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
1## Data creation
2##
3## Create a large Excel spreadsheet within a Shiny app
4##
5
6library(shiny)
7library(openxlsx)
8
9## Create a dummy matrix
10
11server <- function(input, output, session) {
12
13 mydata <- reactiveValues(wb = NULL)
14 status <- reactiveValues(text = 'Waiting')
15
16 ## Disable download button
17 observe({
18 session$sendCustomMessage('disableButton', 'butDownload')
19 })
20
21 ## Generate Excel output
22 observeEvent(input$butCreate, {
23 session$sendCustomMessage('disableButton', 'butDownload')
24 session$sendCustomMessage('disableButton', 'butCreate')
25
26 ## Included for comparison - the status text will not update until after the spreadsheet is built
27 status$text <- 'Building'
28
29 m <- matrix(rexp(input$numRows * input$numCols, rate = 0.1), ncol = input$numCols)
30
31 wb <- createWorkbook()
32 addWorksheet(wb, 'sheet1')
33 writeData(wb, 'sheet1', m)
34 mydata$wb <<- wb
35 session$sendCustomMessage('enableButton', 'butDownload')
36 session$sendCustomMessage('enableButton', 'butCreate')
37 status$text <- 'Completed'
38 })
39
40 output$butDownload <- downloadHandler(
41 filename = function() {
42 'output.xlsx'
43 },
44 content = function(file) {
45 showNotification('Writing Excel File')
46 saveWorkbook(mydata$wb, file, overwrite = TRUE)
47 }
48 )
49
50 output$uiStatus <- renderUI(
51 h4(paste0('STATUS: ', status$text), style="color:red;")
52 )
53
54 output$plt <- renderPlot({
55 hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks),
56 xlab = 'Duration (minutes)', main = 'Geyser eruption duration')
57 dens <- density(faithful$eruptions, adjust = input$bw_adjust)
58 lines(dens, col = 'blue')
59 })
60}
61
62ui <- fluidPage(
63 singleton(tags$head(HTML('
64 <script type="text/javascript">
65 $(document).ready(function() {
66 // Enable button
67 Shiny.addCustomMessageHandler("enableButton", function(id) {
68 $("#" + id).removeAttr("disabled");
69 });
70 // Disable button
71 Shiny.addCustomMessageHandler("disableButton", function(id) {
72 $("#" + id).attr("disabled", "true");
73 });
74 })
75 </script>
76 ')
77 )),
78 fluidRow(
79 column(4,
80 wellPanel(
81 fluidRow(
82 column(6, numericInput('numRows', 'Number of Rows', value = 100000, min = 1000, step = 1000)),
83 column(6, numericInput('numCols', 'Number of Columns', value = 50, min = 10, step = 10))
84 )
85 ),
86 fluidRow(
87 column(11, offset = 1,
88 actionButton('butCreate', 'Create Data', class = 'btn action-button btn-success'),
89 downloadButton('butDownload', 'Download Data', class = 'btn btn-warning'),
90 br(),
91 uiOutput('uiStatus')
92 )
93 )
94 ),
95 column(8,
96 wellPanel(
97 fluidRow(
98 column(4, selectInput('n_breaks', label = 'Number of bins:', choices = c(10, 20, 35, 50), selected = 20)),
99 column(4, sliderInput('bw_adjust', label = 'Bandwidth adjustment:', min = 0.2, max = 2, value = 1, step = 0.2))
100 )
101 ),
102 plotOutput('plt')
103 )
104 )
105 )
106
107shinyApp(ui = ui, server = server)
Running as an Asynchronous Process
The gist for the code can be found at https://gist.github.com/harveyl888/bf05d902b10c138a02acd5c9c65fc5da
1## Data creation
2##
3## Create a large Excel spreadsheet as a asynchronous process
4##
5
6library(shiny)
7
8## Temporary files to store log, script, rds data and excel output
9logfile <- tempfile()
10scriptfile <- tempfile()
11datafile <- tempfile()
12excelfile <- tempfile()
13
14server <- function(input, output, session) {
15
16 status <- reactiveValues(text = 'Waiting')
17
18 ## Disable download button
19 observe({
20 session$sendCustomMessage('disableButton', 'butDownload')
21 })
22
23 # reactivePoll - look for changes in log file every second
24 logData <- reactivePoll(1000, session,
25 checkFunc = function() {
26 if (file.exists(logfile))
27 file.info(logfile)$mtime[1]
28 else
29 ''
30 },
31 valueFunc = function() {
32 if (file.exists(logfile))
33 readLines(logfile)
34 else
35 ''
36 }
37 )
38
39 ## React to an update in the logfile
40 observe({
41 if (grepl('COMPLETED', logData())) {
42 session$sendCustomMessage('enableButton', 'butDownload')
43 session$sendCustomMessage('enableButton', 'butCreate')
44 status$text <- 'Completed'
45 }
46 })
47
48 ## Generate Excel output
49 ## Once button is pressed create an R Script and run as a second process
50 ## to avoid tying up Shiny
51 observeEvent(input$butCreate, {
52 session$sendCustomMessage('disableButton', 'butDownload')
53 session$sendCustomMessage('disableButton', 'butCreate')
54 status$text <- 'Building'
55
56 m <- matrix(rexp(input$numRows * input$numCols, rate = 0.1), ncol = input$numCols)
57
58 ## Write data to an rds file
59 saveRDS(m, file = datafile)
60
61 ## Create script file
62 vfile <- c('library(openxlsx)',
63 paste0('m <- readRDS(\"', datafile, '\")'),
64 'wb <- createWorkbook()',
65 'addWorksheet(wb, \"sheet1\")',
66 'writeData(wb, \"sheet1\", m)',
67 paste0('saveWorkbook(wb, \"', excelfile, '\", overwrite = TRUE)'),
68 paste0('fileConn <- file(\"', logfile, '\")'),
69 'writeLines(\"COMPLETED\", fileConn)',
70 'close(fileConn)'
71 )
72
73 ## Save script file
74 fileConn <- file(scriptfile)
75 writeLines(vfile, fileConn)
76 close(fileConn)
77
78 ## Execute script file
79 system(paste0(Sys.getenv('R_HOME'), '/bin/Rscript ', scriptfile), wait = FALSE)
80 })
81
82 output$butDownload <- downloadHandler(
83 filename <- function() {
84 'excel-out.xlsx'
85 },
86 content <- function(file) {
87 file.copy(excelfile, file)
88 }
89 )
90
91 output$uiStatus <- renderUI(
92 h4(paste0('STATUS: ', status$text), style="color:red;")
93 )
94
95 output$plt <- renderPlot({
96 hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks),
97 xlab = 'Duration (minutes)', main = 'Geyser eruption duration')
98 dens <- density(faithful$eruptions, adjust = input$bw_adjust)
99 lines(dens, col = 'blue')
100 })
101}
102
103ui <- fluidPage(
104 singleton(tags$head(HTML('
105 <script type="text/javascript">
106 $(document).ready(function() {
107 // Enable button
108 Shiny.addCustomMessageHandler("enableButton", function(id) {
109 $("#" + id).removeAttr("disabled");
110 });
111 // Disable button
112 Shiny.addCustomMessageHandler("disableButton", function(id) {
113 $("#" + id).attr("disabled", "true");
114 });
115 })
116 </script>
117 ')
118 )),
119 fluidRow(
120 column(4,
121 wellPanel(
122 fluidRow(
123 column(6, numericInput('numRows', 'Number of Rows', value = 100000, min = 1000, step = 1000)),
124 column(6, numericInput('numCols', 'Number of Columns', value = 50, min = 10, step = 10))
125 )
126 ),
127 fluidRow(
128 column(11, offset = 1,
129 actionButton('butCreate', 'Create Data', class = 'btn action-button btn-success'),
130 downloadButton('butDownload', 'Download Data', class = 'btn btn-warning'),
131 br(),
132 uiOutput('uiStatus')
133 )
134 )
135 ),
136 column(8,
137 wellPanel(
138 fluidRow(
139 column(4, selectInput('n_breaks', label = 'Number of bins:', choices = c(10, 20, 35, 50), selected = 20)),
140 column(4, sliderInput('bw_adjust', label = 'Bandwidth adjustment:', min = 0.2, max = 2, value = 1, step = 0.2))
141 )
142 ),
143 plotOutput('plt')
144 )
145 )
146 )
147
148shinyApp(ui = ui, server = server)