Parallel processes in Shiny R (future, promises)

[tomsu]

I have problem with understanding how parallel processes in Shiny works. I created simple Shiny app with 2 processes:

1. first is waiting 10s (Sys.sleep(20))
2. second generate random heatmap both are triggered by actionButtons. The idea of the application is to test the asynchrony of processes, i.e. I run process 1, and during it generates a heatmap using the process 2.

Where is the problem? Well, the application works as expected when the button that starts the process 2 is in the observeEvent, which observes the button responsible for starting the process 1 (code lines 49-51). However, if I define this button outside of observeEvent, asynchrony doesn't work and process 1 will be executed first, and then the generated heatmap will appear.

Can someone explain to me why it works like this? Maybe I have a mistake somewhere? I am inclined to do so, because otherwise the necessity defined as I described in the first case makes this functionality very troublesome with more complex applications with many processes. I have R version 4.0.3

library(shiny)
library(promises)
library(future)
library(DT)
library(plotly)
library(chron)

plan(multisession)

testAsyncProcess <- function(x){
  start <- Sys.time()
  Sys.sleep(x)
  end <- Sys.time()
  result <- data.frame(
    start = as.character(times(strftime(start,"%H:%M:%S"))),
    end   = as.character(times(strftime(end,  "%H:%M:%S"))),
    duration = round(end - start,1)
  )
  return(result)
}

ui <- fluidPage(
  titlePanel("async test app"),
  sidebarLayout(
    sidebarPanel(width = 12,
      fluidRow(
        column(3, uiOutput("SimulateAsyncProcesses"), style = 'margin-top:25px'),
        column(4, DTOutput("ProcessInfo"))
      )
    ),
    mainPanel(width = 12,
      fluidRow(
        column(2, uiOutput("GenerateDataToPlot")),
        column(8, offset = 1, plotlyOutput("GeneratedHeatMap"))
      )
    )
  )
)

server <- function(input, output, session) {
  processInfo <- reactiveVal()
  
  DataToPlot <- eventReactive(input$GenerateDataToPlot, {
    matrix(runif(100), nrow = 10, ncol = 10)
  })
  observeEvent(input$SimulateAsyncProcesses, {
    future_promise({testAsyncProcess(10)}) %...>% processInfo()
    
    output$GenerateDataToPlot <- renderUI({
      actionButton("GenerateDataToPlot", "Generate data to plot")
    })
  })
  output$SimulateAsyncProcesses <- renderUI({
    actionButton("SimulateAsyncProcesses", "Simulate async processes")
  })
  output$ProcessInfo            <- renderDT({
    req(processInfo())
    datatable(processInfo(), rownames = FALSE, options = list(dom = 't'))
  })
  output$GenerateDataToPlot     <- renderUI({
    #actionButton("GenerateDataToPlot", "Generate data to plot")
  })
  output$GeneratedHeatMap       <- renderPlotly({
    req(DataToPlot())
    plot_ly(z = DataToPlot(), type = "heatmap")
  })
}

shinyApp(ui = ui, server = server)

[nirgrahamuk]

I agree with you , I'm not seeing expected behaviour. I tried in some ways to simplify what you had, but it doesnt appear to be async in the desired way.

library(shiny)
library(promises)
library(future)
library(plotly)
library(chron)
plan(multisession)

testAsyncProcess <- function(x){
  start <- Sys.time()
  for(i in seq_len(x)){
    Sys.sleep(1)
    print("sleeping")
  }
  end <- Sys.time()
  result <- data.frame(
    start = as.character(times(strftime(start,"%H:%M:%S"))),
    end   = as.character(times(strftime(end,  "%H:%M:%S"))),
    duration = round(end - start,1)
  )
  return(result)
}

