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

Question

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

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

创建一个 jobs/plots
点击“开始”创建一个后台进程来创建绘图
- 如果用户什么都不做，绘图将在后台计算。我每秒使用 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 and its introductory vignette。

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

cancelOutput: If TRUE and an output is being evaluated, stop processing as usual but instead of clearing the output, leave it in whatever state it happens to be in.

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)

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

How to show a loading screen when the output is being calculated in a background process?

r

shiny