Shiny promises future is not working on eventReactive - r

I have an inputButton than when you click it, 2 querys to mysql database are done. One is a heavy one (more than 10 secs) and the other is light (less than 0.01sec to get data).
As I want to show the result of this querys on shiny app, I have intendeed to use Promises and Future packages for asyncronous loading.
In the example that I show you of my code, I have simulated the SQL querys with the function heavyFunction, which is intended to simulate the heavy query and the ligth one time loads.
The issue is that this code is not working for me, because the results of the light query are not shown till the heavy query is done.
Note: In the Rstudio console, this code works perfect...
library(future)
library(promises)
plan(multiprocess)
heavyFunction <- function(n){
Sys.sleep(n)
print(n)
}
ui <- fluidPage(
actionButton("go","Show the data"),
textOutput("result0sec"),
textOutput("result10sec")
)
server <- function(input,output,session){
data0 <- eventReactive(input$go,{
heavyFunction(0)
})
data10 <- eventReactive(input$go,{
heavyFunction(10)
})
output$result0sec <- renderText({
data <- data0()
future(data)%...>%print()
})
output$result10sec <- renderText({
data <- data10()
print(data)
})
}
shinyApp(ui,server)
What I'm doing wrong?

Welcome to SO!
This thread discusses the same issue.
Please also see the detailed answer from Joe Cheng on GitHub.
The main problem you are experiencing is reflected by his following statement:
The goal, at least for this release of Shiny, is not to allow this
kind of intra-session responsiveness, but rather, inter-session; i.e.,
running an async operation won't make its owning session more
responsive, but rather will allow other sessions to be more
responsive.
However, there are ways to work around this behaviour by running the future in a background R process with e.g. library(callr) or more convenient library(future.callr) and it's plan(callr).
Here is a working version of your code:
library(future)
library(promises)
library(future.callr)
plan(callr)
heavyFunction <- function(n) {
Sys.sleep(n)
print(n)
}
ui <- fluidPage(
br(),
actionButton("go", "Show the data"),
br(), br(),
textOutput("result0sec"),
textOutput("result10sec")
)
server <- function(input, output, session) {
futureData <- reactiveValues(data10 = NULL)
data0 <- eventReactive(input$go, {
heavyFunction(0)
})
observeEvent(input$go, {
myFuture <- future({
heavyFunction(5)
})
then(
myFuture,
onFulfilled = function(value) {
futureData$data10 <<- value
},
onRejected = NULL
)
return(NULL)
})
output$result0sec <- renderText({
data0()
})
output$result10sec <- renderText({
req(futureData$data10)
})
}
shinyApp(ui, server)
The most important point here is to realize, that you shouldn't return your future directly, otherwise it will block all other actions - the observer returns nothing, it only has the side-effect of triggering the callback-function.

Related

How to use callr::r_bg within a downloadHandler in a Shiny App

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)

Using standard R shiny progress bar in parallel foreach calculations