ui <- fluidPage(
  titlePanel("async test app"),
  sidebarLayout(
    sidebarPanel(width = 12,
      fluidRow(
        column(3,  actionButton("SimulateAsyncProcesses", 
                                "Simulate async processes")
, style = 'margin-top:25px'),
        column(4, tableOutput("ProcessInfo"))
      )
    ),
    mainPanel(width = 12,
      fluidRow(
        column(2,  actionButton("GenerateDataToPlot", 
                                "Generate data to plot")),
        column(8, offset = 1, plotlyOutput("GeneratedHeatMap"))
      )
    )
  )
)

server <- function(input, output, session) {


  output$ProcessInfo <- renderTable({
    req(input$SimulateAsyncProcesses)
  future_promise({
      testAsyncProcess(5)})
    })

  DataToPlot <- eventReactive(input$GenerateDataToPlot, {
    print("clicked for plot")
    matrix(runif(100), nrow = 10, ncol = 10)
  })
  
  output$GeneratedHeatMap       <- renderPlotly({
    req(DataToPlot())
    plot_ly(z = DataToPlot(), type = "heatmap")
  })
}

shinyApp(ui = ui, server = server)

[michaelbgarcia]

This is new territory for me, but from what I understand, {promises} handles the problem of scaling an app to allow for concurrent users. I think what your original app is doing (haven't tested this part) is allowing for a second user to come in and generate the heatmap while the first user is running the long task. Without {promises}, the second user would need to wait for the first user to finish that long process. Still, {promises} does not deal with the same user interacting with the app while they are running their own long task. This is where {callr} comes in, specifically the ability to run background processes. This is explained much better in this post.

Borrowing some code from there and @nirgrahamuk simplified example, the below app should work as you intended. This will solve the problem of you wanting to perform tasks simultaneously, but it wouldn't (I don't think) scale for concurrent users which you would need {promises} for.

Definitely check out https://callr.r-lib.org/ for more info

library(shiny)
library(plotly)
library(chron)
library(callr)

testAsyncProcess <- function(x) {
  start <- Sys.time()
  for (i in seq_len(x)) {
    Sys.sleep(1)
    print("sleeping")
  }
  end <- Sys.time()
  result <- data.frame(
    start = as.character(chron::times(strftime(start, "%H:%M:%S"))),
    end   = as.character(chron::times(strftime(end,  "%H:%M:%S"))),
    duration = round(end - start, 1)
  )
  return(result)
}

ui <- fluidPage(titlePanel("async test app"),
                sidebarLayout(
                  sidebarPanel(width = 12,
                               fluidRow(
                                 column(
                                   3,
                                   actionButton("SimulateAsyncProcesses",
                                                "Simulate async processes")
                                   ,
                                   style = 'margin-top:25px'
                                 ),
                                 column(4, tableOutput("ProcessInfo"))
                               )),
                  mainPanel(width = 12,
                            fluidRow(
                              column(2,  actionButton(
                                "GenerateDataToPlot",
                                "Generate data to plot"
                              )),
                              column(8, offset = 1, plotlyOutput("GeneratedHeatMap"))
                            ))
                ))

server <- function(input, output, session) {
  output$ProcessInfo <- renderTable({
    req(check())
    check()
  })
  
  DataToPlot <- eventReactive(input$GenerateDataToPlot, {
    print("clicked for plot")
    matrix(runif(100), nrow = 10, ncol = 10)
  })
  
  output$GeneratedHeatMap <- renderPlotly({
    req(DataToPlot())
    plot_ly(z = DataToPlot(), type = "heatmap")
  })
  
  long_run <- eventReactive(input$SimulateAsyncProcesses, {
    x <- callr::r_bg(
      func = testAsyncProcess,
      args = list(x = 5),
      supervise = TRUE
    )
    return(x)
  })
  
  check <- reactive({
    invalidateLater(millis = 1000, session = session)
    if (!long_run()$is_alive()) x = long_run()$get_result() else x = NULL
    return(x)
  })
}

shinyApp(ui = ui, server = server)