Related
I have a problem where I have data with (x,y) coordinates that I want to plot in the x-y plane. Furthermore, I have some box constraints such that -7 < x < 7 and -5 < y < 5 need to be drawn and checked. All points that fall outside of this box constraint I would like to color red. To do this I have the following code in R:
library(rgl)
x <- 7
y <- 5
data.x <- rnorm(10,0,5)
data.y <- rnorm(10,0,5)
plot(data.x, data.y, xlim = c(min(-x,data.x),max(x,data.x)),
ylim = c(min(-y,data.y),max(y,data.y)), pch = 19)
rect(-x, -y, x, y, col = "lightgrey")
idx <- abs(data.x) > x | abs(data.y) > y
points(data.x[idx], data.y[idx], col = "red", pch = 19)
points(data.x[!idx], data.y[!idx], col = "deepskyblue", pch = 19)
Now, where I am stuck, is on how to plot this type of data picture when I have a third group of data and a third constraint. I.e.,
### How to generalize when I have a third axis and constraint, i.e., a 3D cube
z <- 4
data.z <- rnorm(10, 0, 5)
So essentially I want to plot a box constraint as a cube in the x-y-z plane, and to color the points that fall outside the box constraint red again.
Also, I should say I understand there are functions for plottig 3d scatter plots in R, however, what I am struggling with is how to draw the 3D cube that defines the constraints.
The difficulty with a 3D plot such as this is being able to interpret the "depth" of the points in the image. An animated 3D image might be helpful here:
library(plot3D)
x <- 7
y <- 5
z <- 6
set.seed(123)
data.x <- rnorm(10, 0, 5)
data.y <- rnorm(10, 0, 5)
data.z <- rnorm(10, 0, 5)
in_out <- abs(data.x) > x | abs(data.y) > y | abs(data.z) > z
for(i in seq(0, 358, 2)) {
png(paste0("box", sprintf("%03d", i), ".png"))
box3D(-x, -y, -z, x, y, z, col = NA, border = "gray50", theta = i, phi = 15,
xlim = c(-10, 10), ylim = c(-10, 10), zlim = c(-10, 10),
axes = TRUE, ticktype = "detailed")
points3D(data.x, data.y, data.z, colvar = in_out, pch = 16, cex = 3,
add = TRUE, colkey = FALSE, col = c("lightblue", "red"))
dev.off()
}
library(magick)
list.files(pattern = 'box\\d+\\.png', full.names = TRUE) %>%
image_read() %>%
image_join() %>%
image_animate(fps=50) %>%
image_write("box.gif")
box.gif
I'm hoping to keep in the image below the ticks on the vertical z axis, but remove ticks and numbers from the x and y axes. I would like to be able to label my x and y axes with a label for each condition in my matrix, but have not figured out how to do this with text3D. For some reason (because I'm on a mac?) I can't download axes3D, which is one potential solution I've seen in other responses.
Here is my code:
x = c(0,1)
y = c(0,1)
zval = c(104.1861, 108.529, 110.3675, 110.4112)
z = matrix (zval, nrow=2, ncol=2, byrow=TRUE)
hist3D(x,y,z, zlim=c(101,111), colvar = NULL, d=2, col = "lightblue", NAcol = "white", breaks = NULL, colkey = NULL, theta=-60, phi=20, nticks=10, axes=TRUE, ticktype="detailed", space=0.5, lighting=TRUE, light="diffuse", shade=.5, ltheta = 50, bty = "g")
My output
Ultimately, I'd like something more along the lines of this:
I'm very new to R.
stackoverflow.com/questions/26794236/ggplot2-3d-bar-plot
^ this seems like it might be what I need, but I couldn't replicate the code without an error. When I tried to run this piece I got an error because my x and z (in this case) axes aren't numerical:
cloud(y~x+z, d, panel.3d.cloud=panel.3dbars, col.facet='grey', xbase=0.4, ybase=0.4, scales=list(arrows=FALSE, col=1), par.settings = list(axis.line = list(col = "transparent")))
Maybe this might be helpful (with the caveat that 3D plots can sometimes make interpretation more challenging).
First, I recreated a data frame d based on something similar to what you started with:
x = c(0, 0, 1, 1)
y = c(0, 1, 0, 1)
z = c(104.1861, 108.529, 110.3675, 110.4112)
d <- data.frame(
x = factor(as.logical(x)),
y = factor(as.logical(y)),
z = z
)
Note that for x and y I converted the 0 and 1 to FALSE and TRUE with as.logical, then made them factors.
Then for the plot:
library(latticeExtra)
cloud(z ~ x + y, data = d, panel.3d.cloud=panel.3dbars, col.facet='grey',
xbase=0.4, ybase=0.4, scales=list(arrows=FALSE, col=1),
par.settings = list(axis.line = list(col = "transparent")))
You will want the formula as z ~ x + y where z is a numeric response.
Edit: If you wish to customize the axis labels, you can set the factor labels as follows (for example):
d <- data.frame(
x = factor(as.logical(x), labels = c("Hi", "Lo")),
y = factor(as.logical(y), labels = c("Label1", "Label2")),
z = z
)
Plot
I am having a 3D plot in which the points are colored acording to some extra vector. My problem is to add a color gradient legend. This is my code:
x = matrix(NA,100,6)
#x value
x[,1] = runif(100, 0, 10)
#y value
x[,2] = runif(100, 0, 10)
#z value
x[,3] = x[,1]+x[,2]
#additional value
x[,4] = runif(100, 0, 1)
#find out in which interval each additional value is
intervals = seq(0,1,1/10)
x[,5] = findInterval(x[,4], intervals)
colours = topo.colors(length(intervals))
x[,6] = colours[x[,5]]
library(rgl)
plot3d(as.numeric(x[,1]),as.numeric(x.stab.in[,2]), as.numeric(x[,3]),
type="p", col=x[,6], size=2, xlab = "x(t)", ylab = "y(t)",
zlab = "z(t)")
decorate3d(xlab = "x", ylab = "y", zlab = "z")
legend3d("topright", legend = intervals, pch = 16, col = colours, cex=1, inset=c(0.02))
grid3d(c("x", "y+", "z"),col = "gray")
The plot looks like this
but I want the legend in a gradient form. That means I don't want separate points for each color but one box in which the colors fade into each other.
Here is a possible solution if you are okay with using scatterplot3d package instead of rgl. It is basically same but non-interactive. Here is your code modified to produce your expected result.
x = matrix(NA,100,6)
#x value
x[,1] = runif(100, 0, 10)
#y value
x[,2] = runif(100, 0, 10)
#z value
x[,3] = x[,1]+x[,2]
#additional value
x[,4] = runif(100, 0, 1)
#find out in which interval each additional value is
intervals = seq(0,1,1/10)
x[,5] = findInterval(x[,4], intervals)
#produce gradient of colors
#you can define different colors (two or more)
gradient <- colorRampPalette(colors = c("yellow", "green", "blue"))
colours <- gradient(length(intervals))
x[,6] = colours[x[,5]]
library(scatterplot3d)
png('3d.png', width = 600, height = 400)
layout(matrix(1:2, ncol=2), width = c(3, 1), height = c(1, 1))
scatterplot3d(as.numeric(x[,1]),as.numeric(x[,2]), as.numeric(x[,3]), type = 'p',
cex.symbols = 1.25, color=x[,6], pch = 16, xlab = "x(t)", ylab = "y(t)", zlab = "z(t)")
plot(x = rep(1, 100), y = seq_along(x[,6]),
pch = 15, cex = 2.5,
col = gradient(length(x[,6])),
ann = F, axes = F, xlim = c(1, 2))
axis(side = 2, at = seq(1, nrow(x), length.out = 11),
labels = 1:11,
line = 0.15)
dev.off()
This will plot the following graph
Here is another solution if you want to plot a gradient on an interactive 3d plot, such as if you needed to animate the plot into a movie.
require(car)
require(rgl)
require(RColorBrewer)
require(mgcv)
require(magick) #Only for creating the animation of the plot as a gif
#Creating mock dataset
Example_Data <- data.frame(Axis1 = rnorm(100),
Axis2 = rnorm(100),
Axis3 = rnorm(100))
Example_Data$Value <- Example_Data$Axis1+Example_Data$Axis2
#Defining function that takes a vector of numeric values and converts them to
#a spectrum of rgb colors to help color my scatter3d plot
get_colors <- function(values){
v <- (values - min(values))/diff(range(values))
x <- colorRamp(rev(brewer.pal(11, "Spectral")))(v)
rgb(x[,1], x[,2], x[,3], maxColorValue = 255)
}
#Writing function that takes a vector of numeric values and a title and creates
#a gradient legend based on those values and the title and suitable for addition
#to a scatter3d plot via a call to bgplot3d()
#Note, I didn't have time to make this automatically adjust text position/size for different size
#plot windows, so values may need to be adjusted manually depending on the size of the plot window.
gradient_legend_3d <- function(values, title){
min_val <- min(values)
max_val <- max(values)
x <- colorRamp(brewer.pal(11, "Spectral"))((0:20)/20)
colors <- rgb(x[,1], x[,2], x[,3], maxColorValue = 255)
legend_image <- as.raster(matrix(colors, ncol=1))
plot(c(0,1),c(0,1),type = 'n', axes = F,xlab = '', ylab = '', main = '') #Generates a blank plot
text(x=0.92, y = seq(0.5, 1,l=5), labels = signif(seq(min_val, max_val,l=5), 2), cex = 1.5) #Creates the numeric labels on the scale
text(x = 0.85, y = 1, labels = title, adj = 1, srt = 90, cex = 1.5) #Determines where the title is placed
rasterImage(legend_image, 0.87, 0.5, 0.9,1) #Values can be modified here to alter where and how wide/tall the gradient is drawn in the plotting area
}
#Creating scatter3d plot
scatter3d(x = Example_Data$Axis1, y = Example_Data$Axis2, z = Example_Data$Axis3, xlab = "Axis1", ylab = "Axis2", zlab = "Axis3", surface = F, grid = F, ellipsoid = F, fogtype = "none", point.col = get_colors(Example_Data$Value))
#Changing size of plotting window and orientation to optimize for addition of static legend
#This may not work on another machine, so the window may need to be adjusted manually
par3d(windowRect = c(0,23,1536,824))
par3d(userMatrix = matrix(c(-0.98181450, -0.02413967, 0.18830180, 0, -0.03652956, 0.99736959, -0.06260729, 0, -0.18629514, -0.06834736, -0.98011345, 0, 0, 0, 0, 1), nrow = 4, ncol = 4, byrow = T))
#Adding legend
bgplot3d(gradient_legend_3d(Example_Data$Value, "Point Value"))
#Animating plot and saving as gif
movie3d(spin3d(axis = c(0,1,0), rpm = 5), duration = 12, dir = getwd(), fps = 5, convert = FALSE, clean = FALSE)
frames <- NULL
for(j in 0:60){
if(j == 1){
frames <- image_read(sprintf("%s%03d.png", "movie", j))
} else {
frames <- c(frames, image_read(sprintf("%s%03d.png", "movie", j)))
}
}
animation <- image_animate(frames, fps = 10, optimize = TRUE)
image_write(animation, path = "Example.gif")
for(j in 0:60){
unlink(sprintf("%s%03d.png", "movie", j))
}
See link to view 3d plot generated by this code:
gif of 3d plot with gradient color scale
Say I have a set of coordinates like this, for example:
m <- data.frame(replicate(2,sample(0:9,20,rep=TRUE)))
And I want to draw a box around all of the points so that it creates a minimum bounding rectangle.
a <- bounding.box.xy(m)
plot(m)
par(new=T)
plot(a, main="Minimum bounding rectangle")
But the box doesn't go around all of the points.
I am also interested in drawing a standard deviation circle/ellipse around these points but I don't know the function for this.
RECTANGLE
You can obtain the value of minimum and maximum x and y and then draw polygon using those values. Try this:
set.seed(42)
m <- data.frame(replicate(2,sample(0:9,20,rep=TRUE)))
lx = min(m$X1)
ux = max(m$X1)
ly = min(m$X2)
uy = max(m$X2)
plot(m)
title(main = "Minimum bounding rectangle")
polygon(x = c(lx, ux, ux, lx), y = c(ly, ly, uy, uy), lty = 2)
POLYGON
More discussion about drawing a curve around a set of points can be found here. One way is to exploit the chull command for creating convex hull.
First import the following function
plot_boundary <- function(x,y,offset = 0,lty = 1,lwd = 1,border = "black",col = NA){
# 'offset' defines how much the convex hull should be bumped out (or in if negative value)
# relative to centroid of the points. Typically value of 0.1 works well
BX = x + offset*(x-mean(x))
BY = y + offset*(y-mean(y))
k2 = chull(BX,BY)
polygon(BX[k2],BY[k2],lty = lty,lwd = lwd,border = border,col = col)
}
Then you can generate data and plot boundary around it.
set.seed(242)
m <- data.frame(replicate(2,sample(0:9,20,rep=TRUE)))
plot(m, xlim = c(0,10), ylim = c(0,10))
title(main = "Minimum bounding rectangle")
plot_boundary(x = m$X1, y = m$X2, lty = 2)
ELLIPSE
set.seed(42)
A = data.frame(x = rnorm(20, 25, 4), y = rnorm(20, 11, 3))
B = data.frame(x = rnorm(20, 12, 5), y = rnorm(20, 5, 7))
plot(rbind(A,B), type = "n", ylim = c(-10,20), xlim = c(0,40), asp = 1)
require(ellipse)
red_eli = ellipse(cor(A$x,A$y), scale = c(sd(A$x), sd(A$y)),
centre = c(mean(A$x), mean(A$y)))
blue_eli = ellipse(cor(B$x,B$y), scale = c(sd(B$x), sd(B$y)),
centre = c(mean(B$x), mean(B$y)))
points(A, pch = 19, col = "red")
points(B, pch = 18, col = "blue")
lines(red_eli, col = "red")
lines(blue_eli, col = "blue", lty = 2)
Using the sample data below, how can I generate rasters and spatial points plot with the same colorkey as in the "manually" joined plot shown below?
library(rasterVis)
library(raster)
library(colorRamps)
col=colorRampPalette(matlab.like2(255))
s <- stack(replicate(2, raster(matrix(runif(100), 10))))
xy <- data.frame(coordinates(sampleRandom(s, 10, sp=TRUE)),
z1=runif(10), z2=runif(10))
levelplot(s, margin=FALSE, at=seq(0, 1, 0.05),col.regions=col)
x=xy$x;y=xy$y;z=xy$z1
levelplot(z ~ x + y,contour=F, panel = panel.levelplot.points,
margin=FALSE,col.regions=col,
par.settings=list(axis.line=list(lwd=3), strip.border=list(lwd=3)),
cex=1.4, scales=list(x=list(cex=1.7),y=list(cex=1.7)),xlab=list(label="Longitude",cex=2),
ylab=list(label="Latitude",cex=2))
Thanks to #fdestch I was able to generate the following plot using:
latticeCombineGrid(mget(rep("pp", 24)), layout = c(3, 8))
following my comments on printing multiple plots with the same colorkey.
An issue that remains to be clarified:
1) How can one decide on the order of panels? That is, which row & column to place a particular plot just as in levelplot using index.cond.
First of all, you should probably make sure that the breaks in the points plot are identical with those defined in the first levelplot.
## raster plot with colorkey disabled
pr <- levelplot(s, margin = FALSE, at = seq(0, 1, 0.05), col.regions = col,
colorkey = FALSE, xlab = list("Longitude", col = "transparent"))
## points plot
pp <- levelplot(z ~ x + y, panel = panel.levelplot.points, cex = 1.4,
contour = FALSE, margin = FALSE, col.regions = col,
colorkey = list(at = seq(0, 1, .05), width = .6, height = .6),
xlab = "Longitude", ylab = "Latitude")
Please note the definition of a transparent xlab when creating the raster plot. This little workaround comes in quite handy when using downViewport later on to ensure that the actual plot boundaries of pr and pp overlap (feel free to run grid.rect() right after print(pr, newpage = FALSE) to see what I mean).
The actual plot arrangement can then easily be achieved by using viewports from the grid package.
library(grid)
library(lattice)
## initialize new grid device
grid.newpage()
## add raster plot
vp1 <- viewport(x = 0, y = 0, width = .5, height = 1,
just = c("left", "bottom"))
pushViewport(vp1)
print(pr, newpage = FALSE)
## add points plot
downViewport(trellis.vpname("page"))
vp2 <- viewport(x = 1, y = 0, width = .75, height = 1,
just = c("left", "bottom"))
pushViewport(vp2)
print(pp, newpage = FALSE)
Here is my solution using latticeExtra::c.trellis:
library(raster)
library(rasterVis)
s <- stack(replicate(2, raster(matrix(runif(100), 10))))
xy <- data.frame(coordinates(sampleRandom(s, 10, sp=TRUE)),
z1=runif(10), z2=runif(10))
## Define theme and breaks
myTheme <- BTCTheme()
my.at <- seq(0, 1, 0.05)
Plot the Raster* object, using rasterVis::levelplot:
p1 <- levelplot(s, margin=FALSE,
at = my.at,
par.settings = myTheme)
Plot the points, using lattice::levelplot:
p2 <- levelplot(z1 ~ x + y, data = xy,
at = my.at,
panel = panel.levelplot.points,
par.settings = myTheme)
Join them with latticeExtra::c.trellis:
p3 <- c(p1, p2, layout = c(3, 1))
Unfortunately, c.trellis does not assign the strip labels correctly, so you have to define them directly:
update(p3,
strip = strip.custom(factor.levels = c(names(s), "Points")))