I am trying to use the standard R shiny progress bar in a parallel foreach loop using the doParallel back-end. However, this results in the following error message:
Warning: Error in {: task 1 failed - "'session' is not a ShinySession object."
Code (minimum working example)
library(shiny)
library(doParallel)
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch calculation")
)
server <- function(input, output, session) {
workers=makeCluster(2)
registerDoParallel(workers)
observeEvent(input$go, {
Runs=c(1:4)
Test_out=foreach(i=Runs, .combine=cbind, .inorder=TRUE, .packages=c("shiny"),.export=c("session")) %dopar% {
pbShiny = shiny::Progress$new()
pbShiny <- Progress$new(session,min = 0, max = 10)
on.exit(pbShiny$close())
test_vec=rep(0,100)
for(i in 1:10){
test_vec=test_vec+rnorm(100)
pbShiny$set(message="Simulating",detail=paste(i),
value=i)
Sys.sleep(0.2)
}
}
})
}
shinyApp(ui = ui, server = server)
The code runs if I run the foreach loop sequentially (using registerDoSEQ()).
Does anyone know how to resolve this issue?
Overall Goal
Show progress to user in a parallel foreach loop using the doParallel
back-end in shiny
User should be aware of the number of workers and
the progress per worker and or overall progress
There is a similar question under the following link, but it didn't get resolved as no working example was provided:
Utilizing parallel foreach for progress bar in R Shiny
The doParallel package is an extension of the parallel package as shown in the documentation here.
https://cran.r-project.org/web/packages/doParallel/doParallel.pdf
Reading the parallel package's documentation we see that it implements 3 different methods to achieve parallelism. Keep in mind R is a single threaded language.
A new R session where the parent process communicates with a worker or child process.
Via Forking
Using OS level facilities
You can find this information here,
https://stat.ethz.ch/R-manual/R-devel/library/parallel/doc/parallel.pdf
A consequence of this is that the child process cannot communicate with the parent process until it completes its computation and returns a value. This is to the best of my knowledge.
Hence, ticking the progress bar within the worker process will not be possible.
Full disclosure, I have not worked with the doParallel package and the documentation with respect to shiny was limited.
Alternative solution
There is a similar package however with extensive documentation with respect to shiny. These are the futures and promises and ipc packages. futures and promises enable asynchronous programming while ipc enables interprocess communication. To help us even more it also has an AsyncProgress() function.
Here is an example where we tick two counters synchronously.
Example
library(shiny)
library(future)
library(promises)
library(ipc)
plan(multisession)
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch calculation")
)
server <- function(input, output, session) {
observeEvent(input$go, {
progress = AsyncProgress$new(message="Complex analysis")
future({
for (i in 1:15) {
progress$inc(1/15)
Sys.sleep(0.5)
}
progress$close()
return(i)
})%...>%
cat(.,"\n")
Sys.sleep(1)
progress2 = AsyncProgress$new(message="Complex analysis")
future({
for (i in 1:5) {
progress2$inc(1/5)
Sys.sleep(0.5)
}
progress2$close()
return(i)
})%...>%
cat(.,"\n")
NULL
})
}
shinyApp(ui = ui, server = server)
Your code adapted
Here is the code you have written, slightly modified to spin off many asynchronous processes. Any work can be performed in the worker, such as the vector you create and add an rnorm too. (Not shown here)
library(shiny)
library(future)
library(promises)
library(ipc)
plan(multisession)
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch calculation")
)
server <- function(input, output, session) {
observeEvent(input$go, {
Runs=c(1:4) #define the number of runs
progress = list() #A list to maintain progress for each run
for(j in Runs){
progress[[j]] = AsyncProgress$new(message="Complex analysis")
future({
for (i in 1:10) {
progress[[j]]$inc(1/10)
Sys.sleep(0.2)
}
progress[[j]]$close()
return(i)
})%...>%
cat(.,'\n')
}
NULL
})
}
shinyApp(ui = ui, server = server)
The code above is a modified version of the code found in the ipc documentation here:
http://htmlpreview.github.io/?https://github.com/fellstat/ipc/blob/master/inst/doc/shinymp.html
Additional Resources:
https://rstudio.github.io/promises/articles/overview.html
I think I found a solution for cases where the number of runs exceeds the number of cores.
I searched for nested future processes and found the following page:
https://cran.r-project.org/web/packages/future/vignettes/future-3-topologies.html
I changed my code as follows. This runs the jobs sequentially per core and updates the respective progress bars accordingly.
library(shiny)
library(future)
library(promises)
library(ipc)
library(listenv)
plan(list(multiprocess, sequential))
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch calculation")
)
server <- function(input, output, session) {
observeEvent(input$go, {
x <- listenv()
Runs=12 #define the number of runs
N=availableCores()
Tasks=rep(0,N) #Number of sequential tasks per core
Tasks[1:(Runs-(ceiling(Runs/N)-1)*N)]=ceiling(Runs/N)
if((Runs-(ceiling(Runs/N)-1)*N)<N){
Tasks[(Runs-(ceiling(Runs/N)-1)*N+1):N]=ceiling(Runs/N)-1
}
progress = list() #A list to maintain progress for each run
for(j in 1:N){
for(l in 1:Tasks[j]){
progress[[(l-1)*N+j]] = AsyncProgress$new(message=paste("Complex analysis, core ",j," , task ",l))
}
x[[j]]%<-%{
for(l in 1:Tasks[j]){
for (i in 1:10) {
progress[[(l-1)*N+j]]$inc(1/10)
Sys.sleep(0.5)
}
progress[[(l-1)*N+j]]$close()
}
}
}
NULL
})
}
shinyApp(ui = ui, server = server)

