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.
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.
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"))