Related
I am attempting to create three contour plots, each illustrating the following function applied to two input vectors and a fixed alpha:
alphas <- c(1, 5, 25)
x_vals <- seq(0, 25, length.out = 100)
y_vals <- seq(0, 50, length.out = 100)
my_function <- function(x, y, alpha) {
z <- (1 / (x + alpha)) * (1 / (y + alpha))
}
for each alpha in the vector alphas, I am creating a contour plot of z values—relative to the minimal z value—over x and y axes.
I do so with the following code (probably not best practices; I'm still learning the basics with R):
plots <- list()
for(i in seq_along(alphas)) {
z_table <- sapply(x_vals, my_function, y = y_vals, alpha = alphas[i])
x <- rep(x_vals, each = 100)
y <- rep(y_vals, 100)
z <- unlist(flatten(list(z_table)))
z_rel <- z / min(z)
d <- data.frame(cbind(x, y, z_rel))
plots[[i]] <- ggplot(data = d, aes(x = x, y = y, z = z_rel)) +
geom_contour_filled()
}
When alpha = 1:
When alpha = 25:
I want to display these plots in one grouping using ggarrange(), with one logarithmic color scale (as relative z varies so much from plot to plot). Is there a way to do this?
You can build a data frame with all the data for all alphas combined, with a column indicating the alpha, so you can facet your graph:
I basically removed the plot[[i]] part, and stacked up the d's created in the former loop:
d = numeric()
for(i in seq_along(alphas)) {
z_table <- sapply(x_vals, my_function, y = y_vals, alpha = alphas[i])
x <- rep(x_vals, each = 100)
y <- rep(y_vals, 100)
z <- unlist(flatten(list(z_table)))
z_rel <- z / min(z)
d <- rbind(d, cbind(x, y, z_rel))}
d = as.data.frame(d)
Then we create the alphas column:
d$alpha = factor(paste("alpha =", alphas[rep(1:3, each=nrow(d)/length(alphas))]),
levels = paste("alpha =", alphas[1:3]))
Then build the log scale inside the contour:
ggplot(data = d, aes(x = x, y = y, z = z_rel)) +
geom_contour_filled(breaks=round(exp(seq(log(1), log(1400), length = 14)),1)) +
facet_wrap(~alpha)
Output:
library(mgcv)
model1 <- gam(EE ~ te(Load, Gradient, k=4, bs=c("tp", "tp")), data = dipasEE)
x <- range(dipasEE$Load)
x <- seq(x[1], x[2], length.out=20)
y <- range(dipasEE$Gradient)
y <- seq(y[1], y[2], length.out=20)
z <- outer(x,y,
function(Load,Gradient)
predict(model1, data.frame(Load,Gradient)))
p <- persp(x,y,z, theta=30, phi=30,
col="yellow",expand = 0.5,shade = 0.2, ticktype = "detailed",
xlab="Load", ylab="Gradient", zlab="EE")
obs<- trans3d(dipasEE$Load, dipasEE$Gradient,dipasEE$EE,p)
pred<- trans3d(dipasEE$Load, dipasEE$Gradient,fitted(model1),p)
points(obs, col="red",pch=16)
segments(obs$x, obs$y, pred$x, pred$y)
predict(model1)
pd <- data.frame(Load = seq(0, 21.5, by = 0.5), Gradient = 15)
predict(model1,newdata=pd)
Output:
[enter image description here][1]
# How to plot the points for newdata=pd in the 3d plot? Below is the Output for above code with Plots. Need to Point more plots for newdata=pd.
# 3 D Plot Graph
[1]: https://i.stack.imgur.com/bIMoY.png
I try to plot cube and ball around it in 3D using plotly in R, type = "mesh3D". I was successful to get the plots right, however, can't get the coordinate lines to go through the origin, point (0,0,0). Any suggestions on how to do that? Code example:
library(misc3d)
library(plotly)
grid <- 100
f.1 <- function(x, y, z){
(x^2+y^2+z^2)
}
f.2 <- function(x, y, z){
abs(x)+abs(y)+abs(z)
}
x <- seq(-1, 1, length=grid)
y <- seq(-1, 1, length=grid)
z <- seq(-1, 1, length=grid)
g <- expand.grid(x=x, y=y, z=z)
voxel.1 <- array(with(g, f.1(x,y,z)), c(grid,grid,grid))
voxel.2 <- array(with(g, f.2(x,y,z)), c(grid,grid,grid))
cont.1 <- computeContour3d(voxel.1, level=1, x=x, y=y, z=z)
idx.1 <- matrix(0:(nrow(cont.1)-1), ncol=3, byrow=TRUE)
cont.2 <- computeContour3d(voxel.2, level=1, x=x, y=y, z=z)
idx.2 <- matrix(0:(nrow(cont.2)-1), ncol=3, byrow=TRUE)
axx <- list(gridcolor="rgb(255,255,255)",zerolinecolor="rgb(0,0,0)")
axy <- list(gridcolor="rgb(255,255,255)",zerolinecolor="rgb(0,0,0)")
axz <- list(gridcolor="rgb(255,255,255)",zerolinecolor="rgb(0,0,0)")
plot.1 <- plot_ly(x = cont.1[,1], y = cont.1[,2], z = cont.1[,3],
i = idx.1[,1], j = idx.1[,2], k = idx.1[,3],
type = "mesh3d",opacity = 0.1,intensity=seq(0,1,length=4),showscale = FALSE,colors="red") %>%
add_trace(x = cont.2[,1], y = cont.2[,2], z = cont.2[,3],
i = idx.2[,1], j = idx.2[,2], k = idx.2[,3],color="blue",
type="mesh3d",opacity=0.7,intensity=seq(0,1,length=4),
showscale=FALSE,inherit=FALSE) %>%
layout(scene = list(xaxis=axx,yaxis=axy,zaxis=axz))
plot.1
It plots zerolines through (1,0,0), (0,1,0) and (0,0,1), but cant get it to plot through (0,0,0).
I am plotting multiple panels of variable size in R, and using layout to accomplish this. I, however, would like to add arrows and text between the plots but seem to, in my best attempts using arrow and text functions, have the annotations being cut-off at the end of the axis I'm plotting on.
MWE:
circle <- function(){
theta <- seq(from = 0, to = 2*pi - pi/1000, by = 2*pi/1000)
x <- cos(theta)
y <- sin(theta)
circ <- list(x, y)
}
shape_plot <- function(xs, ys, typ){
plot(xs, ys, type=typ, axes=FALSE, xlab='', ylab='', asp=1, lwd=4)
}
sample1 <- function(data, n){
pts <- sort(floor(runif(n, min=1, max=1000)))
xs <- data[[1]]
x <- xs[pts] + .1*runif(n, min=-1, max=1)
x <- c(x, x[1])
ys <- data[[2]]
y <- ys[pts] + .1*runif(n, min=-1, max=1)
y <- c(y, y[1])
samp <- list(x, y)
}
layout(matrix(c(1,2, 1,3, 1,4), 3, 2, byrow = TRUE))
circ <- circle()
shape_plot(circ[[1]], circ[[2]], 'l')
label <- rep('circle', 3)
for (i in 1:3){
samp <- sample1(circ, 50)
shape_plot(samp[[1]], samp[[2]], 'p')
}
This returns the following figure:
What I would like is something like this (but less ugly, and not created in GIMP):
Thanks!
In response to a comment by #rawr, I came up with the following modifications which enabled me to accomplish this goal:
...
layout(matrix(c(1,2, 1,3, 1,4), 3, 2, byrow = TRUE))
par(xpd=NA)
...
...
arrows(x0=1.5, x1=2.5, y0=1, y1=2, length=0.1, lwd = lweight)
arrows(x0=1.5, x1=2.5, y0=0, y1=0, length=0.1, lwd = lweight)
arrows(x0=1.5, x1=2.5, y0=-1, y1=-2, length=0.1, lwd = lweight)
text(x=1.8, y=1.8, expression('s'[1]^'a'), cex=2)
text(x=1.8, y=0.3, expression('s'[2]^'a'), cex=2)
text(x=1.8, y=-1.8, expression('s'[3]^'a'), cex=2)
...
Result:
Using layout seemed to cause problems.
Below is a modified version of your MWE that I think does what you are looking for.
circle <- function(){
theta <- seq(from = 0, to = 2*pi - pi/1000, by = 2*pi/1000)
x <- cos(theta)
y <- sin(theta)
circ <- data.frame(x, y)
}
shape_plot <- function(xs, ys, typ){
plot(xs, ys, type=typ, axes=FALSE, xlab='', ylab='', asp=1, lwd=4)
}
sample1 <- function(data, n){
pts <- sort(floor(runif(n, min=1, max=1000)))
xs <- data[[1]]
x <- xs[pts] + .1*runif(n, min=-1, max=1)
x <- c(x, x[1])
ys <- data[[2]]
y <- ys[pts] + .1*runif(n, min=-1, max=1)
y <- c(y, y[1])
samp <- data.frame(x, y)
}
circ <- circle()
shape_plot(circ[[1]], circ[[2]], 'l')
label <- rep('circle', 3)
samp <- list()
nudge <- cbind(5,c(3,0,-3))
for (i in 1:3){
s <- sample1(circ, 50)
samp[[i]] <- t(apply(s, 1, function(x) x + nudge[i,]))
}
samp <- Reduce(rbind, samp)
tot <- rbind(circ, samp)
shape_plot(tot[[1]], tot[[2]], typ = 'n')
points(circ, type = 'l')
points(samp, type = 'p')
arrows(1.2,1,3.7,2.5)
arrows(1.2,0,3.7,0)
arrows(1.2,-1,3.7,-2.5)
text(2.5,2, label = "arrow 1", srt = atan(1/1.5)*180/pi)
text(2.5,0.25, label = "arrow 2")
text(2.5,-2, label = "arrow 3", srt = atan(-1/1.5)*180/pi)
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))