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

Question

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.

user_11738400 · Answer

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.

user_11738400 · Answer

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.

user_9841389 · Answer

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

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

3 Answers