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

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.

CodePudding user response：

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.

CodePudding user response：

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.

CodePudding user response：

Here is an alternative approach using library(