Animate trajectory in a Shiny app without explicit controls

Question

I'm trying to create a Shiny app to help my students learn how different MCMC samplers work. I want to have an interactive visualization where I show trajectories on a 3-dimensional space. This is my current approach to "mimic" a trajectory going from point A to point B.

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)

The problem is that this is very slow and it won't scale to what I want to do.

I basically want to have the behavior shown in the example in the documentation here https://dmurdoch.github.io/rgl/reference/ageControl.html, without having to use the control widgets. I don't want the user of my app to click Play so the trajectory moves. Also, trajectories will change all the time.

Does anyone have any recommendation to make it work?

I tried with playwidgets, ageControl, subsetControl, and many approaches to update input values in a hacky way, but nothing worked well.

edit just in case more context helps, I want to create something similar to the animation in the Hamiltonian Monte Carlo section at https://arogozhnikov.github.io/2016/12/19/markov_chain_monte_carlo.html

I already have everything to compute trajectories, surfaces, etc. The problem is that I can't plot them efficiently.