Async: Display progress when actionButton is hit and disable other operations for the same user but allow concurrent users
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.
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 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. Ideally the progress bar functionality should we used with multiple actionButtons.
I read the blogs about async but unable to put right code in the right place. any help is appreciated with a bounty!!
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)
Here is a solution based on the (absolutely under-star-ed) library(ipc).
I came across this library due to a question of @Dean Attali, where Joe Cheng mentioned it.
The quick-start guide of the ipc-package gives an example of what you are asking for: AsyncProgress.
Furthermore it provides an example on how to kill a future using AsyncInterruptor.
However, I haven't been able to test it yet.
I worked around the cancel-problem by using @Dean Attali's great package shinyjs to simply start a new session and ignore the old Future (You might be able to improve this, by using AsyncInterruptor).
But nevertheless, I gave your code a Future, dropped your system() cmd because I'm currently running R on Windows and found a way to disable (tribute to @Dean Attali) the analyze button session-wise by giving it session-dependant names:
library(shiny)
library(shinydashboard)
library(ipc)
library(promises)
library(future)
library(shinyjs)
library(datasets)
library(V8)
plan(multiprocess)
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(),
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]],{
session$reload()
})
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)
App running:
- Math.Sin() gives incorrect value
- How to run my python script when the sunOS is start booting
- Express-session: not resetting cookie expiration on each request
- Getting a stack overflow exception when normalizing a vector
- Edit default summary function in R gives error for multiple variables
- What was a For loop? Why isn't it needed in R?
- How to use download button in shiny and save results in various formats (csv, texte, pdf, spss...)?
- Why are there two assignment operators, `<-` and `->` in R?
- lm()$assign: what is it?
- How to get the value of list(...) in R and S functions
- Design matrix for MLM from library(lme4) with fixed and random effects
- how to generate elements not included in my sample
- Create a matrix with gradually changing values without a for loop
- Emacs ESS and S-plus ( S+ ) 8.1 compatability
- How to lag date-index in a time-series in R?
- Nonlinear regression in R / S
- Calling R from S-Plus?