Related
The scenario I'm emulating with the below minimal example is allowing a user to engage with a Shiny App (click the numericInput control and see server-side events occur) while a long-running download is occurring (simulated with Sys.sleep(10) within downloadHandler).
In a synchronous setting, when the "Download" button is clicked, the user can still interact with UI elements, but other Shiny calculations (in this case, renderText), get put in a queue. I'd like the asynchronous setting, where the download occurs in the background, and users can still interact with the UI elements and get desired output (e.g. renderText).
I'm using callr::r_bg() to achieve asynchronicity within Shiny, but the issue is that my current code of the downloadHandler is incorrect (mtcars should be getting downloaded, but the code is unable to complete the download, 404 error message), I believe it's due to the specific way in which downloadHandler expects the content() function to be written, and the way I've written callr::r_bg() is not playing nicely with that. Any insights would be appreciated!
Reference:
https://www.r-bloggers.com/2020/04/asynchronous-background-execution-in-shiny-using-callr/
Minimal Example:
library(shiny)
ui <- fluidPage(
downloadButton("download", "Download"),
numericInput("count",
NULL,
1,
step = 1),
textOutput("text")
)
server <- function(input, output, session) {
long_download <- function(file) {
Sys.sleep(10)
write.csv(mtcars, file)
}
output$download <- downloadHandler(
filename = "data.csv",
content = function(file) {
x <- callr::r_bg(
func = long_download,
args = list(file)
)
return(x)
}
)
observeEvent(input$count, {
output$text <- renderText({
paste(input$count)
})
})
}
shinyApp(ui, server)
I figured out a solution, and learned the following things:
Because downloadHandler doesn't have a traditional input$X, it can be difficult to include reactivity in the traditional way. The workaround was to present the UI as a hidden downlodButton masked by an actionButton which the user would see. Reactivity was facilitated in the following process: user clicks actionButton -> reactive updates -> when the reactive finishes (reactive()$is_alive() == FALSE), use shinyjs::click to initiate the downloadHandler
Instead of placing the callr function within the downloadHandler, I kept the file within the content arg. There seems to be some difficulties with scoping because the file needs to be available within the content function environment
I'm using a reactive function to track when the background job (the long-running computation) is finished to initiate the download using the syntax: reactive()$is_alive()
The invalidateLater() and toggling of a global variable (download_once) is important to prevent the reactive from constantly activating. Without it, what will happen is your browser will continually download files ad infinitum -- this behavior is scary and will appear virus-like to your Shiny app users!
Note that setting global variables is not a best practice for Shiny apps (will think of a better implementation)
Code Solution:
library(shiny)
library(callr)
library(shinyjs)
ui <- fluidPage(
shinyjs::useShinyjs(),
#creating a hidden download button, since callr requires an input$,
#but downloadButton does not natively have an input$
actionButton("start", "Start Long Download", icon = icon("download")),
downloadButton("download", "Download", style = "visibility:hidden;"),
p("You can still interact with app during computation"),
numericInput("count",
NULL,
1,
step = 1),
textOutput("text"),
textOutput("did_it_work")
)
long_job <- function() {
Sys.sleep(5)
}
server <- function(input, output, session) {
#start async task which waits 5 sec then virtually clicks download
long_run <- eventReactive(input$start, {
#r_bg by default sets env of function to .GlobalEnv
x <- callr::r_bg(
func = long_job,
supervise = TRUE
)
return(x)
})
#desired output = download of mtcars file
output$download <- downloadHandler(filename = "test.csv",
content = function(file) {
write.csv(mtcars, file)
})
#output that's meant to let user know they can still interact with app
output$text <- renderText({
paste(input$count)
})
download_once <- TRUE
#output that tracks progress of background task
check <- reactive({
invalidateLater(millis = 1000, session = session)
if (long_run()$is_alive()) {
x <- "Job running in background"
} else {
x <- "Async job in background completed"
if(isTRUE(download_once)) {
shinyjs::click("download")
download_once <<- FALSE
}
invalidateLater(millis = 1, session = session)
}
return(x)
})
output$did_it_work <- renderText({
check()
})
}
shinyApp(ui, server)
Thanks #latlio for your great answer. I think it cloud be easily improved.
invalidateLater should be used very carefully and only WHEN needed. I use invalidateLater only once and moved it to the logical part where we are waiting for the result. Thus we are NOT invalidating the reactivity infinitely.
library(shiny)
library(callr)
library(shinyjs)
ui <- fluidPage(
shinyjs::useShinyjs(),
#creating a hidden download button, since callr requires an input$,
#but downloadButton does not natively have an input$
actionButton("start", "Start Long Download", icon = icon("download")),
downloadButton("download", "Download", style = "visibility:hidden;"),
p("You can still interact with app during computation"),
numericInput("count",
NULL,
1,
step = 1),
textOutput("text"),
textOutput("did_it_work")
)
long_job <- function() {
Sys.sleep(5)
}
server <- function(input, output, session) {
#start async task which waits 5 sec then virtually clicks download
long_run <- eventReactive(input$start, {
#r_bg by default sets env of function to .GlobalEnv
x <- callr::r_bg(
func = long_job,
supervise = TRUE
)
return(x)
})
#desired output = download of mtcars file
output$download <- downloadHandler(filename = "test.csv",
content = function(file) {
write.csv(mtcars, file)
})
#output that's meant to let user know they can still interact with app
output$text <- renderText({
paste(input$count)
})
#output that tracks progress of background task
check <- reactive({
if (long_run()$is_alive()) {
x <- "Job running in background"
invalidateLater(millis = 1000, session = session)
} else {
x <- "Async job in background completed"
shinyjs::click("download")
}
return(x)
})
output$did_it_work <- renderText({
check()
})
}
shinyApp(ui, server)
To reproduce :
library(shiny)
library(DT)
testdf<-c("car1",sample(1:1000,1),sample(1:10,1),sample(1:10,1),sample(1:10,1))
testdf<-rbind(testdf,c("car2",sample(1:1000,1),sample(1:10,1),sample(1:10,1),sample(1:10,1)))
testdf<-data.frame(testdf)
shinyApp(
ui = fluidPage(
tabPanel("tab1",dataTableOutput("datatable")),
actionButton("CheckFile", "Refresh data")
),
server = function(input, output, session) {
X = testdf
output$datatable = renderDataTable(
{X},selection = list(mode = 'single',target = 'cell')
)
observeEvent(input$CheckFile, {
tryCatch(eval(testdf[nrow(testdf)+1,]<-c(sample(row.names(mtcars),1),sample(1:1000,1),sample(1:10,1),sample(1:10,1),sample(1:10,1))))
#same with evaluate function
#evaluate(testdf[nrow(testdf)+1,]<-c(sample(row.names(mtcars),1),sample(1:1000,1),sample(1:10,1),sample(1:10,1),sample(1:10,1)))
removeModal()
showModal(modalDialog(
title="Refresh done",
footer=NULL,
easyClose=T
))
})
}
)
My app is rendering a table. I want to give the user the possibility to update this dataset with an actionButton(). It then calls an other R file that update this dataset with source(). However, this script may contain some errors and stops before the end. So I chose to handle errors with tryCatch() and eval(). The problem is that these two functions inside my shiny app avoid the update of the dataset.
I made this reproducible example to illustrate the problem.
When I'm only running this line the dataset is updated:
tryCatch(eval(testdf[nrow(testdf)+1,]<-c(sample(row.names(mtcars),1),sample(1:1000,1),sample(1:10,1),sample(1:10,1),sample(1:10,1))))
But in the app, it is not the case.
Any idea?
Thanks in advance.
I am trying to make Shiny App which allows users to save inputs and later load them.
Easiest way to approach this, is to make Save button, which saves inputs. Here is basic app to demonstrate:
server.R
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("integer", "Integer:",
min = 0, max = 1000,
value = 500)
),
mainPanel(tableOutput("values"),
actionButton('save_inputs', 'Save inputs')
)
))
server <- function(input, output, session) {
sliderValues <- reactive({
value = input$integer
})
output$values <- renderTable({
sliderValues()
})
observeEvent(input$save_inputs,{
saveRDS( input$integer , file = 'integer.RDS')
})
}
shinyApp(ui = ui, server = server)
However, I would like to make saving automatic, e.g. I want inputs to be saved at end of session. onSessionEnded() should be answer to this, but it can't reach input values and save them.
session$onSessionEnded( function() {
saveRDS( input$integer, file = 'integer.RDS')
})
Which returns error: Warning:
Error in .getReactiveEnvironment()$currentContext: Operation not
allowed without an active reactive context. (You tried to do something
that can only be done from inside a reactive expression or observer.)
Is there any way to solve it?
Using isolate seems to solve the problem.
session$onSessionEnded(function() {
isolate(saveRDS( input$integer, file = 'integer.RDS'))
})
Using another observe event function and watching the value of isClosed() we can
make this work
observeEvent(session$isClosed()==T,{
saveRDS( input$integer, file = 'integer.RDS')
})
observeEvent() as well as reactive() are both considered "reactive" environments which means they are watching for changing values throughout the session and not just on startup. If you put a function that needs to be reactive outside of a reactive environment shiny will do you the favor of sending you that error, to inform you the function would never be called unless we wrap it in a reactive function.
Also +1 for the well composed question.
It should be possible to use the R packages future and promises to trigger asynchronous (long running) processing via Shiny apps without freezing the rest of the app while the async process is running in another R process.
See:
https://cran.r-project.org/web/packages/promises/vignettes/intro.html
https://cran.r-project.org/web/packages/promises/vignettes/overview.html
https://cran.r-project.org/web/packages/promises/vignettes/futures.html
https://cran.r-project.org/web/packages/promises/vignettes/shiny.html
I got this to work in R-script-based environment but can't get this to work when I implement a simple shiny app with 2 functions. The "not-async" function is always blocked while the async function is running, but that should not be the case.
I have posted the same question on the GitHub repo of the package promises: https://github.com/rstudio/promises/issues/23
I am posting it here as well hoping someone can help.
The question is:
Can you take a look at the shiny app example posted below and let me know why the async processing is blocking the app? (It should not block).
Ideally, can you provide a small example of an app with a non-blocking async and normal functionality (accessible while the async is running)?
Environment
Mac OS 10.12
$ R --version
R version 3.4.3 (2017-11-30) -- "Kite-Eating Tree"
remove.packages("future")
remove.packages("promises")
remove.packages("shiny")
install.packages("future")
install.packages("devtools")
devtools::install_github("rstudio/promises")
devtools::install_github("rstudio/shiny")
> packageVersion("future")
[1] ‘1.8.1’
> packageVersion("promises")
[1] ‘1.0.1’
> packageVersion("shiny")
[1] ‘1.0.5.9000’
One side question on the shiny package version, https://rstudio.github.io/promises/articles/intro.html says it should be >=1.1, but even installing with devtools, the version remains 1.0.5... . Is this an issue or is there a typo in the doc?
First, you can use promises with Shiny outputs. If you’re using an async-compatible version of Shiny (version >=1.1), all of the built-in renderXXX functions can deal with either regular values or promises.
Example of issue
I have implemented this simple shiny app inspired from the example at the URLs mentioned above.
The shiny app has 2 "sections":
A button to trigger the "long running" async processing. This is simulated by a function read_csv_async which sleeps for a few seconds, reads a csv file into a data frame. The df is then rendered below the button.
A simple functionality which should work at any time (including when the async processing has been triggered): it includes a slider defining a number of random values to be generated. We then render a histogram of these values.
The issue is that the second functionality (histogram plot update) is blocked while the async processing is occurring.
global.R
library("shiny")
library("promises")
library("dplyr")
library("future")
# path containing all files, including ui.R and server.R
setwd("/path/to/my/shiny/app/dir")
plan(multiprocess)
# A function to simulate a long running process
read_csv_async = function(sleep, path){
log_path = "./mylog.log"
pid = Sys.getpid()
write(x = paste(format(Sys.time(), "%Y-%m-%d %H:%M:%OS"), "pid:", pid, "Async process started"), file = log_path, append = TRUE)
Sys.sleep(sleep)
df = read.csv(path)
write(x = paste(format(Sys.time(), "%Y-%m-%d %H:%M:%OS"), "pid:", pid, "Async process work completed\n"), file = log_path, append = TRUE)
df
}
ui.R
fluidPage(
actionButton(inputId = "submit_and_retrieve", label = "Submit short async analysis"),
br(),
br(),
tableOutput("user_content"),
br(),
br(),
br(),
hr(),
sliderInput(inputId = "hist_slider_val",
label = "Histogram slider",
value = 25,
min = 1,
max = 100),
plotOutput("userHist")
)
server.R
function(input, output){
# When button is clicked
# load csv asynchronously and render table
data_promise = eventReactive(input$submit_and_retrieve, {
future({ read_csv_async(10, "./data.csv") })
})
output$user_content <- renderTable({
data_promise() %...>% head(5)
})
# Render a new histogram
# every time the slider is moved
output$userHist = renderPlot({
hist(rnorm(input$hist_slider_val))
})
}
data.csv
Column1,Column2
foo,2
bar,5
baz,0
Thanks!
So this behavior is normal, see the response of the package developer at https://github.com/rstudio/promises/issues/23
Summary:
In shiny apps, one R process can be shared by multiple users.
If one user submits a long running task, then all the other users sharing the same underlying R process are blocked.
The goal of promises is to avoid this. So promises will prevent blocking between "user sessions" within one R process but not within a single "user session".
The author of the package mentioned that this feature is not supported yet and that it may be added if enough people ask for it. If you are looking for this, please go the GitHub issue and like the original question - this is how interest for new features is measured.
Thanks!
As this or similar questions about shiny intra-session responsiveness are frequently asked on stackoverflow I think it's worth mentioning the workaround Joe Cheng provides in the GitHub issue #Raphvanns created:
If you really must have this kind of behavior, there is a way to work
around it. You can "hide" the async operation from the Shiny session
(allowing the session to move on with its event loop) by not returning
your promise chain from your observer/reactive code. Essentially the
async operation becomes a "fire and forget". You need to hook up a
promise handler to have some side effect; in the example below, I set
a reactiveVal on successful completion.
Some caveats to this approach:
By doing this you are inherently opening yourself up to race
conditions. Even in this very simple example, the user can click the
Submit button multiple times; if the long-running task has very
variable runtime you might end up with multiple results coming back,
but out of order. Or if you reference input values in promise
handlers, they might pick up values that were set after the submit
button was clicked!
You also lose the automatic semi-transparent
indication that an output has been invalidated (though below I at
least null the reactiveVal out in the beginning of the observeEvent).
Accordingly the solution for the above example code can be something like this:
library("shiny")
library("promises")
library("dplyr")
library("future")
# path containing all files, including ui.R and server.R
# setwd("/path/to/my/shiny/app/dir")
write.csv(data.frame(stringsAsFactors=FALSE,
Column1 = c("foo", "bar", "baz"),
Column2 = c(2, 5, 0)
), file = "./data.csv")
onStop(function() {
file.remove("./data.csv")
})
plan(multiprocess)
# A function to simulate a long running process
read_csv_async = function(sleep, path){
log_path = "./mylog.log"
pid = Sys.getpid()
write(x = paste(format(Sys.time(), "%Y-%m-%d %H:%M:%OS"), "pid:", pid, "Async process started"), file = log_path, append = TRUE)
Sys.sleep(sleep)
df = read.csv(path)
write(x = paste(format(Sys.time(), "%Y-%m-%d %H:%M:%OS"), "pid:", pid, "Async process work completed\n"), file = log_path, append = TRUE)
df
}
ui <- fluidPage(
textOutput("parallel"),
sliderInput(inputId = "hist_slider_val",
label = "Histogram slider",
value = 25,
min = 1,
max = 100),
plotOutput("userHist"),
actionButton(inputId = "submit_and_retrieve", label = "Submit short async analysis"),
tableOutput("user_content")
)
server <- function(input, output, session) {
data_promise <- reactiveVal()
# When button is clicked
# load csv asynchronously and render table
observeEvent(input$submit_and_retrieve, {
future({ read_csv_async(10, "./data.csv") }) %...>% data_promise()
return(NULL) # hide future
})
output$user_content <- renderTable({
req(data_promise())
head(data_promise(), 5)
})
# Render a new histogram
# every time the slider is moved
output$userHist = renderPlot({
hist(rnorm(input$hist_slider_val))
})
output$parallel <- renderText({
invalidateLater(300)
paste("Something running in parallel:", Sys.time())
})
}
shinyApp(ui = ui, server = server)
Note the return(NULL) in the observeEvent call to hide the future. This way the long running process no longer blocks the execution of the other reactives.
I am having a lot of trouble getting a search filtering module working.
I am to run stats on a large database of cat owner information.
I want my search module to bring up a list of possible owners(that the user can select from) based on a selection from a list of cat breeds.
I thought wrapping the updateSelectInput with observe and using a reactive cat owner expression would facilitate this, in the module, but it is not working( and I can't guess why this is happening or how to debug this). It worked in these other posts([1]:R shiny passing reactive to selectInput choices , [2]:using values from a reactive input to directly input into a custom function)
Why won't my selectInput update with cat owners?
library(shiny)
df=data.frame(
cat=c("tabby","DSH","MSH","LSH","DSH","MSH","LSH","sphinx"),
owner=c("Foo","Bar","Bash","Foo","Foo","Foo","Bar","Bash"),stringsAsFactors = F)
refinedSearch<-function(input, output, session){
ownsCat<-reactive({df[df$cat%in%input$cat,"owner"]})
observe({updateSelectInput(session, "ownerSelected",
label ="Owned By",choices = ownsCat())})
return()
}
refinedSearchUI<-function(id){
ns <- NS(id)
fluidRow(
column(4,selectInput(ns("cat"),"Cat",selectize = T,
choices =c("tabby","DSH","MSH","LSH","sphinx") )),
column(4,selectInput(ns("ownerSelected"),"Owned By","",selectize = T))
)
}
ui <- fluidPage(
h1("Find cats owners"),
fluidRow(column(10,offset=1, refinedSearchUI("tmp"))),
fluidRow(column(10,offset=1, actionButton("addFilter","Add a Filter",
icon = icon("plus"))))
)
server <- function(input, output,session) {
refinedSearch(input,output,session)
observeEvent(input$add, {insertUI(selector = "#addFilter",where = "beforeBegin",
ui = refinedSearch(input,output,session))})
}
shinyApp(ui = ui, server = server)
Thank y'all for you time.
There seems to be quite a bit of confusion on how to call modules. You need to use the callModule() function in the server. Also, when inserting UI (using the insertUI()function), you need to call the refinedSearchUI() function, not the refinedSearch() function (which, again, should always be called through callModule(), so it should never actually get called directly like that).
I'd recommend a re-reading of the modules article.
You also have a typo. The event in your observeEvent() function should be input$addFilter, not input$add (which doesn't exist, so that observer is never fired..)
If you change your server function to this, your app will work as expected:
server <- function(input, output,session) {
callModule(refinedSearch, "tmp")
observeEvent(input$addFilter, {
id <- paste0("filter_", input$add)
insertUI(selector = "#addFilter",where = "beforeBegin",
ui = refinedSearchUI(id))
callModule(refinedSearch, id)
})
}