R闪亮的rgl rgl.setMouseCallbacks答案

【问题标题】：R shiny rgl rgl.setMouseCallbacksR闪亮的rgl rgl.setMouseCallbacks
【发布时间】：2018-02-07 03:36:26
【问题描述】：

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() 调用，它会默认缩放。

我不太确定从这里去哪里。任何帮助都会很棒，干杯

【问题讨论】：

标签： r shiny rgl

【解决方案1】：

目前只有在交互窗口中由 R 完成显示时才支持鼠标回调。您正在使用rglwidget() 执行此操作，这意味着浏览器正在处理它。

我不知道是否可以说服 Shiny 管理交互式显示；这将要求 R 会话与显示器在同一系统上运行，或者在用户屏幕上使用带有远程显示器的 X 窗口，Windows 用户不太可能支持。

另一方面，如果您了解 Javascript，则可以编写一个 pan3d 的 Javascript 版本，用 rglwidget() 完成您想要的操作。

【讨论】：