用rgl制作动画

Question

我刚开始使用闪亮动画，我试图用lapply或闪亮的for循环来绘制一个“动画”，但我似乎无法得到正确的输出。当使用基R时，我的代码工作。

我的数据不是作为时间序列设置的，但是每一行都代表一个时间上的观察。

另外，如果需要的话，我愿意使用另一个包(rgl除外)。

而且，我正在使用描述的一些代码，包括javascript文件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)
}

############################################################################

使用上面的函数，可以实现：

 # 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)

但我无法让“动画”( lapply)在闪亮的环境中工作。这就是我所做的：

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) })
      }
    })
  })
}

谢谢。

Answer 1

我发现使用闪亮动画的速度太慢了:有大量数据从R传递到Javascript以显示rgl场景，而且每次帧更新都要花费太长时间。您最好使用基于WebGL的playControl中显示的技术。不幸的是，这要求您预先计算每个动画帧的数据，因此并不总是可用的。