Async: Display progress when actionButton is hit and disable other operations for the same user but allow concurrent users

chas · October 19, 2018, 1:27pm

Below is a sample code which takes two inputs: 1) input file and 2) input number of rows. Upon clicking the "Analyze" button the output from the server command return to the "Table" in "Results" tabset. This is a simple example where the command will be executed quickly and switches to the "Results" tabsetpanel. In the real app, the tasks takes several minutes to run and soon figured out that it needs async programming in shiny.

The below withProgress code only shows the progress bar for the set time and disappears and then the actual code is executed. I would like to 1) show a "Status Message" or "Progress Bar" when the "Analyze" is hit and show as long as the command is run. As long as the progress bar is running the current user (other users can use the app) cannot perform any action from the side bar. Because in the real app, sidebar has more menuItems which does similar tasks like this and each task has a Analyze button. If the user is allowed to browse to sidebar pages and hit Analyze then the app will have overload of performing multiple tasks.

I read the blogs about async but unable to put right code in the right place. any help is appreciated as as the async concept is quiet new with few references or examples.

library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(width = 200,
                    sidebarMenu(id = "tabs",
                                menuItem(
                                  "File", tabName = "tab1", icon = icon("fas fa-file")
                                )))
body <- tabItem(tabName = "tab1",
        h2("Input File"),
        fluidRow(
          tabPanel(
            "Upload file",
            value = "upload_file",
            fileInput(
              inputId = "uploadFile",
              label = "Upload Input file",
              multiple = FALSE,
              accept = c(".txt")
            ),
            checkboxInput('header', label = 'Header', TRUE)
          ),
          box(
            title = "Filter X rows",
            width = 7,
            status = "info",
            tabsetPanel(
              id = "input_tab",
              tabPanel(
                "Parameters",
                numericInput(
                  "nrows",
                  label = "Entire number of rows",
                  value = 5,
                  max = 10
                ),
                actionButton("run", "Analyze")
              ),
              tabPanel(
                "Results",
                value = "results",
                navbarPage(NULL,
                           tabPanel(
                             "Table", DT::dataTableOutput("res_table"), 
icon = icon("table")
                           )),
                downloadButton("downList", "Download")
              )
            )
          )
        ))
ui <-
shinyUI(dashboardPage(
dashboardHeader(title = "TestApp", titleWidth = 150),
sidebar,dashboardBody(tabItems(body))
))


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

observeEvent(input$run, {
withProgress(session, min = 1, max = 15, {
  setProgress(message = 'Analysis in progress',
              detail = 'This may take a while...')
  for (i in 1:15) {
    setProgress(value = i)
    Sys.sleep(0.5)
  }
})
system(paste(
  "cat",
  input$uploadFile$datapath,
  "|",
  paste0("head -", input$nrows) ,
  ">",
  "out.txt"
),
intern = TRUE)
head_rows <- read.delim("out.txt")
file_rows(head_rows)
  })

observeEvent(file_rows(), {
updateTabsetPanel(session, "input_tab", "results")
output$res_table <-
DT::renderDataTable(DT::datatable(
file_rows(),
options = list(
  searching = TRUE,
  pageLength = 10,
  rownames(NULL),
  scrollX = T
  )
  ))
 })

output$downList <- downloadHandler(
filename = function() {
paste0("output", ".txt")
}, content = function(file) {
write.table(file_rows(), file, row.names = FALSE)
}
)
}

shinyApp(ui = ui, server = server)

chas · October 21, 2018, 7:59pm

To add more info, the actual app also uses system() commands as shown in the example.

jcheng · October 23, 2018, 9:19pm

This seems to be the main piece of code you're asking about:

  observeEvent(input$run, {
    withProgress(session, min = 1, max = 15, {
      setProgress(message = 'Analysis in progress',
        detail = 'This may take a while...')
      for (i in 1:15) {
        setProgress(value = i)
        Sys.sleep(0.5)
      }
    })
    system(paste(
      "cat",
      input$uploadFile$datapath,
      "|",
      paste0("head -", input$nrows) ,
      ">",
      "out.txt"
    ),
      intern = TRUE)
    head_rows <- read.delim("out.txt")
    file_rows(head_rows)
  })

With futures/promises, you need to clearly decide what operations happen inside of the Shiny process, and what operations happen in the future process. In this case, here are the steps that we want to happen, in order:

