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
Related
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
I'm trying to create a very simple 3D plot using the rgl package: I have a function that just maps x values into y values. For a given z (in my example: z = 1), I can plot this function in a 3D plot:
library(rgl)
mycurve <- function(x) { return (1/x)}
myx <- seq(1, 10, by = 0.1)
plot3d(x = NA, xlim = c(0, 10), ylim = c(0, 10), zlim = c(0, 5),
xlab = "x", ylab = "y", zlab = "height")
lines3d(x = myx, y = mycurve(myx), z = 1)
However, even after hours of trying to understand the documentation of ?persp3d and ?surface3d, I still have no idea how to add a surface to my plot that "connects" my line to the x-y plane – like this:
(To generate this image, I cheated by plotting many lines: for (i in seq(0, 1, by = 0.01)) { lines3d(x = myx, y = mycurve(myx), z = i) }.)
I suppose that I need to supply the correct values to surface3d somehow. From ?surface3d:
The surface is defined by the matrix of height values in z, with rows corresponding to the values in x and columns corresponding to the values in y.
Given that my space curve is "vertical", each value of x corresponds to only 1 value of y. Still, I need to specify two z values for each xy pair, which is why I do not know how to proceed.
How can I plot a space curve as shown in the second image?
In persp3d, all 3 arguments can be matrices, so you can plot arbitrary surfaces. For your needs, this works:
mycurve <- function(x) { return (1/x)}
myx <- seq(1, 10, by = 0.1)
xmat <- matrix(NA, 2, length(myx))
ymat <- matrix(NA, 2, length(myx))
zmat <- matrix(NA, 2, length(myx))
for (i in 0:1) {
xmat[i+1,] <- myx
ymat[i+1,] <- mycurve(myx)
zmat[i+1,] <- i
}
library(rgl)
persp3d(x = xmat, y = ymat, z = zmat, xlim = c(0, 10), ylim = c(0, 10), zlim = c(0, 5),
xlab = "x", ylab = "y", zlab = "height", col = "gray")
The image produced looks like this:
If you want z to depend on x or y, you'll likely want a smaller step size, but this works for the surface you're after.
To use the persp3d function one needs to create a matrix for z to correspond to all of the x and y values in the desired range.
I revised your function to take both the x and y parameters and return the desired z value. The outer function will call the function repeatedly to fill the matrix. Then plot, with the defined x and y axis and z (from the outer function)
library(rgl)
mycurve <- function(x, y) { return (1/x)}
myx <- seq(1, 10, by = 0.4)
myy <-seq(1, 10, by =0.4)
#create matrix
data<-outer(myx, myy, mycurve)
#plot points
persp3d(x=myx, y=myy, z=data,
xlab = "x", ylab = "y", zlab = "height")
Using scatterplot3d in R, I'm trying to draw red lines from the observations to the regression plane:
wh <- iris$Species != "setosa"
x <- iris$Sepal.Width[wh]
y <- iris$Sepal.Length[wh]
z <- iris$Petal.Width[wh]
df <- data.frame(x, y, z)
LM <- lm(y ~ x + z, df)
library(scatterplot3d)
G <- scatterplot3d(x, z, y, highlight.3d = FALSE, type = "p")
G$plane3d(LM, draw_polygon = TRUE, draw_lines = FALSE)
To obtain the 3D equivalent of the following picture:
In 2D, I could just use segments:
pred <- predict(model)
segments(x, y, x, pred, col = 2)
But in 3D I got confused with the coordinates.
I decided to include my own implementation as well, in case anyone else wants to use it.
The Regression Plane
require("scatterplot3d")
# Data, linear regression with two explanatory variables
wh <- iris$Species != "setosa"
x <- iris$Sepal.Width[wh]
y <- iris$Sepal.Length[wh]
z <- iris$Petal.Width[wh]
df <- data.frame(x, y, z)
LM <- lm(y ~ x + z, df)
# scatterplot
s3d <- scatterplot3d(x, z, y, pch = 19, type = "p", color = "darkgrey",
main = "Regression Plane", grid = TRUE, box = FALSE,
mar = c(2.5, 2.5, 2, 1.5), angle = 55)
# regression plane
s3d$plane3d(LM, draw_polygon = TRUE, draw_lines = TRUE,
polygon_args = list(col = rgb(.1, .2, .7, .5)))
# overlay positive residuals
wh <- resid(LM) > 0
s3d$points3d(x[wh], z[wh], y[wh], pch = 19)
The Residuals
# scatterplot
s3d <- scatterplot3d(x, z, y, pch = 19, type = "p", color = "darkgrey",
main = "Regression Plane", grid = TRUE, box = FALSE,
mar = c(2.5, 2.5, 2, 1.5), angle = 55)
# compute locations of segments
orig <- s3d$xyz.convert(x, z, y)
plane <- s3d$xyz.convert(x, z, fitted(LM))
i.negpos <- 1 + (resid(LM) > 0) # which residuals are above the plane?
# draw residual distances to regression plane
segments(orig$x, orig$y, plane$x, plane$y, col = "red", lty = c(2, 1)[i.negpos],
lwd = 1.5)
# draw the regression plane
s3d$plane3d(LM, draw_polygon = TRUE, draw_lines = TRUE,
polygon_args = list(col = rgb(0.8, 0.8, 0.8, 0.8)))
# redraw positive residuals and segments above the plane
wh <- resid(LM) > 0
segments(orig$x[wh], orig$y[wh], plane$x[wh], plane$y[wh], col = "red", lty = 1, lwd = 1.5)
s3d$points3d(x[wh], z[wh], y[wh], pch = 19)
The End Result:
While I really appreciate the convenience of the scatterplot3d function, in the end I ended up copying the entire function from github, since several arguments that are in base plot are either forced by or not properly passed to scatterplot3d (e.g. axis rotation with las, character expansion with cex, cex.main, etc.). I am not sure whether such a long and messy chunk of code would be appropriate here, so I included the MWE above.
Anyway, this is what I ended up including in my book:
(Yes, that is actually just the iris data set, don't tell anyone.)
Using the advertising dataset from An Introduction to Statistical Learning, you can do
advertising_fit1 <- lm(sales~TV+radio, data = advertising)
sp <- scatterplot3d::scatterplot3d(advertising$TV,
advertising$radio,
advertising$sales,
angle = 45)
sp$plane3d(advertising_fit1, lty.box = "solid")#,
# polygon_args = list(col = rgb(.1, .2, .7, .5)) # Fill color
orig <- sp$xyz.convert(advertising$TV,
advertising$radio,
advertising$sales)
plane <- sp$xyz.convert(advertising$TV,
advertising$radio, fitted(advertising_fit1))
i.negpos <- 1 + (resid(advertising_fit1) > 0)
segments(orig$x, orig$y, plane$x, plane$y,
col = c("blue", "red")[i.negpos],
lty = 1) # (2:1)[i.negpos]
sp <- FactoClass::addgrids3d(advertising$TV,
advertising$radio,
advertising$sales,
angle = 45,
grid = c("xy", "xz", "yz"))
And another interactive version using rgl package
rgl::plot3d(advertising$TV,
advertising$radio,
advertising$sales, type = "p",
xlab = "TV",
ylab = "radio",
zlab = "Sales", site = 5, lwd = 15)
rgl::planes3d(advertising_fit1$coefficients["TV"],
advertising_fit1$coefficients["radio"], -1,
advertising_fit1$coefficients["(Intercept)"], alpha = 0.3, front = "line")
rgl::segments3d(rep(advertising$TV, each = 2),
rep(advertising$radio, each = 2),
matrix(t(cbind(advertising$sales, predict(advertising_fit1))), nc = 1),
col = c("blue", "red")[i.negpos],
lty = 1) # (2:1)[i.negpos]
rgl::rgl.postscript("./pics/plot-advertising-rgl.pdf","pdf") # does not really work...
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)
I'm using persp() to create a 3d plot (but I'm open to anything that will get the job done). Now I want to add a 2d field to make it clear where the 3d plot is above a specific Z value. Is there a way to achieve this? Ideally it would ideally be something like a semi transparent surface where you can see the mass under the surface vs over.
Using the example from the persp documentation
f <- function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }
x <- seq(-10, 10, length= 30)
y <- x
z <- outer(x, y, f)
z[is.na(z)] <- 1
persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue",
ltheta = 120, shade = 0.75, ticktype = "detailed",
xlab = "X", ylab = "Y", zlab = "Sinc( r )"
)
How can I insert a field that slices the graph at a certain point of the z-axis?
How about this - there are a lot more possibilities using the rgl package, but it has a persp3d function for easy upgrade from the base graphics.
library(rgl)
f <- function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }
x <- seq(-10, 10, length= 30)
y <- x
z <- outer(x, y, f)
z[is.na(z)] <- 1
persp3d(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue",
ltheta = 120, shade = 0.75, ticktype = "detailed",
xlab = "X", ylab = "Y", zlab = "Sinc( r )")
# Here we add a transparent purple square to mark the top
# x and y mark the corners of the purple square, z is its height
sqdf <- data.frame(x=c(-10,-10,10,10,-10),
y=c(-10, 10,10,-10,-10),
z=c(5,5,5,5,5))
# now draw the purple square,
# note:
# - the "add=T" parameter that appends it to the previous 3d-plot
# - the coord paramter tells it what two planes to use when
# tesselating the polygon into triangles
# (a necessary step and expensive to calculate)
polygon3d(sqdf$x,sqdf$y,sqdf$z,coord=c(1,2),alpha=0.5,color="purple",add=T)
Yielding: