Adding Contour Lines to 3D Plots - r

I am working with the R programming language. I made the following 3 Dimensional Plot using the "plotly" library:
library(dplyr)
library(plotly)
my_function <- function(x,y) {
final_value = (1 - x)^2 + 100*((y - x^2)^2)
}
input_1 <- seq(-1.5, 1.5,0.1)
input_2 <- seq(-1.5, 1.5,0.1)
z <- outer(input_1, input_2, my_function)
plot_ly(x = input_1, y = input_2, z = z) %>% add_surface()
I am now trying to add "contour lines" to the above plot as shown below: https://plotly.com/r/3d-surface-plots/
I am trying to adapt the code from the "plotly website" to make these contours, but I am not sure how to do this:
Graph 1:
# This might have worked?
fig <- plot_ly(z = ~z) %>% add_surface(
contours = list(
z = list(
show=TRUE,
usecolormap=TRUE,
highlightcolor="#ff0000",
project=list(z=TRUE)
)
)
)
fig <- fig %>% layout(
scene = list(
camera=list(
eye = list(x=1.87, y=0.88, z=-0.64)
)
)
)
Graph 2:
# I don't think this worked?
fig <- plot_ly(
type = 'surface',
contours = list(
x = list(show = TRUE, start = 1.5, end = 2, size = 0.04, color = 'white'),
z = list(show = TRUE, start = 0.5, end = 0.8, size = 0.05)),
x = ~x,
y = ~y,
z = ~z)
fig <- fig %>% layout(
scene = list(
xaxis = list(nticks = 20),
zaxis = list(nticks = 4),
camera = list(eye = list(x = 0, y = -1, z = 0.5)),
aspectratio = list(x = .9, y = .8, z = 0.2)))
fig
Can someone please show me how to correctly adapt these above codes?

You were almost there.
The contours on z should be defined according to min-max values of z:
plot_ly(x = input_1, y = input_2, z = z,
contours = list(
z = list(show = TRUE, start = round(min(z),-2),
end = round(max(z),-2),
size = 100))) %>%
add_surface()
or automatically set by plotly :
plot_ly(x = input_1, y = input_2, z = z,
colors = 'Oranges',
contours = list(
z = list(show = TRUE))) %>%
add_surface()

The contour lines are on your plots, but may not be super visible due to the parameters in the contours.z list. Here's how you can tweak the contour lines to fit your needs:
fig <- plot_ly(z = ~z) %>% add_surface(
contours = list(
z = list(
show = TRUE,
# project=list(z=TRUE) # (don't) project contour lines to underlying plane
# usecolormap = TRUE, # (don't) use surface color scale for contours
color = "white", # set contour color
width = 1, # set contour thickness
highlightcolor = "#ff0000", # highlight contour on hover
start = 0, # include contours from z = 0...
end = 1400, # to z = 1400...
size = 100 # every 100 units
)
)
)
You can draw lines along the other dimensions by passing lists to x or y. (Per follow-up question from OP) you can change the surface color scale using colorscale, either specifying one of the named colorscale options or building your own. Example:
fig <- plot_ly(z = ~z) %>% add_surface(
colorscale = "Picnic",
contours = list(
x = list(show=TRUE, color="#a090b0", width=2, start=0, end=30, size=7.5),
y = list(show=TRUE, color="#a090b0", width=2, start=0, end=30, size=7.5),
z = list(show=TRUE, color="#a090b0", width=2, start=0, end=1400, size=300)
)
)

Related

Is there a more efficient way to draw 3D arrows in R?

