Plot animation in Shiny with rgl - r

Question

I just started using Shiny and I'm trying to plot an "animation" using lapply or a for loop in Shiny, but I can't seem to get the correct output. When using base R, my code works.
My data is not set as a time series, but each row represents an observation in time.
Also, I'm willing to use another package (other than rgl), if necessary.
And, I'm making use of some of the code described here, including the javascript file rglwidgetaux.js .
global.R
library(rgl)
# MAIN FUNCTION
movement.points<-function(DATA,time.point,CONNECTOR){
DATA.time<-DATA[time.point,]
DATA.time<-matrix(DATA.time,c(3,4),byrow = TRUE)
x<-unlist(DATA.time[,1])
y<-unlist(DATA.time[,2])
z<-unlist(DATA.time[,3])
next3d(reuse=FALSE)
points3d(x=x,y=y,z=z,size=6,col="blue")
segments3d(x=c(x,x[CONNECTOR]),y=c(y,y[CONNECTOR]),z=c(z,z[CONNECTOR]),col="red")
Sys.sleep(0.05)
}
############################################################################
Using the function above, this works:
# INITIAL POSITION
rgl.viewpoint(userMatrix=rotationMatrix(0,2,0,0))
U <- par3d("userMatrix")
par3d(userMatrix = rotate3d(U, pi, 1,1,2))
movement.points(DATA=DATA.position,time.point=1,CONNECTOR=CONNECTOR)
# # ANIMATION (THIS IS WHAT I WANT TO RUN IN SHINY)
lapply(1:dim(DATA.position),movement.points,DATA=DATA.position,CONNECTOR=CONNECTOR)
But I can't get the "animation" (the lapply) to work in Shiny. This is what I've done:
ui.R
library(shiny)
library(rgl)
library(htmlwidgets)
library(jsonlite)
rglwgtctrl <- function(inputId, value="", nrows, ncols) {
# This code includes the javascript that we need and defines the html
tagList(
singleton(tags$head(tags$script(src = "rglwidgetaux.js"))),
tags$div(id = inputId,class = "rglWidgetAux",as.character(value))
)
}
ui <- fluidPage(
rglwgtctrl('ctrlplot3d'),
rglwidgetOutput("plot3d"),
actionButton("queryumat", "Select initial position"),
tableOutput("usermatrix"),
actionButton("regen", "Visualize sequence with new position")
,rglwidgetOutput("plot3d2")
)
server.R
source('global.R', local=TRUE)
library(shiny)
library(rgl)
library(jsonlite)
library(htmlwidgets)
options(shiny.trace=TRUE)
server <- function(input, output, session)
{
# DATA
DATA.position<-c(0.099731,-0.509277,3.092024,1,0.173340,-0.869629,3.142025,1,0.197632,-0.943848,3.099056,1,
0.099315,-0.509114,3.094403,1,0.173125,-0.868526,3.140778,1,0.196985,-0.943108,3.100157,1,
0.099075,-0.509445,3.094318,1,0.172445,-0.869610,3.138849,1,0.196448,-0.943238,3.100863,1,
0.097668,-0.508197,3.090442,1,0.172319,-0.869749,3.138942,1,0.195357,-0.943346,3.102253,1,
0.096432,-0.507724,3.087681,1,0.172151,-0.870230,3.139060,1,0.193886,-0.943752,3.103878,1,
0.095901,-0.508632,3.086148,1,0.172345,-0.870636,3.139181,1,0.193134,-0.943644,3.107753,1,
0.093076,-0.513129,3.082425,1,0.173721,-0.874329,3.139272,1,0.188041,-0.949220,3.111685,1,
0.092158,-0.513409,3.082376,1,0.173221,-0.876358,3.141781,1,0.188113,-0.949724,3.111405,1,
0.091085,-0.513667,3.082308,1,0.173626,-0.876292,3.140349,1,0.189704,-0.948493,3.108416,1,
0.089314,-0.514493,3.083489,1,0.173133,-0.876019,3.141443,1,0.189653,-0.947757,3.108083,1,
0.087756,-0.515289,3.084332,1,0.172727,-0.875819,3.141264,1,0.189452,-0.947415,3.108107,1,
0.085864,-0.515918,3.085951,1,0.172672,-0.876940,3.141271,1,0.190892,-0.946514,3.104689,1,
0.084173,-0.515356,3.087133,1,0.172681,-0.876866,3.140089,1,0.189969,-0.944275,3.100415,1,
0.065702,-0.518090,3.097703,1,0.172706,-0.876582,3.139876,1,0.189737,-0.944277,3.100796,1,
0.063853,-0.517976,3.099412,1,0.172821,-0.876308,3.139856,1,0.189682,-0.944037,3.100752,1,
0.062551,-0.518264,3.100512,1,0.172848,-0.874960,3.139102,1,0.190059,-0.942105,3.098919,1,
0.065086,-0.517151,3.098104,1,0.172814,-0.875237,3.138775,1,0.190539,-0.942204,3.098439,1,
0.064088,-0.517003,3.098001,1,0.172911,-0.874908,3.137694,1,0.190593,-0.942012,3.097417,1,
0.065648,-0.516077,3.094584,1,0.172581,-0.874648,3.137671,1,0.190480,-0.942432,3.098431,1,
0.068117,-0.516750,3.094343,1,0.172545,-0.874946,3.136352,1,0.190648,-0.942610,3.096850,1)
DATA.position<-matrix(DATA.position,c(20,12),byrow = TRUE)
CONNECTOR<-c(1,2,3)
#############################################
# THIS WORKS
# INITIAL POSITION MATRIX
observe({
input$queryumat
session$sendInputMessage("ctrlplot3d",list("cmd"="getpar3d","rglwidgetId"="plot3d"))
})
# USER POSITION MATRIX
# SELECTION
umat <-reactive({
shiny::validate(need(!is.null(input$ctrlplot3d),"User Matrix not yet queried"))
umat <- matrix(0,4,4)
jsonpar3d <- input$ctrlplot3d
if (jsonlite::validate(jsonpar3d)){
par3dout <- fromJSON(jsonpar3d)
umat <- matrix(unlist(par3dout$userMatrix),4,4) # make list into matrix
}
return(umat)
})
## SHOW POSITION
output$usermatrix <- renderTable({
umat()
})
# INITIAL IMAGE
scenegen <- reactive({
rgl.viewpoint(userMatrix=rotationMatrix(0,2,0,0))
U <- par3d("userMatrix")
par3d(userMatrix = rotate3d(U, pi, 1,1,2))
movement.points(DATA=DATA.position,time.point=1,CONNECTOR=CONNECTOR)
scene1 <- scene3d()
rgl.close() # make the app window go away
return(scene1)
})
output$plot3d <- renderRglwidget({ rglwidget(scenegen()) })
############################################################
# NOT WORKING
# Animation after selecting position
# 1st TRY
# scenegen2 <- eventReactive(input$regen,({
# par3d(userMatrix = umat())
# lapply(1:dim(DATA.position)[1],movement.points,DATA=DATA.position,CONNECTOR=CONNECTOR)
# scene2 <- scene3d()
# rgl.close() # make the app window go away
# return(scene2)
# })
# )
# output$plot3d2 <- renderRglwidget({ rglwidget(scenegen2()) })
# 2nd TRY
# output$plot3d2 <- eventReactive(input$regen,
# renderRglwidget({
# lapply(1:dim(DATA.position)[1],movement.points,DATA=DATA.position,CONNECTOR=CONNECTOR)
# scene2 <- scene3d()
# rgl.close() # make the app window go away
# return(scene2)
# })
# )
# 3rd TRY
# for (i in 1:(dim(DATA.position)[1])){
# scenegen2 <- eventReactive(input$regen,({
# par3d(userMatrix = umat())
# movement.points(DATA=DATA.position,time.point=i,CONNECTOR=CONNECTOR)
# scene2 <- scene3d()
# rgl.close() # make the app window go away
# return(scene2)
# })
# )
# output$plot3d2 <- renderRglwidget({ rglwidget(scenegen2()) })
# }
#4th TRY
observe({
input$regen
isolate({
for (i in 1:(dim(DATA.position)[1])){
par3d(userMatrix = umat())
movement.points(DATA=DATA.position,time.point=1,CONNECTOR=CONNECTOR)
scene2 <- scene3d()
rgl.close()
output$plot3d2 <- renderRglwidget({ rglwidget(scene2) })
}
})
})
}
Thanks.

Answer 1

I've found animations using Shiny are too slow: there's a lot of data passed from R to Javascript to show an rgl scene, and it takes too long for each frame update. You're better off using the techniques shown in the WebGL vignette based on playControl. Unfortunately these require you to precompute data for each animation frame, so aren't always available.