I need to mark where certain observations appear in a 3D plotted joint density function -- I envision adding a vector, (x, y, f(x,y) + something_small) to the density plot, showing where the point is. I have tried using trans3d(), but that hasn't worked.
Here is an example:
library(MASS)
Sigma <- matrix(c(12,1,1,12),2,2)
Sample <- mvrnorm(n=1000, rep(0, 2), Sigma)
empDen <- kde2d(Sample[,1],Sample[,2])
par(bg = "white")
x <- empDen$x
y <- empDen$y
z <- empDen$z
nrz <- nrow(z)
ncz <- ncol(z)
jet.colors <- colorRampPalette( c("lightblue", "blue") )
nbcol <- 100
color <- jet.colors(nbcol)
zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]
facetcol <- cut(zfacet, nbcol)
persp(x, y, z, col = color[facetcol], phi = 15, theta = -50, xlab="x", ylab="y", zlab="Empirical Joint Density", border=NA)
The question is: How do I indicate where Sample[1,] appears in the joint density, i.e. add this to the plot?
Thanks for any tips!
This works:
fmt=persp(x, y, z, col = color[facetcol], phi = 15, theta = -50, xlab="x", ylab="y", zlab="Empirical Joint Density", border=NA)
pt = Sample[1,]
points(trans3d(pt[1],pt[2],.001,fmt),pch=20, col="Red")
lines(trans3d(c(pt[1],pt[1]), c(pt[2],pt[2]), c(0,.001),fmt),col="Red",cex=2)
Although, it would be nice to replace .001 with some information based off the empirical joint density instead of manually specifying values for each point.
Related
I am trying to adjust my colour scale on a level plot using the rasterVis package. My code plots a raster. I am using manually set colour scale that classifies that data into 5 quantiles. I would like to have the labels stay at the values I have set, but instead of a linear scale as it appears now, have equal space between the labels. Is this possible with levelplot??
cor = M[, c("lon", "lat")]
sPDF <- SpatialPointsDataFrame (cor, data=M)
proj4string(sPDF)<-(p$geog.proj)
#Create Rasters
grid.sum <- rasterize(x=sPDF, y=grid, field=v, fun=grid.fun)
#Define colour scale
z <- getValues(grid.sum)
z <- z[is.finite(z)]
z <- round(z, digits=0)
quant <- unique(quantile(z, seq(0,1, length.out=75)))
quant.small <- unique(quantile(z, seq(0,1, length.out=5)))
ckey <- list(at=quant, labels=list(at=quant.small))
print(
levelplot(grid.sum, at=quant, colorkey=ckey, col.regions=p$seis,
alpha.regions=1, margin=F, xlab="", ylab="", main=name,
scales = list(x=list(cex=0.7), y=list(cex=0.7)))
+ layer(sp.polygons(coast, fill='lightgrey', alpha = 0.2))
+ layer(sp.lines(contours, col='dimgrey', alpha=0.6, lwd= 0.4)))
How do we make different layers of colours to better see a Multivariate Function in R? I would like to check whether the function is Quasi-Concave and Quasi-Convex, but these things are hard to see in 1 one-colour plot...
# Define Sequences for Multivariate Function
xf3x1 <- seq(-100, 100, length=500)
xf3x2 <- seq(-100, 100, length=500)
# Outer Calculates the Cartesian Product
z <- outer(xf3x1,xf3x2,function(xf3x1,xf3x2) xf3x1*xf3x2)
persp(xf3x1,xf3x2,z,col="lightgreen",theta=30,phi=20, main="Problème 3: Function 3")
The plot3D package is an additional option. persp3D colors by z-value by default:
library(plot3D) # For persp3D function
# Define Sequences for Multivariate Function
#### length=50 to speed up plotting ####
xf3x1 <- seq(-100, 100, length=50)
xf3x2 <- seq(-100, 100, length=50)
# Outer Calculates the Cartesian Product
z <- outer(xf3x1,xf3x2,function(xf3x1,xf3x2) xf3x1*xf3x2)
persp(xf3x1,xf3x2, z, theta=30, phi=20,
col="lightgreen",
main="persp: Black border lines overwhelm plot")
persp(xf3x1,xf3x2, z, theta=30, phi=20,
col="lightgreen",
border="black", lwd=0.2, # Or border=NA per #jlhoward
main="persp: Thinner border lines")
persp3D(xf3x1,xf3x2, z, theta=30, phi=20,
main="persp3D: No borders by default")
persp3D(xf3x1,xf3x2, z, theta=30, phi=20,
border="black", lwd=0.5,
main="persp3D with borders")
First, you need to set border=NA to turn off the borders around the surface facets.
One way is to color based on z-value. Adapting this post:
nrz <- nrow(z)
ncz <- ncol(z)
color <- rev(rainbow(100))
zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]
facetcol <- cut(zfacet, 100)
persp(xf3x1,xf3x2,z,col=color[facetcol],border=NA,,theta=30,phi=20)
I'd encourage you to try surface3d(...) in the rgl package, which creates rotatable 3D plots. The image below is just a screen shot.
zlen <- diff(range(z)) + 1
clrs <- rev(rainbow(zlen))
col <- clrs[ z - min(z) + 1 ] # assign colors to heights for each point
open3d(scale=c(100,100,1))
surface3d(xf3x1,xf3x2,z,col=col, main="Problème 3: Function 3")
axes3d(box=TRUE)
title3d(xlab="xf3f1", ylab="xf3x2", zlab="z")
I am plotting the standard normal distribution.
curve(dnorm(x), from=-4, to=4,
main = "The Standard Normal Distibution",
ylab = "Probability Density",
xlab = "X")
For pedagogical reasons, I want to shade the area below a certain quantile of my choice. How can I do this?
If you want to use curve and base plot, then you can write a little function yourself with polygon:
colorArea <- function(from, to, density, ..., col="blue", dens=NULL){
y_seq <- seq(from, to, length.out=500)
d <- c(0, density(y_seq, ...), 0)
polygon(c(from, y_seq, to), d, col=col, density=dens)
}
A little example follows:
curve(dnorm(x), from=-4, to=4,
main = "The Standard Normal Distibution",
ylab = "Probability Density",
xlab = "X")
colorArea(from=-4, to=qnorm(0.025), dnorm)
colorArea(from=qnorm(0.975), to=4, dnorm, mean=0, sd=1, col=2, dens=20)
We could use the following R code too, in order to shade the regions under the standard normal curve below a certain (given) quantile:
library(ggplot2)
z <- seq(-4,4,0.01)
fz <- dnorm(z)
q <- qnorm(0.1) # the quantile
x <- seq(-4, q, 0.01)
y <- c(dnorm(x), 0, 0)
x <- c(x, q, -4)
ggplot() + geom_line(aes(z, fz)) +
geom_polygon(data = data.frame(x=x, y=y), aes(x, y), fill='blue')
May be it is very simple to do, but after hours of searching I didn't able to find how to add colorbar beside the persp plot using R. Could anyone kindly help? Thanks.
persp(w_lb, w_dti, cm[[i]],
theta = -30, phi = 30, expand = 0.95,
col=color[facetcol], shade = 0.25,
ticktype = "detailed", border = NA,
xlab = "LB", ylab = "DT", zlab="CM",
zlim=c(0.0, 1.0)
)
It's possible to add a legend using image.plot in the fields package. Using an example from ?persp:
library(fields)
## persp example code
par(bg = "white")
x <- seq(-1.95, 1.95, length = 30)
y <- seq(-1.95, 1.95, length = 35)
z <- outer(x, y, function(a, b) a*b^2)
nrz <- nrow(z)
ncz <- ncol(z)
# Create a function interpolating colors in the range of specified colors
jet.colors <- colorRampPalette( c("blue", "green") )
# Generate the desired number of colors from this palette
nbcol <- 100
color <- jet.colors(nbcol)
# Compute the z-value at the facet centres
zfacet <- (z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz])/4
# Recode facet z-values into color indices
facetcol <- cut(zfacet, nbcol)
persp(x, y, z, col = color[facetcol], phi = 30, theta = -30, axes=T, ticktype='detailed')
## add color bar
image.plot(legend.only=T, zlim=range(zfacet), col=color)
EDIT thanks to #Marc_in_the_box: the range of the colorbar is defined by zfacet, not by z
persp has a tricky way of computing colors based on the mid points of the facets. This makes your work a bit difficult in extracting the color levels, but I think I have found a way. In any case, layout is probably your best bet for splitting your device and adding a color bar:
Example:
layout(matrix(1:2, nrow=1, ncol=2), widths=c(4,1), heights=1)
par(bg = "white", mar=c(4,4,1,1))
x <- seq(-1.95, 1.95, length = 30)
y <- seq(-1.95, 1.95, length = 35)
z <- outer(x, y, function(a, b) a*b^2)
nrz <- nrow(z)
ncz <- ncol(z)
# Create a function interpolating colors in the range of specified colors
jet.colors <- colorRampPalette( c("blue", "green") )
# Generate the desired number of colors from this palette
nbcol <- 100
color <- jet.colors(nbcol)
# Compute the z-value at the facet centres
zfacet <- (z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz])/4
# Recode facet z-values into color indices
facetcol <- cut(zfacet, nbcol)
persp(x, y, z, col = color[facetcol], phi = 30, theta = -30)
labs <- levels(facetcol)
tmp <- cbind(lower = as.numeric( sub("\\((.+),.*", "\\1", labs) ),
upper = as.numeric( sub("[^,]*,([^]]*)\\]", "\\1", labs) ))
par(mar=c(10,0,10,5))
image(x=1, y=rowMeans(tmp), matrix(rowMeans(tmp), nrow=1, ncol=nbcol), col=color, axes=FALSE, xlab="", ylab="")
axis(4)
box()
btw, I realized that the last example from persp looks to have an error in it's calculation of facet values - as is, they are the sum of the corner values, and need to be divided by 4 in order to use them directly in extracting the color break points:
# Compute the z-value at the facet centres
zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]
# Recode facet z-values into color indices
facetcol <- cut(zfacet, nbcol)
#should be:
# Compute the z-value at the facet centres
zfacet <- (z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]) / 4
# Recode facet z-values into color indices
facetcol <- cut(zfacet, nbcol)
I want to plot the regression surface from a model with an interaction term using rgl's interactive plotting system. It is easy to plot a regression plane for a model without an interaction term using:
plot3d(x=x1, y=x2, z=y1, type="s", col="yellow", size=1)
planes3d(a=coef(mod1)[2], b=coef(mod1)[3], c=-1, d=coef(mod1)[1], alpha=.5)
However, when the plane twists, this seems to be more difficult. Following on this question: 3D equivalent of the curve function in r, I am trying:
f2 <- function(x, y) as.vector(coef(mod2)%*%c(1, x, y, x*y))
curve_3d <- function(f2, x_range=c(0, 40), y_range=c(0, 40)){
if (!require(rgl) ) {stop("load rgl")}
xvec <- seq(x_range[1], x_range[2], by=1)
yvec <- seq(y_range[1], y_range[2], by=1)
fz <- outer(xvec, yvec, FUN=f2)
persp3d(xvec, yvec, fz, alpha=.5)
}
open3d()
plot3d(x=x1, y=x2, z=y2, type="s", col="yellow", size=1)
curve_3d(f2)
But, it's not working. (I've tried some other things as well, but I'm keeping this short.) My main problem so far seems to be with f2; however, I will also want this to look like planes3d, and I'm not sure if this is going to give me a wireframe.
Here's an example:
set.seed(897)
x1 = rep(c(0, 10, 20, 30, 40), times=25)
x2 = rep(c(0, 10, 20, 30, 40), each=25)
y2 = 37 + 0.7*x1 + 1.2*x2 - 0.05*x1*x2 + rnorm(125, mean=0, sd=5)
mod2 = lm(y2~x1*x2)
open3d()
plot3d(x=x1, y=x2, z=y2, type="s", col="yellow", size=1)
curve_3d(f2)
grd <- expand.grid(x1=unique(x1), x2=unique(x2) )
grd$pred <-predict(mod2, newdata=grd)
persp3d(x=unique(grd[[1]]), y=unique(grd[[2]]),
z=matrix(grd[[3]],5,5), add=TRUE)