R闪亮的rgl rgl.setMouseCallbacks

Question

Shiny是否会阻止rgl.setMouseCallbacks函数启用自定义鼠标映射，如平移？我试着从帮助中弄清楚pan3d，但没有用。

下面是一个示例：

library(shiny)
library(plot3D)
library(rgl)

ui <- fluidPage(

  titlePanel("3D slice test"),

  tags$head(tags$style("#rglplot{height:90vh !important;}")),

  sidebarLayout(
    sidebarPanel(
      sliderInput('xs', 'Easting', min = 0, max = 1, value = 0.5, step = 0.1),
      sliderInput('ys', 'Northing', min = 0, max = 1, value = 0.5, step = 0.1),
      sliderInput('zs', 'Depth', min = 0, max = 2, value = 1, step = 0.1)
    ),

    mainPanel(
      rglwidgetOutput('rglplot', width = "100%")
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output, session) {

  #some data
  x <- y <- seq(0, 1, by = 0.1)
  z <- exp(seq(0, 1, by = 0.1)) - 1
  grid <- mesh(x, y, z)
  colvar <- with(grid, x*exp(-x^2 - y^2 - z^2))

  pan3d <- function(button){
    start <- list()

    begin <- function(x, y) {
      start$userMatrix <<- par3d("userMatrix")
      start$viewport <<- par3d("viewport")
      start$scale <<- par3d("scale")
      start$projection <<- rgl.projection()
      start$pos <<- rgl.window2user( x/start$viewport[3], 1 - y/start$viewport[4], 0.5, 
                                     projection = start$projection)
    }

    update <- function(x, y) {
      xlat <- (rgl.window2user( x/start$viewport[3], 1 - y/start$viewport[4], 0.5,
                                projection = start$projection) - start$pos)*start$scale
      mouseMatrix <- translationMatrix(xlat[1], xlat[2], xlat[3])
      par3d(userMatrix = start$userMatrix %*% t(mouseMatrix) )
    }
    rgl.setMouseCallbacks(button, begin, update)
    cat("Callbacks set on button", button, "of rgl device", rgl.cur(), "\n")
  }

  scene2 <- reactive({

    #plot colour
    col_plt <- (colvar - min(colvar))/diff(range(colvar))*127+1
    col_lut <- rainbow(128)

    # find the colours to use at each slice
    nx <- which.min(abs(x-input$xs))
    ny <- which.min(abs(y-input$ys))
    nz <- which.min(abs(z-input$zs))
    colz <- col_lut[col_plt[,,nz]]
    colx <- col_lut[col_plt[nx,,]]
    coly <- col_lut[col_plt[,ny,]]

    # Plot surfaces
    open3d(useNULL = T)
    rgl.surface(x, y, array(input$zs, dim=c(length(x), length(y))), color=colz, specular="black", coords=c(1, 3, 2))
    rgl.surface(y, z, array(input$xs, dim=c(length(y), length(z))), color=colx, specular="black", coords=c(2, 1, 3))
    rgl.surface(x, z, array(input$ys, dim=c(length(x), length(z))), color=coly, specular="black", coords=c(1, 2, 3))
    axes3d()
    title3d(xlab = "X", ylab = "Y", zlab = "Z")

    # try to set mouse panning here
    pan3d(3)
    scene1 <- scene3d()
    rgl.close()
    scene1
  })

  output$rglplot <- renderRglwidget({
    rglwidget(scene2())
  })
}

shinyApp(ui = ui, server = server)

请注意，鼠标中键受到影响，因为它不再放大/缩小。如果注释掉pan3d()调用，它会默认缩放。

我不太确定下一步该怎么做。任何帮助都是最好的，干杯

Answer 1

当前仅当R在交互式窗口中完成显示时，才支持鼠标回调。您使用的是rglwidget()，这意味着浏览器正在处理它。

我不知道是否可以说服Shiny来管理交互式显示；这将需要R会话在与显示相同的系统上运行，或者使用X窗口并在用户屏幕上远程显示，这可能不是windows用户所支持的。

另一方面，如果你知道Javascript，你也许能够编写一个用rglwidget()做你想做的事的pan3d的Javascript版本。