r - 从 future 中调用 Shiny 的 JavaScript 回调

Question

在shiny中，可以从服务器的逻辑调用用javascript编写的客户端回调。假设在 ui.R 中您有一些 JavaScript，其中包括一个名为 setText 的函数:

tags$script('
    Shiny.addCustomMessageHandler("setText", function(text) {
        document.getElementById("output").innerHTML = text;
    })          
')

然后在您的server.R中您可以调用session$sendCustomMessage(type='foo', 'foo')。

假设我有一个长时间运行的函数，它返回一些数据来绘制。如果我正常执行此操作，则 R 线程在运行此函数时会很忙，因此此时无法处理其他请求。如果能够使用 futures 包运行此函数，以便它与代码异步运行，并异步调用回调，那将非常有用。然而，当我尝试时，这似乎不起作用。

抱歉，如果这不是很清楚。作为一个简单的示例，在您取消注释 server.R 中尝试调用 future 的两行之前，以下内容应该有效。一旦这些行被取消注释，回调就永远不会被调用。显然，它在本示例的上下文中实际上并没有什么用处，但我认为一般情况下它会非常有用。

ui.R:

library(shiny)
shinyUI(fluidPage(
  sidebarLayout(
    sidebarPanel(
       sliderInput("max",
                   "Max random number:",
                   min = 1,
                   max = 50,
                   value = 30)
    ),
    mainPanel(
       verbatimTextOutput('output'),
       plotOutput('plot')
    )
  ),
  tags$script('
    Shiny.addCustomMessageHandler("setText", function(text) {
        document.getElementById("output").innerHTML = text;
    })          
  ')
))

服务器.R:

library(shiny)
library(future)
plan(multiprocess)
shinyServer(function(input, output, session) {
    output$plot <- reactive({
      max <- input$max
      #f <- future({
        session$sendCustomMessage(type='setText', 'Please wait')
        Sys.sleep(3)
        x <- runif(1,0,max)
        session$sendCustomMessage(type='setText', paste('Your random number is', x))
        return(NULL)
      #})
    })
})

Answer 1

这是一个关于如何在 Shiny 的应用程序中使用 future 包的解决方案。当运行计算密集型任务或等待 SQL 查询完成时，可能会存在多个 session ，而没有 session 会阻塞另一个 session 。我建议打开两个 session (只需在两个选项卡中打开 http://127.0.0.1:14072/)并使用按钮来测试功能。

run_app.R:

library(shiny)
library(future)
library(shinyjs)

runApp(host = "127.0.0.1", port = 14072, launch.browser = TRUE)

ui.R:

ui <- fluidPage(
            useShinyjs(),
            textOutput("existsFutureData"),
            numericInput("duration", "Duration", value = 5, min = 0),
            actionButton("start_proc", h5("get data")),
            actionButton("start_proc_future", h5("get data using future")),
            checkboxInput("checkbox_syssleep", label = "Use Sys.sleep", value = FALSE),
            h5('Table data'),
            dataTableOutput('tableData'),
            h5('Table future data'),
            dataTableOutput('tableFutureData')
)

服务器.R:

plan(multiprocess) 

fakeDataProcessing <- function(duration, sys_sleep = FALSE) {
  if(sys_sleep) {
    Sys.sleep(duration)
    } else {
    current_time <- Sys.time()
    while (current_time + duration > Sys.time()) {  }
  }
  return(data.frame(test = Sys.time()))
}
#fakeDataProcessing(5)
############################ SERVER ############################ 
server <- function(input, output, session) { 
  values <- reactiveValues(runFutureData = FALSE, futureDataLoaded = 0L)
  future.env <- new.env()

  output$existsFutureData <- renderText({ paste0("exists(futureData): ", exists("futureData", envir = future.env)," | futureDataLoaded: ", values$futureDataLoaded) })

  get_data <- reactive({
  if (input$start_proc > 0) {
    shinyjs::disable("start_proc")
    isolate({ data <- fakeDataProcessing(input$duration) })
    shinyjs::enable("start_proc")
    data
  }
})

  observeEvent(input$start_proc_future, { 
      shinyjs::disable("start_proc_future")
      duration <- input$duration # This variable needs to be created for use in future object. When using fakeDataProcessing(input$duration) an error occurs: 'Warning: Error in : Operation not allowed without an active reactive context.'
      checkbox_syssleep <- input$checkbox_syssleep
      future.env$futureData %<-% fakeDataProcessing(duration, sys_sleep = checkbox_syssleep)
      future.env$futureDataObj <- futureOf(future.env$futureData)
      values$runFutureData <- TRUE
      check_if_future_data_is_loaded$resume()
      },
    ignoreNULL = TRUE, 
    ignoreInit = TRUE
  )

  check_if_future_data_is_loaded <- observe({
      invalidateLater(1000)
      if (resolved(future.env$futureDataObj)) {
          check_if_future_data_is_loaded$suspend()
          values$futureDataLoaded <- values$futureDataLoaded + 1L
          values$runFutureData <- FALSE
          shinyjs::enable("start_proc_future")
      }
  }, suspended = TRUE)

  get_futureData <- reactive({ if(values$futureDataLoaded > 0) future.env$futureData })

  output$tableData <- renderDataTable(get_data())

  output$tableFutureData <- renderDataTable(get_futureData())

  session$onSessionEnded(function() {
    check_if_future_data_is_loaded$suspend()
  })
}