I'm plotting Ackley's function in R and I'd like to have an additional contour plot on the bottom of the plot. Here is what I'm doing:
library(fields)
ackley <- function(x1, x2) {
a <- 20
b <- 0.2
c <- (2*pi)
d <- 2
fofx1 <- -a*exp(-b*sqrt(1/d*sum(c(x1,x2)^2))) -
exp(sum( cos(c*c(x1,x2))/d))+a+exp(1)
return(fofx1)
}
Ackley <- Vectorize(ackley)
x1 <- seq(-4,4,length=150)
x2 <- seq(-4,4,length=150)
z <- outer(x1, x2, FUN="Ackley")
drape.plot( x1,x2,z, col=rev(rainbow(50)), horizontal = FALSE)
Is it possible with drape.plot() to add the contour or are there other alternatives?
The plot3D library offers a nice solution. See here for details.
library(plot3D)
ackley <- function(x1, x2) {
a <- 20
b <- 0.2
c <- (2*pi)
d <- 2
fofx1 <- -a*exp(-b*sqrt(1/d*sum(c(x1,x2)^2))) -
exp(sum( cos(c*c(x1,x2))/d))+a+exp(1)
return(fofx1)
}
Ackley <- Vectorize(ackley)
x1 <- seq(-4,4,length=150)
x2 <- seq(-4,4,length=150)
z <- outer(x1, x2, FUN="Ackley")
zlim <- c(0, 15)
persp3D(x=x1, y=x2, z = z, xlab = "x1", bty = "bl2",
ylab = "x2", zlab = "z", clab = "",
expand = 0.5, d = 2, phi = 20, theta = 30, resfac = 2,
contour = list(col = "grey", side = c("zmin", "z")),
zlim = zlim, colkey = list(side = 4, length = 0.5))
Related
I'm trying to make a figure similar to this in R. Basically X and Y represent coordinates (e.g. lon/lat) and Z represents elevation. I want to plot a 3D bar chart with a elevation as the bar height, and then show a smooth curve of fitted Z values going through the bars. I am able to get a 3d barplot with barplot3d but I'm not sure if it's possible to add the fitted curve on top of that. Does anyone know how to do this? I have some example code below demonstrating what I've tried so far.
library(rgl)
library(barplot3d)
library(tidyverse)
x_mat<- matrix(rep(-1:1, each=3),nrow = 3) #x coordinates
y_mat<- matrix(rev(rep(-1:1, each=3)),nrow = 3, byrow = TRUE) #y coordinates
df<- data.frame(x = as.vector(x_mat), y = as.vector(y_mat)) #dataframe
set.seed(5)
df<- df %>% mutate(z= x^2+ y^2 + rnorm(n = 9, mean = 0, sd = 0.1)) #add elevation values
m<- lm(z ~ I(x^2)+I(y^2)+I(x*y)+x+y, data = df) #fitted curve
rgl.open()
rgl::plot3d(m)
barplot3d(rows=3,cols=3, z=df$z,scalexy=1, gap=0, alpha=0.4,theta=30,phi=50,
topcolors = "gray", gridlines = TRUE)
Update: More complicated example
The curve doesn't seem to intersect the bars properly with current solution for a non-symmetrical curve (fixed in most updated answer).
library(rgl)
library(barplot3d)
library(tidyverse)
x_mat<- matrix(rep(-1:1, each=3),nrow = 3) #x coordinates
y_mat<- matrix(rev(rep(-1:1, each=3)),nrow = 3, byrow = TRUE) #y coordinates
A<- 0.2
B<- 0.2
C<- 0.4
D<- 0.4
E<- 0
df<- data.frame(x = as.vector(x_mat), y = as.vector(y_mat)) #dataframe
df<- df %>% mutate(z= A*x^2 + B*y^2 + C*x*y + D*x + E*y) #add elevation values
z_mat<- matrix(data = df$z, nrow=3)
m<- lm(z ~ I(x^2)+I(y^2)+I(x*y)+x+y, data = df) #fitted curve
df$zpred<- predict(m, data.frame(x=df$x, y=df$y))
round(df$z-df$zpred,10) #Predictions should fit observations almost exactly (i.e. intersect exactly with bars)
#0 0 0 0 0 0 0 0 0
n<- 10
xvals <- seq(-1, 1, len = n)
xmat <- replicate(n, seq(1.5, 3.5, len = n))
ymat <- t(xmat)
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), nrow = n, ncol = n)
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", sidecolors = "cyan", linecolors= "blue", gridlines = FALSE, zlabels = FALSE)
surface3d(x = xmat, y = zmat, z = ymat-5, color = "purple", alpha = 0.7)
axes3d()
As you can probably tell, your 3d surface is rotated 90 degrees relative to where it should be. This is not your fault; it is just a difference between the way barplot3d is drawn compared to the other rgl shapes. You also need a bit of shifting and rescaling to get it to fit.
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", gridlines = TRUE)
xvals <- seq(-1.5, 1.5, len = 10)
xmat <- replicate(10, seq(1, 4, len = 10))
ymat <- t(xmat)
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 10, 10)
surface3d(xmat, zmat, color = "gold", alpha = 0.5, ymat - 5)
Update
To remove the points above the highest bar, just set them to NA. You probably want to increase the resolution when you do this though:
xvals <- seq(-1.5, 1.5, len = 100)
xmat <- replicate(100, seq(1, 4, len = 100))
ymat <- t(xmat) - 5
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 100, 100)
zmat[zmat > 2] <- NA
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", gridlines = TRUE)
surface3d(xmat, zmat, color = "gold", alpha = 0.5, ymat)
Note that this gives an unavoidably ragged edge to the graphic
An alternative is to shrink the x, y grids at which z is calculated:
xvals <- seq(-1, 1, len = 100)
xmat <- replicate(100, seq(1.5, 3.5, len = 100))
ymat <- t(xmat) - 5
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 100, 100)
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", gridlines = TRUE)
surface3d(xmat, zmat, ymat, color = "gray20", alpha = 0.5)
Further update
It looks as though we need a double flip to get the z values correct:
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", sidecolors = "cyan", linecolors= "blue",
gridlines = FALSE, zlabels = FALSE)
surface3d(x = xmat, y = t(apply(t(apply(zmat, 1, rev)), 2, rev)),
z = ymat-5, color = "purple", alpha = 0.7)
axes3d()
library(ROCR);
lig <- unique(read.table("ligands.txt")[,1]);
dec <- unique(read.table("decoys.txt")[,1]);
uniqRes <- read.table("file1.txt",header=T);
colnames(uniqRes)[1]="LigandName";
uniqRes$IsActive <- as.numeric(uniqRes$LigandName %in% lig)
predTOTALuq <- prediction(uniqRes$TOTAL*-1, uniqRes$IsActive)
perfTOTALuq <- performance(predTOTALuq, 'tpr','fpr')
jpeg("hivpr_Rinter_ROC.jpg")
plot(perfTOTALuq,main="hivpr - ROC Curves",col="blue")
abline(0,1,col="grey")
dev.off()
here is the code for plotting single curve by taking data from single file.
i want to plot 3 curves in same plot by taking data from three different files i.e. file 1, file 2, file 3
please help me to do so
you can add abline or curve directly.
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = 1:13, y = 2:14)
df3 <- data.frame(x = 6:10, y = 2:6)
lx <- range(c(df1$x, df2$x, df3$x))
ly <- range(c(df1$y, df2$y, df3$y))
plot(df1, main = "hivpr - ROC Curves", xlim = lx, ylim = ly, col = "blue")
abline(0, 1, col = "blue")
points(df2, col = 'red3')
points(df3, col = 'yellow')
How add the contours under the graph using the R as in plot 2?
I've searched a lot on the internet and found no example of how to do it in R! Is there any function or package to add the outline along with the chart?
#Function density probability
library(pbivnorm)
bsb <- function(t1,t2){
a1 <- sqrt(phi1/2)*(sqrt(((phi1+1)*t1)/(phi1*mu1))-sqrt(((phi1*mu1)/((phi1+1)*t1))))
a2 <- sqrt(phi2/2)*(sqrt(((phi2+1)*t2)/(phi2*mu2))-sqrt(((phi2*mu2)/((phi2+1)*t2))))
Phi2 <- pbivnorm(a1, a2, rho, recycle = TRUE)
b1 <- ((phi1+1)/(2*phi1*mu1))*sqrt(phi1/2)*(((phi1*mu1)/((phi1+1)*t1))^(1/2)+((phi1*mu1)/((phi1+1)*t1))^(3/2))
b2 <- ((phi2+1)/(2*phi2*mu2))*sqrt(phi2/2)*(((phi2*mu2)/((phi2+1)*t2))^(1/2)+((phi2*mu2)/((phi2+1)*t2))^(3/2))
fdp <- Phi2*b1*b2
return(fdp)
}
t1 <- seq(0.001,5,length=100)
t2 <- seq(0.001,5,length=100)
#Parameters
mu1=5
phi1=2
mu2=5
phi2=2
rho=0.9
z<-outer(t1,t2,bsb) # calculate density values
persp(t1, t2, z, # 3-D plot
main="Bivariate Birnbaum-Saunders",
col="lightgray",
theta=40, phi=10,
r=10,
d=0.9,
expand=0.5,
ltheta=90, lphi=80,
shade=0.9,
ticktype="detailed",
nticks=5)
As #alistaire pointed out, it actually requires a single line to get the plotly version, see for documentation to edit details of the plot (https://plot.ly/r/3d-surface-plots/)
test<-outer(t1,t2,bsb) # your output matrix
p <- plot_ly(z = ~test) %>% add_surface()
p
Resolved:
source("https://raw.githubusercontent.com/walmes/wzRfun/master/R/panel.3d.contour.R")
library(lattice)
library(manipulate)
library(colorRamps)
#Function density probability
library(pbivnorm)
bsb <- function(t1,t2){
a1 <- sqrt(phi1/2)*(sqrt(((phi1+1)*t1)/(phi1*mu1))-sqrt(((phi1*mu1)/((phi1+1)*t1))))
a2 <- sqrt(phi2/2)*(sqrt(((phi2+1)*t2)/(phi2*mu2))-sqrt(((phi2*mu2)/((phi2+1)*t2))))
Phi2 <- pbivnorm(a1, a2, rho, recycle = TRUE)
b1 <- ((phi1+1)/(2*phi1*mu1))*sqrt(phi1/2)*(((phi1*mu1)/((phi1+1)*t1))^(1/2)+((phi1*mu1)/((phi1+1)*t1))^(3/2))
b2 <- ((phi2+1)/(2*phi2*mu2))*sqrt(phi2/2)*(((phi2*mu2)/((phi2+1)*t2))^(1/2)+((phi2*mu2)/((phi2+1)*t2))^(3/2))
fdp <- Phi2*b1*b2
return(fdp)
}
#Parameters
mu1=5
phi1=2
mu2=5
phi2=2
rho=0.9
grid <- expand.grid(t1 = seq(0.001,8, by = 0.1),
t2 = seq(0.001,8, by = 0.1))
grid$z <- bsb(grid$t1,grid$t2)
manipulate({
## Makes the three-dimensional chart
colr <- colorRampPalette(c(c1, c2, c3), space="rgb")
arrows <- arr
wireframe(z ~ t1 + t2,
data = grid,
scales = list(arrows = FALSE),
zlim = extendrange(grid$z, f = 0.25),
panel.3d.wireframe = "panel.3d.contour",
nlevels = 8,
col = "gray40",
type = c("bottom"),
col.regions = colr(101),
drape = TRUE, colorkey=FALSE,
screen=list(z=z.angle, x=x.angle),
axis.line = list(col = "transparent"),
clip = list(panel = "off"),
par.settings = list(box.3d = list(col=c(1,NA,NA,1,1,NA,NA,NA,NA))))
},
## Controls the value of angles and colors
z.angle=slider(0, 360, step=10, initial=40),
x.angle=slider(-180, 0, step=5, initial=-80),
arr=checkbox(FALSE, "show.arrows"),
c1=picker("transparent","black","red","yellow","orange","green","blue","pink","violet"),
c2=picker("transparent","black","red","yellow","orange","green","blue","pink","violet"),
c3=picker("transparent","black","red","yellow","orange","green","blue","pink","violet")
)
I've code gradient descent algorithm in R and now I'm trying to "draw" the path of the vectors.
I've got draw points in my contour plot, but it's not correct because nobody knows what happened first.
In my algorith always I have an previous state P=(Xi,Yi) and a later state L=(Xi+1,Yi+1), so, How can I draw the vector PL in a contour or a persp plot?
I only got this with contour, where the red point is the convergence:
The same for persp:
Thanks all!
EDIT:
Graphics can be obtanined respectively:
f<-function(u,v){
u*u*exp(2*v)+4*v*v*exp(-2*u)-4*u*v*exp(v-u)
}
x = seq(-2, 2, by = 0.5)
y = seq(-2, 2, by = 0.5)
z <- outer(x,y,f)
#Contour plot
contour(x,y,z)
#Persp plot
persp(x, y, z, phi = 25, theta = 55, xlim=c(-2,2), ylim=c(-2,2),
xlab = "U", ylab = "V",
main = "F(u,v)", col="yellow", ticktype = "detailed"
) -> res
Taking Himmelblau's function as a test example:
f <- function(x, y) { (x^2+y-11)^2 + (x+y^2-7)^2 }
Its partial derivatives:
dx <- function(x,y) {4*x**3-4*x*y-42*x+4*x*y-14}
dy <- function(x,y) {4*y**3+2*x**2-26*y+4*x*y-22}
Running the gradient descent:
# gradient descent parameters
num_iter <- 100
learning_rate <- 0.001
x_val <- 6
y_val <- 6
updates_x <- vector("numeric", length = num_iter)
updates_y <- vector("numeric", length = num_iter)
updates_z <- vector("numeric", length = num_iter)
# parameter updates
for (i in 1:num_iter) {
dx_val = dx(x_val,y_val)
dy_val = dy(x_val,y_val)
x_val <- x_val-learning_rate*dx_val
y_val <- y_val-learning_rate*dx_val
z_val <- f(x_val, y_val)
updates_x[i] <- x_val
updates_y[i] <- y_val
updates_z[i] <- z_val
}
Plotting:
x <- seq(-6, 6, length = 100)
y <- x
z <- outer(x, y, f)
plt <- persp(x, y, z,
theta = -50-log(i), phi = 20+log(i),
expand = 0.5,
col = "lightblue", border = 'lightblue',
axes = FALSE, box = FALSE,
ltheta = 60, shade = 0.90
)
points(trans3d(updates_x[1:i], updates_y[1:i], updates_z[1:i],pmat = plt),
col = c(rep('white', num_iter-1), 'blue'),
pch = 16,
cex = c(rep(0.5, num_iter-1), 1))
There's a trick to plotting points using persp, as mentioned in ?persp. By employing the power of trans3d, you can successfully put points and lines on a perspective plot.
f<-function(u,v){
u*u*exp(2*v)+4*v*v*exp(-2*u)-4*u*v*exp(v-u)
}
x = seq(-2, 2, by = 0.5)
y = seq(-2, 2, by = 0.5)
z <- scale(outer(x,y,f))
view <- persp(x, y, z, phi = 30, theta = 30, xlim=c(-2,2), ylim=c(-2,2),
xlab = "X", ylab = "Y", zlab = "Z", scale = FALSE,
main = "F(u,v)", col="yellow", ticktype = "detailed")
set.seed(2)
pts <- data.frame(x = sample(x, 3),
y = sample(y, 3),
z = sample(z, 3))
points(trans3d(x = pts$x, y = pts$y, z = pts$z, pmat = view), pch = 16)
lines(trans3d(x = pts$x, y = pts$y, z = pts$z, pmat = view))
I would like to plot a line that connects the outer points of the plot
plot(rnorm(1000), rnorm(1000), xlim=c(-5,5),ylim=c(-5,5))
and thus "bags" all points of the plot
Function to be used here is chull. Line 4 is there to close the circle. For more examples, see here.
x <- data.frame(x = rnorm(100), y = rnorm(100))
plot(x)
chx <- chull(x)
chx <- rbind(x = x[chx, ], x[chx[1], ])
lines(chx)
a <- rnorm(1000)
b <- rnorm(1000)
Plot_ConvexHull<-function(xcoord, ycoord, lcolor){
hpts <- chull(x = xcoord, y = ycoord)
hpts <- c(hpts, hpts[1])
lines(xcoord[hpts], ycoord[hpts], col = lcolor)
}
(xrange <- range(c(a)))
(yrange <- range(c(b)))
par(tck = 0.02, mgp = c(1.7, 0.3, 0))
plot(a, b, type = "p", pch = 1, col = "black", xlim = c(xrange), ylim = c(yrange))
Plot_ConvexHull(xcoord = a, ycoord = b, lcolor = "black")