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

Question

这个问题是这个问题的连续性：是否有可能停止执行shiny内部的R代码（而不停止shiny进程）？。

我在应用程序中显示的绘图需要一些时间才能生成，我希望用户能够停止其创建（例如，如果他们在选项中犯了错误）。我发现这篇关于在 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及其介绍性 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)