R shiny: printing the console output produced by an R package to UI

I am using an R package that, in addition to calculating and returning things, prints some very useful info to the console. For example, it prints what iteration it is on right now.
How could I print that console output directly to my UI?
Assume this is my UI:
ui <- shinyUI(
fluidPage(
titlePanel("Print consol output"),
sidebarLayout(
sidebarPanel(actionButton("go", "Go")),
mainPanel(
verbatimTextOutput("console_text")
)
)
)
)
My user clicks on actionButton “Go” and my package starts doing things - while sending stuff to the console at the same time. I guess, I want the content of the console to be saved as output$console_text - but I don’t know if that’s the right approach and how to do it.
I didn't want to make the code super-complicated. So, instead of a package, I created my own little printing function in Server.
server <- function(input, output, session) {
myfunction <- function(x) {
for(i in 1:x) cat(i)
return(x)
}
observeEvent(input$go, {
{
# This is probably wrong:
output$console_text <- renderPrint(onerun <- myfunction(20))
}
})
}
shinyApp(ui, server)
Thank you very much!

Generating dynamic number of datatables without rerendering

I am wondering what the best practice is for handling a dynamic number of datatables. Here is a toy example:
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
mainPanel(
sliderInput("number","Number of tables",1,10,1,1),
uiOutput("tables")
)))
server <- shinyServer(function(input, output, session) {
observe({
lapply(seq_len(input$number), function(i) {
output[[paste0("table",i)]] <- DT::renderDataTable(head(mtcars))
})
})
output$tables <- renderUI({
lapply(seq_len(input$number), function(i) {
DT::dataTableOutput(paste0("table",i))
})
})
})
# Run the application
shinyApp(ui = ui, server = server)
This approach is sort of a blunt tool, because you have to rerender all the datatables, whenever a single datatable is added or removed.
Is there a better approach to dynamically generating output that doesn't require creating all the output in a loop, and therefore recreating all the output each time there is a change?
I'm the author of insertUI and removeUI. It seems like you found a bug in insertUI when applied to interactive outputs. I filed an issue for this in the Shiny repo and will try to get to it soon. In the meantime, a workaround is to use where = "beforeBegin" instead of where = "beforeEnd" in the call to insertUI(). See my answer to the original issue filed in the DT repo for more details.
[Edit] Answer has been updated with the workaround from #Bárbara Borges (see her answer for details on why it works)
Here is an example, but note that it is working for normal tables (no refresh), but for datatables, there is no refresh when removing tables but always refreshing when adding tables. I think this is something caused by DT but haven't found the real cause yet. I am posting in the hope that someone can improve this.
library(shiny)
library(DT)
numUI <- 0
ui <- shinyUI(fluidPage(
mainPanel(
sliderInput("number","Number of tables",1,10,1,1),
tags$div(id="tables")
)))
server <- shinyServer(function(input, output, session) {
observe({
if (input$number > numUI) {
for (num in (numUI+1):input$number) {
insertUI("#tables", "beforeBegin", DT::dataTableOutput(paste0("table", num)))
output[[paste0("table",num)]] <- DT::renderDataTable(head(mtcars), server = FALSE)
}
}
if (input$number < numUI) {
for (num in (input$number+1):numUI) {
removeUI(paste0("#table", num))
}
}
numUI <<- input$number
})
})
# Run the application
shinyApp(ui = ui, server = server)

