I have data in the form (x, y, z) where x and y are not on a regular grid. I wish to display a 2D colormap of these data, with intensity (say, grey scale) mapped to the z variable. An obvious solution is to interpolate (see below) on a regular grid,
d <- data.frame(x=runif(1e3, 0, 30), y=runif(1e3, 0, 30))
d$z = (d$x - 15)^2 + (d$y - 15)^2
library(akima)
d2 <- with(d, interp(x, y, z, xo=seq(0, 30, length = 30),
yo=seq(0, 30, length = 50), duplicate="mean"))
pal1 <- grey(seq(0,1,leng=500))
with(d2, image(sort(x), sort(y), z, useRaster=TRUE, col = pal1))
points(d$x, d$y, col="white", bg=grey(d$z/max(d$z)), pch=21, cex=1,lwd=0.1)
However, this loses the information of the initial mesh (position of the points with actual data), which could be very fine or very rough at certain locations. My preference would be for a delaunay tiling with triangles, which accurately represents the actual location and density of the original data points.
Ideally the solution would
compute the tesselation outside of the plotting function, so that the resulting polygons may be plotted with either ggplot2, lattice, or base graphics
be fast. In my real-life example (~1e5 points), the calculation of the tesselation via deldir can be really slow.
By "tesselation" I mean either Delaunay triangles or Voronoi diagrams, although my preference would be for the former. However it bring the additional complexity of interpolating the colour of each triangle based on the original data points.
Here's a solution based on dirichlet from the maptools package,
d <- data.frame(x=runif(1e3, 0, 30), y=runif(1e3, 0, 30))
d$z = (d$x - 15)^2 + (d$y - 15)^2
library(spatstat)
library(maptools)
W <- ripras(df, shape="rectangle")
W <- owin(c(0, 30), c(0, 30))
X <- as.ppp(d, W=W)
Y <- dirichlet(X)
Z <- as(Y, "SpatialPolygons")
plot(Z, col=grey(d$z/max(d$z)))
I'm still unsure of the way to extract the polygons from this SpatialPolygons class.
Also if there's an easy way to produce the "correct" colors for the associated delaunay tesselation I'd like to hear it.
Here is a lattice solution using deldir
d <- data.frame(x=runif(1e3, 0, 30), y=runif(1e3, 0, 30))
d$z = (d$x - 15)^2 + (d$y - 15)^2
pal1 <- grey(seq(0,1,leng=500))
library(latticeExtra)
levelplot(z~x*y, data=d,
panel = function(...) panel.voronoi(..., points=FALSE),
interpolate=TRUE,
col.regions = colorRampPalette(pal1)(1e3), cut=1e3)
Related
I have spatial coordinate data, and I would like to plot a density map of these coordinates, overlaying a map. The hexbin R package looks promising, but I am struggling to figure out how to plot hexbin data over a map. I would also prefer to stick with base graphics, rather than ggplot.
Here is a simple example of what I am trying to do (that doesn't work):
library(hexbin)
library(sf)
library(maps)
x <- rnorm(10000, mean = 0, sd = 40)
y <- rnorm(10000, mean = 0, sd = 20)
bin <- hexbin(x, y)
pts <- st_as_sf(cbind.data.frame(x,y), coords = 1:2, crs = "+init=epsg:4326")
map(col = gray(0.95), fill=T, lwd=0.2)
plot(pts, add=TRUE, pch = 3, cex=0.5)
Here, the hexbin data are not plotting in the coordinate space of the map.
map(col = gray(0.95), fill=T, lwd=0.2)
plot(bin, style = "colorscale", newpage=FALSE)
Any sugggestions? Thanks!
How can I highlight the ten minimum value grid points of a 385*373 levelplot as black points?
I have the indexes as well as the coordinates of the ten minimum grid points. Preferably I would use the idexes...
I have the following levelplot displaying Europe's air temperature (Z), with X and Y being longitude and latitude respectively.
levelplot(Z ~ X*Y, data=data , xlab="X" , col.regions = heat.colors(100))
One further question: how can I add the country contours with the same projection type as the base data? I tried that before within another function
image(x,y,data,...)
data(wrdl_simpl)
plot(wrld_simpl, add = TRUE)
where the country contours plot seemed to have a totally different projection. However, I want to do this for levelplot() now.
I am very thankful for any help!
lattice plots differ to base plots. Therefore using points does not work. But there are replacement functions. Here is a way to do it:
x <- seq(-10, 10, length.out = 100)
y <- seq(-10, 10, length.out = 100)
z <- as.vector(sqrt(outer(x^2, y^2, "+")))
grid <- cbind(expand.grid(x=x, y=y), z)
minimum <- grid[which.min(grid$z),]
levelplot(z ~ x * y, grid, panel = function(...) {
panel.levelplot(...)
panel.points(x = minimum$x, y = minimum$y, pch = "x", cex =2)
})
We are basically building up the plot inside the panel argument.
I am trying to plot rings of trees and calculate their areas. However, I have noticed that in reality not all rings have symmetric radii like a circle. I have data measurements of 4 radii, and I would like to plot rings (or any similar shape) following each point of every radio like this example (this figure was done manually with vectors in PowerPoint):
the problem is that in R I found only the possibility to plot these rings with the circles option from the symbols() function, and I got this graph:
using this R script:
data <- data.frame(
a = c(1,4,5,8, 10),
b = c(1, 3,7,9, 10),
c = c(2, 6, 8, 9 ,10),
d = c(1, 3, 4, 7, 9) )
data$y <- (data$a - data$b)/2 # y position
data$x <- (data$d - data$c)/2 # x position
data$z <- rowMeans(data[,1:4]) # radio length
symbols(x = data$x, y = data$y, circles=data$z,
xlim = c(-10, 10)*1.5, ylim = c(-10, 10)*1.5, inches = F, fg = "orange", lwd = 2)
I have checked some packages with functions to draw ellipses (elliplot, ellipse, ellipseplot, car, etc), but I don't like their functions. I am not interested in use these packages, on the contrary I would like to write an own code.
My idea is to plot a shape which best meets the real figure of a ring with my data values of the four radii, it can be an ellipse, oval, etc.
With a circle I am using only data of one radio (in my example, the mean of all radii).
With a ellipse would be better, because I can use at least two values, the major-axis (A+B), and the minor-axis (C+D). But would be great to draw a shape that use the values of four radii (A, B, C, D) or even more radii.
Here a guy drew a very nice superellipse using a R script, and another one drew some ellipses likes rings also in R.
However, I don't know how to use their methods to my specific problem.
If somebody have idea how to start drawing at least an ellipse in R would be nice. But would be great to know how to draw a shape (oval, ellipse, etc.) using the values of four radii and finally calculate their area.
I would appreciate very much your help or any direction to do that.
UPDATE:
Thanks #cuttlefish44 for your excellent answer, that was very useful to explain tree growth to my students. However, most tropical trees have very irregular shapes and now I am wondering to know if can I draw this other shape with an additional radio "E" and the radii axes at different positions like this scheme:
any direction would be very useful for me.
If A & B are on y-axis and C & D are on x-axis, it isn't difficult to calculate the parameters of ellipses. I used optim() to get params (Note: this approach has tiny error, such as 2.439826e-12).
data manipulation
# change all data into xy coordinates and make ring-factor
library(reshape2); library(dplyr)
data <- data.frame(
a = c(1, 4, 5, 8, 10),
b = c(1, 3, 7, 9, 10) * -1,
c = c(2, 6, 8, 9, 10) * -1,
d = c(1, 3, 4, 7, 9) )
data <- t(data)
colnames(data) <- LETTERS[1:ncol(data)] # ring-factor
df <- melt(data, value.name = "x") # change into long-form
df$y <- df$x # make xy coordinates
df[df$Var1=="a"|df$Var1=="b", "x"] <- 0
df[df$Var1=="c"|df$Var1=="d", "y"] <- 0
calculation of center coordinates, ox & oy
center <- df %>% group_by(Var2) %>% summarize(sum(x)/2, sum(y)/2) %>% as.data.frame()
calculation of parameters of ellipse; semi-major and -minor axis, ra & rb
opt.f <- function(par, subset, center) { # target function
ox <- center[[1]] # par[1] and par[2] are ra and rb
oy <- center[[2]]
x <- subset$x
y <- subset$y
sum(abs((x - ox)^2/par[1]^2 + (y - oy)^2/par[2]^2 - 1)) # from ellipse equation
}
lev <- levels(df$Var2)
## search parameters
res <- sapply(1:length(lev), function(a)
optim(c(1,1), opt.f, subset = subset(df, Var2 == lev[a]),
center = center[a, 2:3], control = list(reltol = 1.0e-12)))
res # result. you can get detail by res[,1etc]. values are not 0 but much nearly 0
function to plot (Probably some packages have similar one)
radian <- function(degree) degree/180*pi
plot.ellipse <- function(ox, oy, ra, rb, phi=0, start=0, end=360, length=100, func=lines, ...) {
theta <- c(seq(radian(start), radian(end), length=length), radian(end))
if (phi == 0) {
func(ra*cos(theta)+ox, rb*sin(theta)+oy, ...)
} else {
x <- ra*cos(theta)
y <- rb*sin(theta)
phi <- radian(phi)
cosine <- cos(phi)
sine <- sin(phi)
func(cosine*x-sine*y+ox, sine*x+cosine*y+oy, ...)
}
}
draw
plot(0, type="n", xlim=c(-10, 10), ylim =c(-10, 10), asp=1, xlab="x", ylab="y", axes = F)
axis(1, pos=0);axis(2, pos=0, las=2)
points(df$x, df$y)
for(a in 1:length(lev)) plot.ellipse(ox = center[a, 2], oy = center[a, 3],
ra = res[,a]$par[1], rb = res[,a]$par[2], length=300)
area <- sapply(res[1,], function(a) pi * a[1] * a[2])
Is it possible to add the key for, e.g., an sp.points layer, to the colorkey generated by levelplot?
Take the following example:
library(rasterVis)
library(latticeExtra)
library(sp)
r <- as.factor(raster(matrix(rbinom(100, 1, 0.5), 10)))
levels(r)[[1]] <- data.frame(ID=0:1, z=c('a', 'b'))
p <- SpatialPoints(matrix(runif(20), 10))
levelplot(r, margin=list(draw=FALSE), scales=list(draw=FALSE),
col.regions=c('white', 'gray90')) +
latticeExtra::layer(sp.points(p, pch=20, col=1))
I would like to add a key entry for the points, below the existing colorkey.
A kludgy solution is to add a key to the levelplot call as follows, adjusting the x and y values until it's in the desired location, but (1) finding the right x and y values is a pain, requiring interaction, (2) the right padding doesn't resize to accommodate the key, and (3) the font size is not automatically scaled to be consistent with the colorkey.
k <- list(x = 1.02, y = 0.4, corner = c(0, 0), points=list(pch=20, col=1),
text=list('foo', cex=0.9))
levelplot(r, margin=list(draw=FALSE), scales=list(draw=FALSE),
col.regions=c('white', 'gray90'), key=k) +
latticeExtra::layer(sp.points(p, pch=20, col=1))
Assuming I need to stick with lattice graphics, what's the best way to overcome the issues I listed above?
Although it does not solve all the issues you raised, maybe the latticeExtra::mergedTrellisLegendGrob function is useful for you:
p1 <- levelplot(r, scales=list(draw=FALSE),
col.regions=c('white', 'gray90'))
myPoints <- SpatialPoints(matrix(runif(20), 10))
p2 <- spplot(myPoints, pch=20)
## Merge graphics
p <- p1 + p2
## Merge legends
l1 <- p1$legend$right
l2 <- p2$legend$bottom
ll <- mergedTrellisLegendGrob(l1, l2)
p$legend$right$fun <- ll
p
I want to plot a matrix of z values with x rows and y columns as a surface similar to this graph from MATLAB.
Surface plot:
Code to generate matrix:
# Parameters
shape<-1.849241
scale<-38.87986
x<-seq(from = -241.440, to = 241.440, by = 0.240)# 2013 length
y<-seq(from = -241.440, to = 241.440, by = 0.240)
matrix_fun<-matrix(data = 0, nrow = length(x), ncol = length(y))
# Generate two dimensional travel distance probability density function
for (i in 1:length(x)) {
for (j in 1:length(y)){
dxy<-sqrt(x[i]^2+y[j]^2)
prob<-1/(scale^(shape)*gamma(shape))*dxy^(shape-1)*exp(-(dxy/scale))
matrix_fun[i,j]<-prob
}}
# Rescale 2-d pdf to sum to 1
a<-sum(matrix_fun)
matrix_scale<-matrix_fun/a
I am able to generate surface plots using a couple methods (persp(), persp3d(), surface3d()) but the colors aren't displaying the z values (the probabilities held within the matrix). The z values only seem to display as heights not as differentiated colors as in the MATLAB figure.
Example of graph code and graphs:
library(rgl)
persp3d(x=x, y=y, z=matrix_scale, color=rainbow(25, start=min(matrix_scale), end=max(matrix_scale)))
surface3d(x=x, y=y, z=matrix_scale, color=rainbow(25, start=min(matrix_scale), end=max(matrix_scale)))
persp(x=x, y=y, z=matrix_scale, theta=30, phi=30, col=rainbow(25, start=min(matrix_scale), end=max(matrix_scale)), border=NA)
Image of the last graph
Any other tips to recreate the image in R would be most appreciated (i.e. legend bar, axis tick marks, etc.)
So here's a ggplot solution which seems to come a little bit closer to the MATLAB plot
# Parameters
shape<-1.849241
scale<-38.87986
x<-seq(from = -241.440, to = 241.440, by = 2.40)
y<-seq(from = -241.440, to = 241.440, by = 2.40)
df <- expand.grid(x=x,y=y)
df$dxy <- with(df,sqrt(x^2+y^2))
df$prob <- dgamma(df$dxy,shape=shape,scale=scale)
df$prob <- df$prob/sum(df$prob)
library(ggplot2)
library(colorRamps) # for matlab.like(...)
library(scales) # for labels=scientific
ggplot(df, aes(x,y))+
geom_tile(aes(fill=prob))+
scale_fill_gradientn(colours=matlab.like(10), labels=scientific)
BTW: You can generate your data frame of probabilities much more efficiently using the built-in dgamma(...) function, rather than calculating it yourself.
In line with alexis_laz's comment, here is an example using filled.contour. You might want to increase your by to 2.40 since the finer granularity increases the time it takes to generate the plot by a lot but doesn't improve quality.
filled.contour(x = x, y = y, z = matrix_scale, color = terrain.colors)
# terrain.colors is in the base grDevices package
If you want something closer to your color scheme above, you can fiddle with the rainbow function:
filled.contour(x = x, y = y, z = matrix_scale,
color = (function(n, ...) rep(rev(rainbow(n/2, ...)[1:9]), each = 3)))
Finer granularity:
filled.contour(x = x, y = y, z = matrix_scale, nlevels = 150,
color = (function(n, ...)
rev(rep(rainbow(50, start = 0, end = 0.75, ...), each = 3))[5:150]))