在Shiny应用中无显式控件实现MCMC轨迹高效动画问询

我正在开发一款Shiny应用，用于帮助学生理解不同MCMC采样器的工作原理，核心需求是在3D空间中实现轨迹的交互式流畅可视化。

目前我已经实现了从A点到B点的轨迹模拟，但运行速度极慢，无法满足后续扩展需求。我希望达成以下效果：

• 自动运行轨迹动画，无需用户点击播放按钮；
• 轨迹动态更新，类似rgl包ageControl示例中的动画逻辑，但不需要额外控制组件；
• 最终效果参考Hamiltonian Monte Carlo相关的轨迹动画（已有轨迹、曲面的计算能力，仅需解决高效绘图问题）。

尝试过playwidget、ageControl、subsetControl等方法以及非常规输入值更新方式，但均未达到理想效果。

当前实现代码 #

library(mvtnorm)
library(rgl)
library(shiny)

options(rgl.useNULL = TRUE)

df_basis <- tidyr::crossing(x1 = seq(-3, 3, 0.2), x2 = seq(-3, 3, 0.2))
x1 <- df_basis$x1
x2 <- df_basis$x2
f <- mvtnorm::dmvnorm(df_basis, c(0, 0), diag(2))

ui <- fluidPage(
  registerSceneChange(),  
  sidebarLayout(
    sidebarPanel(
      actionButton("add_point", "Add point"),
      actionButton("remove_points", "Remove points")
    ),
    mainPanel(
      rglwidgetOutput("rglPlot", width = "100%", height = 720)
    )
  )
)

g <- function() {
  z <- matrix(f, nrow = 31)
  x <- seq(-3, 3, 0.2)
  y <- seq(-3, 3, 0.2)
  
  bg3d(col="white")
  surface3d(x, y, z, color = "grey70", alpha = 0.6)
  aspect3d(20, 20, 20)
  axes3d()
}

g()
surface <- scene3d()
close3d()

server <- function(input, output, session) {
  plot3d(surface)
  dev <- cur3d()
  save <- options(rgl.inShiny = TRUE)
  on.exit(options(save))
  
  session$onSessionEnded(function() {
    set3d(dev)
    close3d()
  })
  
  output$rglPlot <- renderRglwidget({
    rglwidget()
  })
  
  current_points <- list()
  points_coords <- list()
  
  observeEvent(input$add_point, {
    new_point <- cbind(rmvnorm(1, c(0, 0), diag(2)), 0)
    
    if (!length(points_coords)) {
      old_point <- c(0, 0, 0)
    } else {
      old_point <- points_coords[[length(points_coords)]]
    }
    
    x1 <- old_point[1]
    y1 <- old_point[2]
    x2 <- new_point[1]
    y2 <- new_point[2]
    
    slope <- (y2 - y1) / (x2 - x1)
    intercept <- y1 - x1 * slope
    
    x_values <- seq(x1, x2, length.out = 30)
    y_values <- intercept + slope * x_values
    lines_list <- list()
    
    for (i in 2:30) {
      line <- lines3d(
        x = x_values[(i - 1):i], y = y_values[(i - 1):i], z = c(0, 0),
        color = "red"
      )
      session$sendCustomMessage(
        "sceneChange", sceneChange("rglPlot", add = line)
      )
      lines_list <- append(lines_list, line)
    }

    
    point <- points3d(new_point, color = "red", size = 4)
    session$sendCustomMessage(
      "sceneChange", sceneChange("rglPlot", add = point)
    )
    current_points <<- append(current_points, point)
    points_coords[[length(points_coords) + 1]] <<- new_point
    
    session$sendCustomMessage(
      "sceneChange", sceneChange("rglPlot", delete = lines_list)
    )
    
  })
  
  observeEvent(
    input$remove_points, {
      session$sendCustomMessage(
        "sceneChange",
        sceneChange("rglPlot", delete = current_points)
      )
      current_points <<- list()
    })
}

runApp(shinyApp(ui = ui, server = server), launch.browser = TRUE)

内容的提问来源于stack exchange，提问作者Tomas Capretto