Possible to show console messages (written with `message`) in a shiny ui?

I don't understand R's message vs cat vs print vs etc. too deeply, but I'm wondering if it's possible to capture messages and show them in a shiny app?
Example: the following app can capture cat statements (and print statements as well) but not message statements
runApp(shinyApp(
ui = fluidPage(
textOutput("test")
),
server = function(input,output, session) {
output$test <- renderPrint({
cat("test cat")
message("test message")
})
}
))
Cross post from the shiny-discuss Google group since I got 0 answers.
Yihui suggested I use withCallingHandlers, and that indeed let me to a solution. I wasn't quite sure how to use that function in a way that would do exactly what I needed because my problem was that I had a function that printed out several messages one at a time and using a naive approach only printed the last message. Here is the my first attempt (which works if you only have one message to show):
foo <- function() {
message("one")
message("two")
}
runApp(shinyApp(
ui = fluidPage(
actionButton("btn","Click me"),
textOutput("text")
),
server = function(input,output, session) {
observeEvent(input$btn, {
withCallingHandlers(
foo(),
message = function(m) output$text <- renderPrint(m$message)
)
})
}
))
Notice how only two\n gets outputted. So my final solution was to use the html function from shinyjs package (disclaimer: I wrote that package), which lets me change or append to the HTML inside an element. It worked perfectly - now both messages got printed out in real-time.
foo <- function() {
message("one")
Sys.sleep(0.5)
message("two")
}
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
actionButton("btn","Click me"),
textOutput("text")
),
server = function(input,output, session) {
observeEvent(input$btn, {
withCallingHandlers({
shinyjs::html("text", "")
foo()
},
message = function(m) {
shinyjs::html(id = "text", html = m$message, add = TRUE)
})
})
}
))
I know this isn't nearly as elegant, but I worked around a bit similar problem using capture.output; sadly sink doesn't allow simultaneous capture of messages and output though. You don't get them in the original order, but you can extract both streams at least (here turned to HTML):
runApp(shinyApp(
ui = fluidPage(
uiOutput("test")
),
server = function(input,output, session) {
output$test <- renderUI({
HTML(
paste(capture.output(type = "message", expr = {
message(capture.output(type = "output", expr = {
cat("test cat<br>")
message("test message")
cat("test cat2<br>")
message("test message2")
}))
}), collapse="<br>")
)})
})
)
Output:
test message
test message2
test cat
test cat2
Perhaps in the case if user wants to capture both but also separate them, this will provide a handy work-around. (Your shinyjs package seems neat, need to take a look at it!)
This can now be done with the high-level function shinyCatch from the spsComps package.
Basic usage
library(shiny)
library(spsComps)
ui <- fluidPage(
actionButton("msg", "msg"),
actionButton("warn", "warn"),
actionButton("err", "err"),
)
server <- function(input, output, session) {
observeEvent(input$msg, {
shinyCatch({message("a message")}, prefix = '')
})
observeEvent(input$warn, {
shinyCatch({warning("a warning")}, prefix = '')
})
observeEvent(input$err, {
shinyCatch({stop("an error")}, prefix = '')
})
}
shinyApp(ui, server)
Choose blocking level
If exceptions happened, we can choose to continue the code or block downstream code in the reactive context. For example, we want to stop downstream code if an error/warning/message happens:
library(shiny)
library(spsComps)
ui <- fluidPage(
actionButton("err", "code not blocked after error"),
actionButton("err_block", "code blocked after error"),
)
server <- function(input, output, session) {
observeEvent(input$err, {
shinyCatch({stop("an error")}, prefix = '')
print("error does not block ")
})
observeEvent(input$err_block, {
shinyCatch({stop("an error")}, prefix = '', blocking_level = "error")
print("you can't see me if error happens")
})
}
shinyApp(ui, server)
More advanced use
check website and demo
cat and print
There is still no good method to catch real-time info from cat and print. I will come back to update this answer if I found a fix for this.

Resources