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

Question

This question is in the continuity of this one: Is it possible to stop executing of R code inside shiny (without stopping the shiny process)?.

The plot that I display in my app takes some time to produce, and I want the users to be able to stop its creation (for instance if they made a mistake in the options). I found this blog post about using callr in Shiny. The workflow is the following:

• create an empty list of jobs/plots
• clicking on "start" creates a background process to create the plot
  • if the user doesn't do anything, the plot is computed in the background. I use invalidateLater() every second to check if the background process is finished. If it is, then I display the plot.
  • if the user clicks on "stop" before the end of the process, the process is killed, removed from the list, and the previous plot is displayed (if there was no plot produced before, nothing is displayed)

First, I'm not sure how this would scale when several people use the app at the same time. Since every background process is independent, I don't think one user would be blocking the others, but I may be wrong.

Second, I'd like to show a waiting indicator on the plot. So far, I used the package waiter to do that, but the problem here is that renderPlot() is being invalidated every second to check if the background process is finished. Therefore, waiter appears and disappears repeatedly as the output is being invalidated.

Below is an example app that mimics the behavior I'd like to have:

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)

Current behavior:

• run the app, click on "Start job"
• notice that the waiter overlay appears and disappears

Question: How can I get a constant loading screen on the plot when it is being calculated in the background?

Answer 1

Regarding your first concern: this approach won't block other sessions. However, the polling via invalidateLater() will create some load.

A great library to look at in this context is ipc and its introductory vignette.

Regarding the second issue: There is a simple fix for this behaviour. We can use req and its cancelOutput parameter - see ?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)