在后台进程中计算输出时如何显示加载屏幕？

Question

这个问题在这个问题的连续性中：Is it possible to stop executing of R code inside shiny (without stopping the shiny process)?。

我在我的应用程序中显示的情节需要一些时间来制作，我希望用户能够停止它的创建（例如，如果他们在选项中犯了错误）。我发现 this blog post 关于在 Shiny 中使用 callr。工作流程如下：

• 创建一个空的作业/地块列表
• 单击“开始”会创建一个后台进程来创建绘图
  • 如果用户不执行任何操作，则在后台计算绘图。我每秒使用invalidateLater() 来检查后台进程是否完成。如果是，那么我显示情节。
  • 如果用户在进程结束前点击“停止”，则进程被杀死，从列表中删除，并显示上一个绘图（如果之前没有生成绘图，则不显示）

首先，我不确定当几个人同时使用该应用时这会如何扩展。由于每个后台进程都是独立的，我不认为一个用户会阻止其他用户，但我可能错了。

其次，我想在情节上显示一个等待指示器。到目前为止，我使用包waiter 来执行此操作，但这里的问题是renderPlot() 每秒都会被无效以检查后台进程是否已完成。因此，waiter 在输出失效时反复出现和消失。

下面是一个模仿我想要的行为的示例应用：

library(shiny)
library(uuid)
library(ggplot2)
library(waiter)

ui <- fluidPage(
  useWaiter(),
  titlePanel("Test background job"),
  actionButton("start","Start Job"),
  actionButton("stop", "Stop job"),
  plotOutput("plot")
)

# the toy example job
slow_func <- function(var){
  library(ggplot2)
  Sys.sleep(5)
  ggplot(mtcars, aes(drat, !!sym(var))) + 
    geom_point()
}

server <- function(input, output, session) {
  
  w <- Waiter$new(id = "plot")

  token <- reactiveValues(var = NULL, id = NULL, last_id = NULL)
  jobs <- reactiveValues()
  
  
  # When I press "start", run the slow function and append the output to
  # the list of jobs. To render the plot, check if the background process is
  # finished. If it's not, re-check one second later.
  
  long_run <- eventReactive(input$start, {
    token$var <- c(token$var, sample(names(mtcars), 1))
    token$id <- c(token$id, UUIDgenerate())
    token$last_id <- token$id[[length(token$id)]]
    message(paste0("running task with id: ", token$last_id))
    jobs[[token$last_id]] <- callr::r_bg(
      func = slow_func,
      args = list(var = token$var[[length(token$var)]])
    )
    return(jobs[[token$last_id]])
  })
  
  observeEvent(input$start, {
    output$plot <- renderPlot({
      w$show()
      if (long_run()$poll_io(0)["process"] == "timeout") {
        invalidateLater(1000)
      } else {
        jobs[[token$last_id]]$get_result()
      }
    })
  })
  
  # When I press "stop", kill the last process, remove it from the list of
  # jobs (because it didn't produce any output so it is useless), and display 
  # the last process (which by definition is the last plot produced)
  
  observeEvent(input$stop, {
    
    if (length(token$id) > 0) {
      jobs[[token$last_id]]$kill()
      message(paste0("task ", token$last_id, " stopped"))
      token$id <- token$id[-length(token$id)]
      if (length(token$id) > 0) {
        token$last_id <- token$id[[length(token$id)]]
      }
    }
    
    output$plot <- renderPlot({
      if (length(token$id) > 0) {
        print(token$last_id)
        jobs[[token$last_id]]$get_result()
      } else {
        return(NULL)
      }
    })
  })
  
}

shinyApp(ui = ui, server = server)

当前行为：

• 运行应用，点击“开始作业”
• 请注意waiter 叠加层出现和消失

问题：在后台计算时，如何在绘图上获得恒定的加载屏幕？

Answer 1

关于您的第一个问题：这种方法不会阻止其他会话。但是，通过invalidateLater() 进行的轮询会产生一些负载。

ipc 及其 introductory vignette 是在这种情况下值得关注的一个很棒的库。

关于第二个问题：此行为有一个简单的修复方法。我们可以使用req 及其cancelOutput 参数——参见?req：

cancelOutput：如果 TRUE 并且正在评估输出，则停止 像往常一样处理，但不是清除输出，而是将其保留在 无论它碰巧处于什么状态。

library(shiny)
library(uuid)
library(ggplot2)
library(waiter)

ui <- fluidPage(
  useWaiter(),
  titlePanel("Test background job"),
  actionButton("start","Start Job"),
  actionButton("stop", "Stop job"),
  plotOutput("plot")
)

# the toy example job
slow_func <- function(var){
  library(ggplot2)
  Sys.sleep(5)
  ggplot(mtcars, aes(drat, !!sym(var))) + 
    geom_point()
}

server <- function(input, output, session) {
  
  w <- Waiter$new(id = "plot")
  
  token <- reactiveValues(var = NULL, id = NULL, last_id = NULL)
  jobs <- reactiveValues()
  
  
  # When I press "start", run the slow function and append the output to
  # the list of jobs. To render the plot, check if the background process is
  # finished. If it's not, re-check one second later.
  
  long_run <- eventReactive(input$start, {
    token$var <- c(token$var, sample(names(mtcars), 1))
    token$id <- c(token$id, UUIDgenerate())
    token$last_id <- token$id[[length(token$id)]]
    message(paste0("running task with id: ", token$last_id))
    jobs[[token$last_id]] <- callr::r_bg(
      func = slow_func,
      args = list(var = token$var[[length(token$var)]])
    )
    return(jobs[[token$last_id]])
  })
  
  observeEvent(input$start, {
    output$plot <- renderPlot({
      w$show()
      if (long_run()$poll_io(0)["process"] == "timeout") {
        invalidateLater(1000)
        req(FALSE, cancelOutput = TRUE)
      } else {
        jobs[[token$last_id]]$get_result()
      }
    })
  })
  
  # When I press "stop", kill the last process, remove it from the list of
  # jobs (because it didn't produce any output so it is useless), and display 
  # the last process (which by definition is the last plot produced)
  
  observeEvent(input$stop, {
    
    if (length(token$id) > 0) {
      jobs[[token$last_id]]$kill()
      message(paste0("task ", token$last_id, " stopped"))
      token$id <- token$id[-length(token$id)]
      if (length(token$id) > 0) {
        token$last_id <- token$id[[length(token$id)]]
      }
    }
    
    output$plot <- renderPlot({
      if (length(token$id) > 0) {
        print(token$last_id)
        jobs[[token$last_id]]$get_result()
      } else {
        return(NULL)
      }
    })
  })
  
}

shinyApp(ui = ui, server = server)