Show progress message (Shiny process)
Read reactives: input$uploadFile$datapath, input$nrows (Shiny)
Write all but the last nrows to out.txt (future process)
Read out.txt (Could be either, let's say future)
Dismiss progress (Shiny)
Assign result to file_rows (Shiny)

Here's what that looks like:

observeEvent(input$run, {
  prog <- Progress$new(session)
  prog$set(message = "Analysis in progress",
    detail = "This may take a while...",
    value = NULL)

  path <- input$uploadFile$datapath
  nrows <- input$nrows

  future({
    readLines(path) %>% head(-nrows) %>% writeLines("out.txt")
    read.delim("out.txt")
  }) %...>%
    file_rows() %>%
    finally(~prog$close())
})

As long as the future/promise pipeline is the last expression in the observeEvent (which it is in this case, as file_rows() and finally(...) are part of the pipeline) then Shiny will hold off on processing any messages on behalf of the user.

There are two things this solution doesn't address.

Progress messages take a step back; not only are we forced to use the Progress$new() syntax instead of the cleaner withProgress(), but we lost the ability to report on the progress percentage. You can try the new ipc package for a solution to that problem.
This doesn't stop the user from clicking around in the UI; it won't do anything while the async operation is executing, but when the operation is done those interactions will have accumulated in a queue and will be handled in the order that they arrived. If you'd like to actually disable the UI entirely so that they're not able to do anything at all, there's not currently a built-in way to do that in Shiny. Although come to think of it, you might try replacing the use of Progress with showModal(modalDialog(title = "Analysis in progress", "This may take a while...", footer=NULL)); I think that will at least stop mouse clicks.

ismirsehregal · October 26, 2018, 1:43pm

Here is an approach using the ipc-package, which takes care about above points 1. & 2. (first posted here):

library(shiny)
library(shinydashboard)
library(ipc)
library(promises)
library(future)
library(shinyjs)
library(datasets)
library(V8)

plan(multiprocess)

jsResetCode <- "shinyjs.reset = function() {history.go(0)}"

header <- dashboardHeader(title = "TestApp", titleWidth = 150)

sidebar <- dashboardSidebar(width = 200,
                            sidebarMenu(id = "tabs",
                                        menuItem(
                                          "File", tabName = "tab1", icon = icon("fas fa-file")
                                        )))

body <- dashboardBody(useShinyjs(),
                      extendShinyjs(text = jsResetCode),
                      fluidRow(column(
                        12, tabItem(
                          tabName = "tab1",
                          h2("Input File"),
                          textOutput("shiny_session"),
                          tabPanel(
                            "Upload file",
                            value = "upload_file",
                            fileInput(
                              inputId = "uploadFile",
                              label = "Upload Input file",
                              multiple = FALSE,
                              accept = c(".txt")
                            ),
                            checkboxInput('header', label = 'Header', TRUE)
                          ),
                          box(
                            title = "Filter X rows",
                            width = 7,
                            status = "info",
                            tabsetPanel(
                              id = "input_tab",
                              tabPanel(
                                "Parameters",
                                numericInput(
                                  "nrows",
                                  label = "Entire number of rows",
                                  value = 5,
                                  max = 10
                                ),
                                column(1, uiOutput("sessionRun")),
                                column(1, uiOutput("sessionCancel"))
                              ),
                              tabPanel(
                                "Results",
                                value = "results",
                                navbarPage(NULL,
                                           tabPanel(
                                             "Table", DT::dataTableOutput("res_table"),
                                             icon = icon("table")
                                           )),
                                downloadButton("downList", "Download")
                              )
                            )
                          )
                        )
                      )))



ui <- shinyUI(dashboardPage(
  header = header,
  sidebar = sidebar,
  body = body,
  title = "TestApp"
))


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

  output$shiny_session <-
    renderText(paste("Shiny session:", session$token))

  file_rows <- reactiveVal()

  run_btn_id <- paste0("run_", session$token)
  cancel_btn_id <- paste0("cancel_", session$token)

  output$sessionRun <- renderUI({
    actionButton(run_btn_id, "Analyze")
  })

  output$sessionCancel <- renderUI({
    actionButton(cancel_btn_id, "Cancel")
  })

  paste("Shiny session:", session$token)


  observeEvent(input[[run_btn_id]], {
    file_rows(NULL)

    shinyjs::disable(id = run_btn_id)

    progress <- AsyncProgress$new(message = 'Analysis in progress',
                                  detail = 'This may take a while...')
    row_cnt <- isolate(input$nrows)
    get_header <- isolate(input$header)

    future({
      fileCon <- file("out.txt", "w+", blocking = TRUE)
      linesCnt <- nrow(iris)
      for (i in seq(linesCnt)) {
        Sys.sleep(0.1)
        progress$inc(1 / linesCnt)
        writeLines(as.character(iris$Species)[i],
                   con = fileCon,
                   sep = "\n")
      }
      close(fileCon)
      head_rows <- read.delim("out.txt", nrows = row_cnt, header=get_header)
      progress$close() # Close the progress bar
      return(head_rows)
    }) %...>% file_rows

    return(NULL) # Return something other than the future so we don't block the UI
  })

  observeEvent(input[[cancel_btn_id]],{
    js$reset() # reset shiny session)
  })

  observeEvent(file_rows(), {
    shinyjs::enable(id = run_btn_id)
    updateTabsetPanel(session, "input_tab", "results")
    output$res_table <-
      DT::renderDataTable(DT::datatable(
        req(file_rows()),
        options = list(
          searching = TRUE,
          pageLength = 10,
          rownames(NULL),
          scrollX = T
        )
      ))
  })

  output$downList <- downloadHandler(
    filename = function() {
      paste0("output", ".txt")
    },
    content = function(file) {
      write.table(file_rows(), file, row.names = FALSE)
    }
  )
}

shinyApp(ui = ui, server = server)

The analyze button is session-wise disabled when the future is running by giving it session-dependant names. The only downside is the cancel-button functionlity which rather should be using AsyncInterruptor, than creating a new session.

jcblum · October 26, 2018, 2:47pm

Hey @chas! Glad you’ve got some answers. Please note that we frown on simultaneous cross-posting here (see: FAQ: Is it OK if I cross-post?).

If you cross-post here because your question hasn’t found any answers elsewhere within a reasonable amount of time, we ask that you state up front that it’s a cross-post, include a link to the other post, and update here if you get an answer somewhere else. The idea is that it is polite to be transparent and try to avoid wasting helpers’ time.