How to not waiting on promise evaluation in R - r

I would like to execute a very expensive function (called 'never_ending_calc' in the below example) in a separate R session in a shiny app. I already prepared the below code, it works fine, but my parent R session waits on the result of the promise object and this uses lots of resources.
If you check the task manager while the below test application is running, you will see that the parent R session uses one CPU thread on maximum capacity while just simply waiting on the results of the promise object.
How can I evaluate a promise in a way which does not use the resources of the parent R session? (It is also ok if I loose the connection between these two sessions.)
I tried the followings (none of them worked):
use different 'plan'
send a custom message (like a warning) from function 'never_ending_calc' on its first row to somehow stop the parent session to wait on the promise object
Here is the example:
library(shiny)
library(future)
library(promises)
library(future.callr)
never_ending_calc <- function(){
K = 1
for (i in 1:20){
K = K + i
Sys.sleep(5)
}
return(K)
}
ui <- fluidPage(
# App title ----
titlePanel("Test app"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel ----
sidebarPanel(
# action button to start the long test calculation ----
actionButton(inputId = "start_test",
label = "Start test run")
),
mainPanel()
)
)
server <- function(input, output) {
observeEvent(input$start_test, {
# start execute the long calculation in another separate R session
future::plan(future.callr::callr)
long_calculation_future <<- future::future({
never_ending_calc()
})
promises::then(long_calculation_future,
onFulfilled = NULL,
onRejected = function(error){NULL})
future::plan(future::sequential)
# return NULL to keep the shiny app reactive
NULL
})
}
shinyApp(ui, server)

Related

Using js shiny events in Cypress

I need to use Javascript shiny events (e.g. shiny:recalculated) described here https://shiny.rstudio.com/articles/js-events.html to know when to trigger next frontend test action (without sleeps). This makes tests deterministic and reduces testing time.
However, I cannot use the event from Cypress nor from slave browser developer console.
Consider e.g. simple code taken from https://github.com/rstudio/shiny-examples/blob/master/084-single-file/app.R and modified to run app in browser
# Global variables can go here
n <- 200
# Define the UI
ui <- bootstrapPage(
numericInput('n', 'Number of obs', n),
plotOutput('plot')
)
# Define the server code
server <- function(input, output) {
output$plot <- renderPlot({
hist(runif(input$n))
})
}
# Return a Shiny app object
shinyApp(ui = ui, server = server, options = list(launch.browser = TRUE))
After executing
$(document).on('shiny:recalculated', function (event) {
if (event.target.id === "plot") {
alert('Output has been just refreshed')
}
})
in browser developer console and modifying input (to 201) I get
However, that's not the case in case of browser runned by Cypress. Any ideas why?

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)

Async process blocking R Shiny app

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.

How to present an output without waiting for the rest of the script to run in R Shiny

I have a Shiny app that should calculate a value, present it and then use the same value for further more expensive computation. The problem is that it shows me the output only after it finishes evaluating the whole script. Here is a simple example:
library(shiny)
ui <- fluidPage(
titlePanel("test"),
sidebarLayout(
sidebarPanel(
textInput("text_in","Enter text here",value = "This is text to process"),
actionButton("go", "Go")
),
mainPanel(
textOutput("first_text"),
textOutput("results")
)
)
)
# Define server logic
server <- function(input, output) {
num_letter<-eventReactive(input$go, {
nchar(input$text_in)})
output$first_text <- renderText(num_letter())
sec_calculation<-eventReactive(num_letter(), {
Sys.sleep(3)
num_letter()*num_letter()})
output$first_text <- renderText(num_letter())
output$results <- renderText(sec_calculation())
}
# Run the application
shinyApp(ui = ui, server = server)
I added the Sys.sleep so it will be easier to see the problem. I would like to get the first output without waiting for the second one.
This is not currently possible (at least not with native shiny code - you can always hack a workaround). An open issue for this exists on the shiny github repository: https://github.com/rstudio/shiny/issues/1705

Pattern for triggering a series of Shiny actions

I'm having trouble creating a sequence of events in a Shiny app. I know there are other ways of handling parts of this issue (with JS), and also different Shiny functions I could use to a similar end (e.g. withProgress), but I'd like to understand how to make this work with reactivity.
The flow I hope to achieve is as follows:
1) user clicks action button, which causes A) a time-consuming calculation to begin and B) a simple statement to print to the UI letting the user know the calculation has begun
2) once calculation returns a value, trigger another update to the previous text output alerting the user the calculation is complete
I've experimented with using the action button to update the text value, and setting an observer on that value to begin the calculation (so that 1B runs before 1A), to ensure that the message isn't only displayed in the UI once the calculation is complete, but haven't gotten anything to work. Here is my latest attempt:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("run", "Pull Data")
mainPanel(
textOutput("status")
)
)
)
server <- function(input, output, session) {
# slow function for demonstration purposes...
test.function <- function() {
for(i in seq(5)) {
print(i)
Sys.sleep(i)
}
data.frame(a=c(1,2,3))
}
report <- reactiveValues(
status = NULL,
data = NULL
)
observeEvent(input$run, {
report$status <- "Pulling data..."
})
observeEvent(report$status == "Pulling data...", {
report$data <- test.function()
})
observeEvent(is.data.frame(report$data), {
report$status <- "Data pull complete"
}
)
observe({
output$status <- renderText({report$status})
})
}
Eventually, I hope to build this into a longer cycle of calculation + user input, so I'm hoping to find a good pattern of observers + reactive elements to handle this kind of ongoing interaction. Any help is appreciated!

Resources