Shiny Background Process

R is a very powerful language but was designed to run single-threaded. There are libraries that will run parallel code but there is no inherent support to run a background process and monitor for completion in the same way that you can in, for example, C++.

One way to overcome this is to launch a second instance of R and run the process in the background. If the background process generates a log file it can be monitored within Shiny using the reactivePoll or reactiveFileInput functions. Once completed subsequent action can be taken. The advantage of this method is that the second process is run under a second instance of R and does not interfere with the user interface of the Shiny app.

By way of example, there are two apps below. The first attempts to run the process within an observer which ties up the UI – the UI will only respond to changes once the calculation is completed. The second launches a second instance and the UI is not affected – the UI is fully responsive during the calculation.

Running as a Single Process

The gist for the code can be found at https://gist.github.com/harveyl888/fa6ff9823b9c5a5fff11c946d8e7c9f5

## Data creation
## 
## Create a large Excel spreadsheet within a Shiny app
##

library(shiny)
library(openxlsx)

## Create a dummy matrix

server <- function(input, output, session) {
  
  mydata <- reactiveValues(wb = NULL)
  status <- reactiveValues(text = 'Waiting')
  
  ## Disable download button
  observe({
    session$sendCustomMessage('disableButton', 'butDownload')
  })

  ## Generate Excel output
  observeEvent(input$butCreate, {
    session$sendCustomMessage('disableButton', 'butDownload')
    session$sendCustomMessage('disableButton', 'butCreate')
    
    ## Included for comparison - the status text will not update until after the spreadsheet is built
    status$text <- 'Building'
    
    m <- matrix(rexp(input$numRows * input$numCols, rate = 0.1), ncol = input$numCols)
    
    wb <- createWorkbook()
    addWorksheet(wb, 'sheet1')
    writeData(wb, 'sheet1', m)
    mydata$wb <<- wb
    session$sendCustomMessage('enableButton', 'butDownload')
    session$sendCustomMessage('enableButton', 'butCreate')
    status$text <- 'Completed'
  })
  
  output$butDownload <- downloadHandler(
    filename = function() {
      'output.xlsx'
    },
    content = function(file) {
      showNotification('Writing Excel File')
      saveWorkbook(mydata$wb, file, overwrite = TRUE)
    }
  )
  
  output$uiStatus <- renderUI(
    h4(paste0('STATUS: ', status$text), style="color:red;")
  )

  output$plt <- renderPlot({
    hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks),
         xlab = 'Duration (minutes)', main = 'Geyser eruption duration')
    dens <- density(faithful$eruptions, adjust = input$bw_adjust)
    lines(dens, col = 'blue')
  })
}

