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).
Related
I have a set of equations (z1) x+y+z=6, (z2) x+2y+2z=9 and (z3) x+3y+4z=13 and would like to plot the planes using plotly.
Method1: using mesh3d
require(plotly)
x<-seq(from=-10, to=10, by=1)
y<-seq(from=-10, to=10, by=1)
z1<-6-x-y #For the first plane
fig <- plot_ly(x = ~, y = ~y, z = ~z1, type = 'mesh3d')
fig
Produces no output though. Why?
Method 2: Using surface
Whereas this produces a plane but the wrong one.
library(plotly)
x<-seq(from=-10,to=10,by=1)
y<-seq(from=-10,to=10,by=1)
z1<-6-x-y
z1<-matrix(rep(z1,10),NROW(x),10)
fig <- plot_ly(showscale = FALSE)
fig <- fig %>% add_surface(z = ~z1)
fig
This plane is not correct. If you look at the point x=2, y=2, z should equal 2 but it doesn't. Instead it is 22, and that's not correct.
When x <- seq(from=-10, to=10, by=1); y<-seq(from=-10, to=10, by=1), x+y+z=6 is not plane but line.
You need to prepare more data points.
library(dplyr); library(tidyr); library(plotly)
x <- seq(from=-10, to=10, by=1)
y <- seq(from=-10, to=10, by=1)
z1 <- 6-x-y #For the first plane
origin <- tibble(x = x, y = y, z = z1)
# prepare all combination of x and y, and calculate z1
xyz1 <- tidyr::crossing(x, y) %>%
mutate(z1 = 6-x-y)
plot_ly(x = ~x, y = ~y, z = ~z1, type = "mesh3d", data = xyz1) %>%
add_markers(~ x, ~y, ~z1, data = origin)
Orange points are the data you prepare (when x <- seq(from=-10, to=10, by=1); y<-seq(from=-10, to=10, by=1) , x+y+z=6 is line.)
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:
Can anybody help me how to plot an image or 3D plot for this function that the output is in array class?
mu <- function(x,y,t,par){
return(par[1]+ par[2]*(x-t)+par[3]*x*t)
}
x <- seq(0,1,0.1)
y <- seq(0,1,0.1)
t <- seq(0,1,0.1)
mu.values <- array(NA, dim=c(length(x),length(y),length(t)))
for(i in 1:length(x)){
for(j in 1:length(y)){
for(k in 1:length(t)){
mu.values[i,j,k] <- mu(x[i], y[j], t[k], par=c(0.25,0.25,0))
}
}
}
Try this, now including slices:
library(reshape2)
library(plot3D)
m = melt(mu.values)
par(mfrow = c(1,2))
scatter3D(x = m$Var1, y = m$Var2, z = m$Var3, colvar = m$value, pch = 16, cex = 0.1)
# contour slices
x <- y <- z <- 1:11
slicecont3D (x, y, z, ys = 1:11, colvar = mu.values,
theta = 60, border = "gray")
Created on 2020-07-08 by the reprex package (v0.3.0)
I wonder how can I find the control points of geom_curve in ggplot2? e.g.
p <- ggplot(mtcars, aes(wt, mpg)) +
geom_curve(aes(x = 2.62, y = 21.0, xend = 3.57, yend = 15.0),curvature = -0.2, data = df) +
geom_point()
b <- ggplot_build(p)
b$data[[1]]
p$layers[[1]]$geom_params
b$data[[1]] gives the starting and ending points and p$layers[[1]]$geom_params gives the curve information (angle, curvature, ...).
But how can I find the control points, so I can reproduce the graphics?
library(ggplot)
library(grid)
library(stringr)
df <- data.frame(x = 1:3, y = 1:3)
df2 <- data.frame(x = c(1,3), y = c(1,3),
xend = c(2,2), yend = c(2,2))
g <- ggplot(df, aes(x, y)) +
geom_point() +
geom_curve(aes(x = x ,y = y,
xend = xend, yend = yend),
data = df2,
color = c("red", "blue"))
g
getCurve_controlPoints <- function(ggplotObject) {
len_layers <- length(ggplotObject$layers)
layerNames <- lapply(seq_len(len_layers),
function(j) {
className <- class(ggplotObject$layers[[j]]$geom)
className[-which(className %in% c("ggproto" ,"gg", "Geom"))]
})
curveLayerId <- which(sapply(layerNames,
function(layerName){
"GeomCurve" %in% layerName
}) == TRUE
)
gg_build <- ggplot_build(ggplotObject)
# you can also add yes or no in your code
# answer <- utils::menu(c("y", "n"), title="Do you want to draw the ggplot?")
grid.draw(ggplotObject)
grid.force()
gridList <- grid.ls(print = FALSE)
gridList.name <- gridList$name
xspline.name <- gridList.name[which(str_detect(gridList.name, "curve") == TRUE)]
xspline.len <- length(xspline.name)
controlPoints <- lapply(seq_len(length(curveLayerId)),
function (j) {
# curve data
curve_data <- gg_build$data[[curveLayerId[j]]]
# avoid duplicated rows
curve_data <- curve_data[!duplicated(curve_data), ]
n <- dim(curve_data)[1]
# here we go! But wait a second, it seems like the starting and ending position do not match
xsplinePoints <- xsplinePoints(grid.get("xspline", grep=TRUE))
# mapping data to our coordinates
control_data <- lapply(seq_len(n),
function(i){
if (n == 1) {
xy <- lapply(xsplinePoints,
function(coord){
as.numeric(coord)
})
} else {
xy <- lapply(xsplinePoints[[i]],
function(coord){
as.numeric(coord)
})
}
x.start <- curve_data[i, ]$x
x.end <- curve_data[i, ]$xend
y.start <- curve_data[i, ]$y
y.end <- curve_data[i, ]$yend
# mapping to ggplot coordinates
xy_x.diff <- xy$x[length(xy$x)] - xy$x[1]
xy_y.diff <- xy$y[length(xy$y)] - xy$y[1]
# maybe there is a better way?
if(xy_x.diff == 0){
xy_x.diff <- 1e-16
}
if(xy_y.diff == 0){
xy_y.diff <- 1e-16
}
x <- (x.end - x.start) / (xy_x.diff) * (xy$x - xy$x[1]) + x.start
y <- (y.end - y.start) / (xy_y.diff) * (xy$y - xy$y[1]) + y.start
list(x = x, y = y)
})
# grid remove
grid.remove(xspline.name[j], redraw = FALSE)
control_data
})
controlPoints
}
controlPoints <- getCurve_controlPoints(g)
# check the points
plot(controlPoints[[1]][[1]]$x, controlPoints[[1]][[1]]$y,
xlim = c(1,3),
ylim = c(1,3),
xlab = "x",
ylab = "y",
pch = 19)
points(controlPoints[[1]][[2]]$x, controlPoints[[1]][[2]]$y, pch = 19)
I think it works well so far and the ggplot version I used is 3.0.0. If you use any version less than 2.2.1, error may occur.
This idea is suggested by Prof Paul Murrell. Perhaps the easiest way to capture the control points of geom_curve? The cons are that grobs(ggplot object) must be drawn at first, since these points are only generated at the drawing time.
I'm trying to create an object to draw a 3D surface based on that,
tmp <- matrix(10:39, nrow = 3, ncol = 10)
x <- 10:12
y <- 20:30
tmp[x,y] is the z
How should I create such an object?
Here is an example:
library(plotly)
tmp <- matrix(10:39, nrow = 3, ncol = 10)
x <- 10:12
y <- 20:30
plot_ly(x = x, y = y ) %>%
add_surface(z = t(tmp)) #transpose it