I'm working on a ShinyApp in R where I want to draw hundreds of arrows displayed in an rglwidgetOutput whenever the respective checkbox is selected. However, my screen is freezing for a couple of seconds whenever I select the checkbox and now I'm wondering if there is a more efficient way to draw the arrows.
Here is a minimal example (outside of Shiny):
library(rgl)
mat0 = matrix(rep(1:10,3), ncol = 3) # 1:n to adjust number of points
mat1 = cbind(mat0[,1]*cos(seq(0,2*pi,length = 10)) - mat0[,2] * sin(seq(0,2*pi,length = 10)),
mat0[,1]*sin(seq(0,2*pi,length = 10)) + mat0[,2] * cos(seq(0,2*pi,length = 10)),
mat0[,3])
mat1 = mat1 + 0.5
open3d()
plot3d(mat0[2:9,], aspect = FALSE, axes = FALSE, xlab = "", ylab ="", zlab = "", col = 1)
plot3d(mat1[2:9,], add = TRUE, col = 2)
for(i in 2:9) arrow3d(mat0[i,], mat1[i,], type = "rotation")
All points can be drawn in a single expression (e.g. plot3d(mat0[2:9,]), however to draw the arrows a loop is required. Is there a way to draw all arrows at the same time within a single expression? The arrows have different lengths, orientation and points of origin. Therefore I believe I cannot use the spriteOrigin argument or do I misunderstand this? I have also looked into the vectors3d function from the matlib library but it seems a single point of origin is required. I'm also not sure if the perfomance issue maybe comes from an inefficient design of the server function within my shiny application. A more elaborate example:
library(shiny)
library(rgl)
# Define UI for application
ui <- fluidPage(
# Application title
titlePanel("Test"),
# Sidebar with checkbox
sidebarLayout(
sidebarPanel(
checkboxInput("cb", "Show Arrows", value = FALSE),
),
# Show plot
mainPanel(
rglwidgetOutput(outputId = "threeDPlot", width = "1200px", height = "800px")
)
)
)
# Define server logic
server <- function(input, output) {
#create 3D Plot
output$threeDPlot = renderRglwidget({
rgl.open(useNULL=TRUE)
rgl.bg(color="white")
plot3d(mat0[2:9,], aspect = FALSE, axes = FALSE, xlab = "", ylab = "", zlab = "", col = 1)
plot3d(mat1[2:9,], add = TRUE, col = 2)
if(input$cb == TRUE){
for(i in 2:9) arrow3d(mat0[i,], mat1[i,], type = "rotation")
}
rglwidget()
})
}
#global variables - read only once
mat0 = matrix(rep(1:10,3), ncol = 3)
mat1 = cbind(mat0[,1]*cos(seq(0,2*pi,length = 10)) - mat0[,2] * sin(seq(0,2*pi,length = 10)),
mat0[,1]*sin(seq(0,2*pi,length = 10)) + mat0[,2] * cos(seq(0,2*pi,length = 10)),
mat0[,3])
mat1 = mat1 + 0.5
# Run the application
shinyApp(ui = ui, server = server)
Note: in these examples only 8 arrows are drawn. With ~ 500 arrows the app is freezing for a while, though.
Here is an alternative approach using library(data.table):
library(plotly)
library(data.table)
# Example Data
# P0 data: origin of arrows
DT0 <- setnames(data.table(replicate(4, 1:10)), new = c("x", "y", "z", "sep"))
DT1 <- copy(DT0)
DT1[, c("x", "y", "z") := .(x * cos(seq(0, 2 * pi, length = 10)) - y * sin(seq(0, 2 * pi, length = 10)),
x * sin(seq(0, 2 * pi, length = 10)) + y * cos(seq(0, 2 * pi, length = 10)),
z)]
DT1[,1:3] <- DT1[,1:3] + 0.5
# Artifical Separator
DTsep <- copy(DT0)
DTsep[,1:3] <- NA
# Each set of points from P0 and P1 is separated by a row of NA coordinates
DT <- rbindlist(list(var_1 = DT0, var_2 = DT1, var_3 = DTsep), idcol = "id")
setorder(DT, sep, id)
# Direction of Arrows
dirDT <- copy(DT1[,1:3])
dirDT <- dirDT - DT0[,1:3] # direction vector
dirDT <- dirDT / sqrt(rowSums(dirDT ^ 2)) # unit vector for evenly sized cones
setnames(dirDT, new = c("u", "v", "w"))
dirDT <- cbind(dirDT, DT1)
# Add P0 and P1
fig <- plot_ly(
data = DT,
type = "scatter3d",
mode = "markers",
x = ~ x,
y = ~ y,
z = ~ z,
size = 1,
marker = list(color = "#000000", line = list(color = "#000000")),
showlegend = FALSE
)
# Add Lines from P0 to P1
fig <- add_trace(
fig,
data = DT,
type = "scatter3d",
mode = "lines",
x = ~ x,
y = ~ y,
z = ~ z,
inherit = FALSE,
showlegend = FALSE,
line = list(color = "black")
)
# Add Cones
fig <- add_trace(
fig,
data = dirDT,
type = "cone",
x = ~ x,
y = ~ y,
z = ~ z,
u = ~ u,
v = ~ v,
w = ~ w,
inherit = FALSE,
showscale = FALSE,
colorscale = list(list(0, "black"), list(1, "black"))
)
# Remove grid and axes
ax <- list(
title = "",
zeroline = FALSE,
showline = FALSE,
showticklabels = FALSE,
showgrid = FALSE
)
# Update Layout
fig <- layout(
fig,
showlegend = FALSE,
scene = list(
aspectmode = "data",
#equal aspect ratio
xaxis = ax,
yaxis = ax,
zaxis = ax,
camera = list(eye = list(
x = -0.76, y = 1.8, z = 0.92
))
)
)
fig
A version without markers:
library(plotly)
library(data.table)
# Example Data
# P0 data: origin of arrows
DT0 <- setnames(data.table(replicate(4, 1:10)), new = c("x", "y", "z", "sep"))
DT1 <- copy(DT0)
DT1[, c("x", "y", "z") := .(x * cos(seq(0, 2 * pi, length = 10)) - y * sin(seq(0, 2 * pi, length = 10)),
x * sin(seq(0, 2 * pi, length = 10)) + y * cos(seq(0, 2 * pi, length = 10)),
z)]
DT1[,1:3] <- DT1[,1:3] + 0.5
# Artifical Separator
DTsep <- copy(DT0)
DTsep[,1:3] <- NA
# Each set of points from P0 and P1 is separated by a row of NA coordinates
DT <- rbindlist(list(var_1 = DT0, var_2 = DT1, var_3 = DTsep), idcol = "id")
setorder(DT, sep, id)
# Direction of Arrows
dirDT <- copy(DT1[,1:3])
dirDT <- dirDT - DT0[,1:3] # direction vector
dirDT <- dirDT / sqrt(rowSums(dirDT ^ 2)) # unit vector for evenly sized cones
setnames(dirDT, new = c("u", "v", "w"))
dirDT <- cbind(dirDT, DT1)
# # Add P0 and P1
# fig <- plot_ly(
# data = DT,
# type = "scatter3d",
# mode = "markers",
# x = ~ x,
# y = ~ y,
# z = ~ z,
# size = 1,
# marker = list(color = "#000000", line = list(color = "#000000")),
# showlegend = FALSE
# )
# Add Lines from P0 to P1
fig <- plot_ly(
# fig,
data = DT,
type = "scatter3d",
mode = "lines",
x = ~ x,
y = ~ y,
z = ~ z,
# inherit = FALSE,
showlegend = FALSE,
line = list(color = "black")
)
# Add Cones
fig <- add_trace(
fig,
data = dirDT,
type = "cone",
x = ~ x,
y = ~ y,
z = ~ z,
u = ~ u,
v = ~ v,
w = ~ w,
inherit = FALSE,
showscale = FALSE,
colorscale = list(list(0, "black"), list(1, "black"))
)
# Remove grid and axes
ax <- list(
title = "",
zeroline = FALSE,
showline = FALSE,
showticklabels = FALSE,
showgrid = FALSE
)
# Update Layout
fig <- layout(
fig,
showlegend = FALSE,
scene = list(
aspectmode = "data",
#equal aspect ratio
xaxis = ax,
yaxis = ax,
zaxis = ax,
camera = list(eye = list(
x = -0.76, y = 1.8, z = 0.92
))
)
)
fig
Rgl solution:
For now I've used some basic geometry to calculate the arrows based solely on line segments:
library(rgl)
#example data
p0 = matrix(rep(1:10,3), ncol = 3)
p1 = cbind(p0[,1]*cos(seq(0,2*pi,length = 10)) - p0[,2] * sin(seq(0,2*pi,length = 10)),
p0[,1]*sin(seq(0,2*pi,length = 10)) + p0[,2] * cos(seq(0,2*pi,length = 10)),
p0[,3])
p1 = p1 + 0.5
pu = p1 - p0 #direction vector
pu = pu / sqrt(rowSums(pu^2)) #make it a unit vector
pu = pu / 2 # scaling: division by 2 for shorter arrows
#a vector that is perpendicular to the unit vector
#based on: https://math.stackexchange.com/questions/137362/how-to-find-perpendicular-vector-to-another-vector (Ken Whatmough)
ppu = cbind(pu[,3] * sign(sign(pu[,1]) + 0.5),
pu[,3] * sign(sign(pu[,2]) + 0.5),
-((abs(pu[,1])+abs(pu[,2])) * sign(sign(pu[,3]) + 0.5)))
tp1 = p1 - pu - ppu #triangle points 1
tp2 = p1 - pu + ppu #triangle points 2 (opposite direction)
#draw points
open3d()
plot3d(p0, aspect = FALSE, axes = FALSE, xlab = "", ylab ="", zlab = "", col = 4)
plot3d(p1, add = TRUE, col = 2)
#draw arrows
segments3d(x = c(t(cbind(p0[,1],p1[,1]))), y = c(t(cbind(p0[,2],p1[,2]))), z = c(t(cbind(p0[,3],p1[,3]))), lwd = 2)
segments3d(x = c(t(cbind(p1[,1], tp1[,1]))), y = c(t(cbind(p1[,2], tp1[,2]))), z = c(t(cbind(p1[,3], tp1[,3]))), lwd = 2)
segments3d(x = c(t(cbind(p1[,1], tp2[,1]))), y = c(t(cbind(p1[,2], tp2[,2]))), z = c(t(cbind(p1[,3], tp2[,3]))), lwd = 2)
This code is already running much faster, although the arrows do not look as beautiful. Maybe it still helps someone else.
I'm leaving this question open for a while in case there will be some more elegant answers.
Here is a plotly solution:
library(plotly)
# Example data
mat0 = matrix(rep(1:10,3), ncol = 3) # 1:n to adjust number of points
mat1 = cbind(mat0[,1]*cos(seq(0,2*pi,length = 10)) - mat0[,2] * sin(seq(0,2*pi,length = 10)),
mat0[,1]*sin(seq(0,2*pi,length = 10)) + mat0[,2] * cos(seq(0,2*pi,length = 10)),
mat0[,3])
mat1 = mat1 + 0.5
dir = mat1 - mat0 #direction vector
dir = dir / sqrt(rowSums(dir^2)) #unit vector
fig = plotly_empty()
#Add P0
fig = fig %>%
add_markers(type = "scatter3d", mode = "markers", size = 1,
x = mat0[,1], y = mat0[,2], z = mat0[,3],
color = rep(1, length(mat0[,1])) ,colors = c("#000000", "#ff0000"))
#Add P1
fig = fig %>%
add_markers(type = "scatter3d", mode = "markers", size = 1,
x = mat1[,1], y = mat1[,2], z = mat1[,3],
color = rep(2, length(mat1[,1])) ,colors = c("#000000", "#ff0000"))
#Add Lines from P0 to P1
fig = fig %>%
add_trace(type = "scatter3d", mode = "lines", split = rep(1:length(mat0[,1]), each = 2),
x = c(rbind(mat0[,1],mat1[,1])), y = c(rbind(mat0[,2],mat1[,2])), z = c(rbind(mat0[,3],mat1[,3])),
color = rep(1, length(mat0[,1])*2), colors = c("#000000", "#ff0000"))
#Add Cones
fig = fig %>%
add_trace(type = "cone",
x = mat1[,1], y = mat1[,2], z = mat1[,3],
u = dir[,1], v = dir[,2], w = dir[,3],
color = rep(1, length(mat1[,1])), colors = c("#000000"),
showscale = FALSE)
#ensure that no lines and numbers for axes are shown
ax <- list(
title = "",
zeroline = FALSE,
showline = FALSE,
showticklabels = FALSE,
showgrid = FALSE
)
#Update Layout
fig = fig %>%
layout(
showlegend = FALSE,
scene = list(
aspectmode = "data", #equal aspect ratio
xaxis = ax,
yaxis = ax,
zaxis = ax,
camera = list(
eye = list(x= -0.76, y= 1.8, z= 0.92)
)
)
)
#Show plot
fig
For some reason the first and last cone have the wrong color (I'll update when I find a solution). Also, adding cones works very fast. However, now adding the lines from P0 to P1 is very slow.

COLOR OF Mesh3d objects with plotly

I am trying to draw ellipsoids using Mesh3d plotly. Only problem, I can't change the color. There is a lot of parameters for the colour (colorscale, colorface, colorbar, ...), is there any way to control the color of each ellipsoid ?
My code:
Color1<-c("#A6CEE3","#1F78B4","#8DA0CB","#33A02C","#FB9A99","#E31A1C","#FDBF6F","#FF7F00",
"#CAB2D6","#6A3D9A","#FFFF99","#B15928","#66C2A5","#FC8D62","B2DF8A","#E78AC3")
fig <- plot_ly(x = BD_PCA[,1], y = BD_PCA[,2], z = BD_PCA[,3])
fig <- fig %>% layout(scene = list(xaxis = list(title = 'PCA1'),
yaxis = list(title = 'PCA2'),
zaxis = list(title = 'PCA3')))
for(i in levels(data_CSV$groups)){
ellipse <- ellipse3d(cov(cbind(x = BD_PCA[data_CSV$groups==i,1],
y = BD_PCA[data_CSV$groups==i,2],
z = BD_PCA[data_CSV$groups==i,3])),
centre=c(mean(BD_PCA[data_CSV$groups==i,1]),
mean(BD_PCA[data_CSV$groups==i,2]),
mean(BD_PCA[data_CSV$groups==i,3])), level = 0.4)
fig <- fig %>% add_trace(x=ellipse$vb [1,], y=ellipse$vb [2,], z=ellipse$vb [3,],
type='mesh3d', alphahull = 0, opacity = 0.3,name=i,showlegend = T,
autocolorscale=FALSE,color=Color1[strtoi(i)]),cauto=FALSE)
}
fig <- fig %>%
add_trace(
x = BD_PCA[nrow(BD_PCA),1],y = BD_PCA[nrow(BD_PCA),2],z = BD_PCA[nrow(BD_PCA),3],
marker = list(color = 'black',symbol='square-dot',size = 5),name="Tested results",showlegend = F)
fig <- fig %>% layout(legend = list(x = 1, y = 1))
plot(fig)
Ellipses with autocolor:
The doc says that the argument color sets the color of the whole mesh, but I tried and it didn't work. You can use facecolor, but then you must provide one color for each face:
library(plotly)
library(rgl)
Sigma <- matrix(c(10, 3, 0, 3, 2, 0, 0, 0, 1), 3, 3)
Mean <- 1:3
ellipsoid <-
ellipse3d(Sigma, centre = Mean, subdivide = 5) # this is a mesh of quads
ellipsoid <- Morpho::quad2trimesh(ellipsoid) # we triangulate it
plot_ly(
x = ellipsoid$vb[1,], y = ellipsoid$vb[2,], z = ellipsoid$vb[3,],
i = ellipsoid$it[1,]-1, j = ellipsoid$it[2,]-1, k = ellipsoid$it[3,]-1,
type = "mesh3d",
facecolor = rep("#ff0000", ncol(ellipsoid$it))
) %>% layout(scene = list(aspectmode = "data"))
Work perfect with facecolor, I repeated 1000 times.
Thanks Stéphane.

plot_ly surface plot axes do not cover full range of values

I try to produce a 3D surface plot using plot_ly like this:
rm(list=ls())
set.seed(42)
x_val <- seq(-2,2,0.1)
y_val <- seq(0,1,0.1)
zz <- matrix(NA, nrow = length(x_val), ncol = length(y_val))
for(i in 1:length(x_val)){
for(j in 1:length(y_val)){
zz[i,j] <- rnorm(1, x_val[i], y_val[j]+0.01)
}
}
plot_ly(x = x_val, y = y_val, z = zz, type = "surface")
The resulting plots looks like this:
As you can see, the x_axis has a range between -2 and 2, but only values between -1 and -2 are plotted.
How can I plot the results for the full range of x-values?
As suggested in the comments, I tried to implement the solution from this question (plotly 3d surface - change cube to rectangular space).
However, using
plot_ly(x = x_val, y = y_val, z = zz, type = "surface") %>%
layout(
scene = list(
xaxis = list(range = c(-2,2)),
yaxis = list(range = c(0,1)),
zaxis = list(range = range(zz)),
aspectratio = list(x = 2, y = 1, z = 0.4))
)
leads to this image with the same problem:
The x-axis refers to the columns of the zz matrix.
The length of your x_val vector is 41 and the number of columns of zz is 11.
Thus, for a correct visualization, the zz matrix needs to be trasposed:
plot_ly(x = x_val, y = y_val, z = t(zz), type = "surface")

Plotting Ellipse3d in R Plotly with surface ellipse

Similar to the question here but this didn't give me excatly what I needed and I couldn't figure it out: Plot ellipse3d in R plotly?. I want to recreate rgl's ellipse3d and surface ellipsoid in plotly. I know there there was an anwer which allowed plotting of an ellipse but as individual opaque markers, I need to get it as a surface ellipsoid that's slightly opaque so I can still see the data points in the ellipsoid.
I tried to figure out how dww's comment for "add_surface" instead works but couldn't figure it out.... Can anyone help please?
if (!require("rgl")) install.packages("rgl")
dt <- cbind(x = rnorm(100), y = rnorm(100), z = rnorm(100))
ellipse <- ellipse3d(cov(dt))
plot3d(dt)
plot3d(ellipse, add = T, color = "red", alpha = 0.5)
dww's answer was:
if (!require("plotly")) install.packages("plotly")
if (!require("rgl")) install.packages("rgl")
dt <- cbind(x = rnorm(100), y = rnorm(100), z = rnorm(100))
ellipse <- ellipse3d(cov(dt))
p <- plot_ly(mode = 'markers') %>%
add_trace(type = 'scatter3d', size = 1,
x = ellipse$vb[1,], y = ellipse$vb[2,], z = ellipse$vb[3,],
opacity=0.01) %>%
add_trace(type = 'scatter3d', x = dt[,1], y = dt[,2], z = dt[,3])
p
# shows more obviously what dww's code does to create the visual ellipsoid
w <- plot_ly(mode = 'markers') %>%
add_trace(type = 'scatter3d',
x = ellipse$vb[1,], y = ellipse$vb[2,], z = ellipse$vb[3,],
opacity=0.5) %>%
add_trace(type = 'scatter3d', x = dt[,1], y = dt[,2], z = dt[,3])
w
Their comment on how to use add_surface was
Note that for simplicity, I plotted the ellipse as a cloud using markers. If you want to use add_surface instead, you will have to first convert the ellipse into a different format, with a vector of x locations, a vector of y locations, z as a matrix (dimensions equal to x by y). You'll also need to split the z values into two separate surface layers one for the top half of the ellipsoid and one for the bottom. I don't have time right now to do all this, but if you get stuck I can work this out later
This is my solution if anyone is interested in it. This allows using of the buttons in plotly to toggle the ellipsoid on and off so that you can still hover over and select data points inside the ellipsoid when desired:
if (!require("rgl")) install.packages("rgl", dependencies=TRUE, repos="http://cran.rstudio.com/")
if (!require("plotly")) install.packages("plotly", dependencies=TRUE, repos="http://cran.rstudio.com/")
dt <- cbind(x = rnorm(100), y = rnorm(100), z = rnorm(100))
ellipse <- ellipse3d(cov(dt))
updatemenus <- list(
list(
active = 0,
type= 'buttons',
buttons = list(
list(
label = "Ellipsoid",
method = "update",
args = list(list(visible = c(TRUE, TRUE)))),
list(
label = "No Ellipsoid",
method = "update",
args = list(list(visible = c(TRUE, FALSE)))))
)
)
plot<- plot_ly()%>%
# Plot raw scatter data points
add_trace(data = dt, x = dt[,1], y = dt[,2], z = dt[,3],
type = "scatter3d", mode = 'markers', marker = list(size = 3)) %>%
# Plot ellipsoid
add_trace(x=ellipse$vb [1,], y=ellipse$vb [2,], z=ellipse$vb [3,],
type='mesh3d', alphahull = 0, opacity = 0.4)%>%
# Axes Titles
layout(updatemenus = updatemenus)
plot
Here is a possibility, using the mesh3d type, and with the help of the misc3d package.
pts <- cbind(x = rnorm(10), y = rnorm(10), z = rnorm(10))
C <- chol(cov(pts))
SVD <- svd(t(C))
A <- solve(t(SVD$u)) %*% diag(SVD$d)
cr <- colMeans(pts)
r <- sqrt(qchisq(0.95,3))
fx <- function(u,v){
cr[1] + r*(A[1,1]*cos(u)*cos(v) + A[1,2]*cos(u)*sin(v) + A[1,3]*sin(u))
}
fy <- function(u,v){
cr[2] + r*(A[2,1]*cos(u)*cos(v) + A[2,2]*cos(u)*sin(v) + A[2,3]*sin(u))
}
fz <- function(u,v){
cr[3] + r*(A[3,1]*cos(u)*cos(v) + A[3,2]*cos(u)*sin(v) + A[3,3]*sin(u))
}
library(misc3d)
tris <- parametric3d(fx, fy, fz,
umin=-pi/2, umax=pi/2, vmin=0, vmax=2*pi,
n=100, engine="none")
n <- nrow(tris$v1)
cont <- matrix(NA_real_, ncol=3, nrow=3*n)
cont[3*(1:n)-2,] <- tris$v1
cont[3*(1:n)-1,] <- tris$v2
cont[3*(1:n),] <- tris$v3
idx <- matrix(0:(3*n-1), ncol=3, byrow=TRUE)
library(plotly)
p <- plot_ly() %>%
add_trace(type = "mesh3d",
x = cont[,1], y = cont[,2], z = cont[,3],
i = idx[,1], j = idx[,2], k = idx[,3],
opacity = 0.3) %>%
add_trace(type = "scatter3d", mode = "markers",
data = as.data.frame(pts),
x = ~x, y = ~y, z = ~z,
marker = list(size = 5)) %>%
layout(scene = list(aspectmode = "data"))
To add some colors:
midpoints <- (tris$v1 + tris$v2 + tris$v3)/3
distances <- apply(midpoints, 1, function(x) crossprod(x-cr))
intervals <- cut(distances, 256)
colorsPalette <- viridisLite::viridis(256)
colors <- colorsPalette[as.integer(intervals)]
p <- plot_ly() %>%
add_trace(type = "mesh3d",
x = cont[,1], y = cont[,2], z = cont[,3],
i = idx[,1], j = idx[,2], k = idx[,3],
facecolor = colors,
opacity = 0.3) %>%
add_trace(type = "scatter3d", mode = "markers",
data = as.data.frame(pts),
x = ~x, y = ~y, z = ~z,
marker = list(size = 5)) %>%
layout(scene = list(aspectmode = "data"))
Another solution with the Rvcg package. We use the vcgSphere function which generates a triangulated sphere.
sphr <- Rvcg::vcgSphere() # triangualted sphere
library(rgl) # to use scale3d and transform3d
ell <- scale3d(transform3d(sphr, A), r, r, r)
vs <- ell$vb[1:3,] + cr
idx <- ell$it - 1
p <- plot_ly() %>%
add_trace(type="mesh3d",
x = vs[1,], y = vs[2,], z = vs[3,],
i = idx[1,], j = idx[2,], k = idx[3,],
opacity = 0.3) %>%
add_trace(type = "scatter3d", mode = "markers",
data = as.data.frame(pts),
x = ~x, y = ~y, z = ~z,
marker = list(size = 5)) %>%
layout(scene = list(aspectmode = "data"))

I want to increase the maximum magnification of the graph in R in plotly

For graphs drawn with R in the R package(Plotly), there is a limit to enlarging the graph. After zooming to a certain size, I can not zoom in anymore, but I want to zoom in. Do you have any code or arguments that circumvent these restrictions?
If you want to go to the bottom of the link, please check the limit of enlargement with the last example 'Map'.
https://plot.ly/r/trisurf/
I need help!
// additional information
The following code shows the graph and I want to zoom in on the helicopter more than the image! Is there a way?
(Zooming is done using the tools of plotly or using the mouse wheel.)
Click graph image (Maximum magnification)
library(plotly)
library(geomorph)
data <- read.csv('https://raw.githubusercontent.com/plotly/datasets/master/_3d-line-plot.csv')
plyFile <- 'http://people.sc.fsu.edu/~jburkardt/data/ply/chopper.ply'
dest <- basename(plyFile)
if (!file.exists(dest)) {
download.file(plyFile, dest)
}
mesh <- read.ply(dest)
# see getS3method("shade3d", "mesh3d") for details on how to plot
# plot point cloud
x <- mesh$vb["xpts",]
y <- mesh$vb["ypts",]
z <- mesh$vb["zpts",]
m <- matrix(c(x,y,z), ncol=3, dimnames=list(NULL,c("x","y","z")))
# now figure out the colormap
zmean <- apply(t(mesh$it),MARGIN=1,function(row){mean(m[row,3])})
library(scales)
facecolor = colour_ramp(
brewer_pal(palette="RdBu")(10)
)(rescale(x=zmean))
p <- plot_ly(data, x = ~x1, y = ~y1, z = ~z1, type = 'scatter3d', mode = 'lines',
line = list(color = '#1f77b4', width = 1)) %>%
add_trace(x = ~x2, y = ~y2, z = ~z2,
line = list(color = 'rgb(44, 160, 44)', width = 1)) %>%
add_trace(x = ~x3, y = ~y3, z = ~z3,
line = list(color = 'bcbd22', width = 1))
add_trace(p, x = x, y = y, z = z,
i = mesh$it[1,]-1, j = mesh$it[2,]-1, k = mesh$it[3,]-1,
facecolor = facecolor,
type = "mesh3d")

Resources