ui <- fluidPage(
  singleton(tags$head(HTML('
    <script type="text/javascript">
    $(document).ready(function() {
      // Enable button
      Shiny.addCustomMessageHandler("enableButton", function(id) {
        $("#" + id).removeAttr("disabled");
      });
      // Disable button
      Shiny.addCustomMessageHandler("disableButton", function(id) {
        $("#" + id).attr("disabled", "true");
      });
      })
    </script>
    ')
  )),
  fluidRow(
    column(4,
           wellPanel(
             fluidRow(
               column(6, numericInput('numRows', 'Number of Rows', value = 100000, min = 1000, step = 1000)),
               column(6, numericInput('numCols', 'Number of Columns', value = 50, min = 10, step = 10))
             )
           ),
           fluidRow(
             column(11, offset = 1,
                    actionButton('butCreate', 'Create Data', class = 'btn action-button btn-success'),
                    downloadButton('butDownload', 'Download Data', class = 'btn btn-warning'),
                    br(),
                    uiOutput('uiStatus')
             )
           )
    ),
    column(8,
           wellPanel(
             fluidRow(
               column(4, selectInput('n_breaks', label = 'Number of bins:', choices = c(10, 20, 35, 50), selected = 20)),
               column(4, sliderInput('bw_adjust', label = 'Bandwidth adjustment:', min = 0.2, max = 2, value = 1, step = 0.2))
             )
           ),
           plotOutput('plt')
           )
    )
  )

shinyApp(ui = ui, server = server)

Running as an Asynchronous Process

The gist for the code can be found at https://gist.github.com/harveyl888/bf05d902b10c138a02acd5c9c65fc5da

## Data creation
## 
## Create a large Excel spreadsheet as a asynchronous process
##

library(shiny)

## Temporary files to store log, script, rds data and excel output
logfile <- tempfile()
scriptfile <- tempfile()
datafile <- tempfile()
excelfile <- tempfile()

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

  status <- reactiveValues(text = 'Waiting')
    
  ## Disable download button
  observe({
    session$sendCustomMessage('disableButton', 'butDownload')
  })
  
  # reactivePoll - look for changes in log file every second
  logData <- reactivePoll(1000, session,
                          checkFunc = function() {
                            if (file.exists(logfile))
                              file.info(logfile)$mtime[1]
                            else
                              ''
                            },
                          valueFunc = function() {
                            if (file.exists(logfile))
                              readLines(logfile)
                            else
                              ''
                            }
  )

  ## React to an update in the logfile
  observe({
    if (grepl('COMPLETED', logData())) {
      session$sendCustomMessage('enableButton', 'butDownload')
      session$sendCustomMessage('enableButton', 'butCreate')
      status$text <- 'Completed'
    } 
  })

  ## Generate Excel output
  ## Once button is pressed create an R Script and run as a second process
  ## to avoid tying up Shiny
  observeEvent(input$butCreate, {
    session$sendCustomMessage('disableButton', 'butDownload')
    session$sendCustomMessage('disableButton', 'butCreate')
    status$text <- 'Building'

    m <- matrix(rexp(input$numRows * input$numCols, rate = 0.1), ncol = input$numCols)
    
    ## Write data to an rds file
    saveRDS(m, file = datafile)
    
    ## Create script file
    vfile <- c('library(openxlsx)',
               paste0('m <- readRDS(\"', datafile, '\")'),
               'wb <- createWorkbook()',
               'addWorksheet(wb, \"sheet1\")',
               'writeData(wb, \"sheet1\", m)',
               paste0('saveWorkbook(wb, \"', excelfile, '\", overwrite = TRUE)'),
               paste0('fileConn <- file(\"', logfile, '\")'),
               'writeLines(\"COMPLETED\", fileConn)',
               'close(fileConn)'
               )
    
    ## Save script file
    fileConn <- file(scriptfile)
    writeLines(vfile, fileConn)
    close(fileConn)
    
    ## Execute script file
    system(paste0(Sys.getenv('R_HOME'), '/bin/Rscript ', scriptfile), wait = FALSE)
  })
  
  output$butDownload <- downloadHandler(
    filename <- function() {
      'excel-out.xlsx'
    },
    content <- function(file) {
      file.copy(excelfile, file)
    }
  )
  
  output$uiStatus <- renderUI(
    h4(paste0('STATUS: ', status$text), style="color:red;")
  )
  
  output$plt <- renderPlot({
    hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks),
         xlab = 'Duration (minutes)', main = 'Geyser eruption duration')
    dens <- density(faithful$eruptions, adjust = input$bw_adjust)
    lines(dens, col = 'blue')
  })
}

ui <- fluidPage(
  singleton(tags$head(HTML('
    <script type="text/javascript">
    $(document).ready(function() {
      // Enable button
        Shiny.addCustomMessageHandler("enableButton", function(id) {
      $("#" + id).removeAttr("disabled");
      });
      // Disable button
        Shiny.addCustomMessageHandler("disableButton", function(id) {
      $("#" + id).attr("disabled", "true");
      });
    })
    </script>
    ')
  )),
  fluidRow(
    column(4,
           wellPanel(
             fluidRow(
               column(6, numericInput('numRows', 'Number of Rows', value = 100000, min = 1000, step = 1000)),
               column(6, numericInput('numCols', 'Number of Columns', value = 50, min = 10, step = 10))
             )
           ),
           fluidRow(
             column(11, offset = 1,
               actionButton('butCreate', 'Create Data', class = 'btn action-button btn-success'),
               downloadButton('butDownload', 'Download Data', class = 'btn btn-warning'),
               br(),
               uiOutput('uiStatus')
             )
           )
    ),
    column(8,
           wellPanel(
             fluidRow(
               column(4, selectInput('n_breaks', label = 'Number of bins:', choices = c(10, 20, 35, 50), selected = 20)),
               column(4, sliderInput('bw_adjust', label = 'Bandwidth adjustment:', min = 0.2, max = 2, value = 1, step = 0.2))
             )
           ),
           plotOutput('plt')
           )
    )
  )

shinyApp(ui = ui, server = server)

Harvey Lieberman

Written by

Updated