I've got a nested call to future_lapply that processes in parallel. It works great and fast!
The problem is that reporting on progress in sequence within Shiny is proving difficult. The following Shiny app has a progress indicator that instead of incrementing like 1,2,3, etc. increments out of order like 1, 5, 2, etc.
Any ideas on how to report progress in order (even if the processing is down out of order)? A simple counter increment doesn't work (increment <- 0; increment <- increment + 1) because of scoping rules.
Switching to plan(multisession) increments in order as expected, but that removes the parallel processing.
library(shiny)
library(future)
library(future.apply)
library(ipc)
library(callr)
plan(list(callr, tweak(multisession, workers = availableCores() -1)))
ui <- fluidPage(
actionButton("run","Run"),
tableOutput("dataset")
)
server <- function(input, output, session) {
dat <- reactiveVal()
observeEvent(input$run, {
progress <- AsyncProgress$new(session, min=1, max=15)
future({
future.apply::future_lapply(1:15, function(i){
progress$set(value = i, message = paste("Iteration:",i))
Sys.sleep(0.5)
})
progress$close()
cars
}) %...>% dat
NULL
})
output$dataset <- renderTable({
req(dat())
})
}
shinyApp(ui, server)
}
Related
How can R(Shiny) perform multiple tasks at the same time?
For example have a "clock" or timer in your UI which keeps on ticking while having an another "ObserveEvent" trigger/calculation running?
See the following example in Shiny below. When you press "click", the clock freezes since R starts focussing on the for loop.
ui <- fluidPage(
h2(textOutput("currentTime")),
actionButton("click","click")
)
server <- function(input, output, session) {
output$currentTime <- renderText({
invalidateLater(1000, session)
paste("The current time is", Sys.time())
})
observeEvent(input$click,{
showNotification("Computation started!", type = "error")
#Sys.sleep(2)
for(i in 1:(8*10^7)) 1 + 1
showNotification("Computation finished!", type = "error")
})
}
# Create Shiny app ----
shinyApp(ui, server)
I'm new to Shiny and have hit a problem I can't find an answer for. Basically, I have a Shiny app that does some long calculations in a loop and I want it to output a "progress report" every few iterations. However, even though I reassign my reactive variable within the loop, the output doesn't update until the loop (or entire function?) has finished.
Here is a simplified test case of what I mean:
library(shiny)
# Basic interface
ui <- fluidPage(
actionButton("run", "Run"),
textOutput("textbox")
)
# Basic server with loop
server <- function(input, output) {
textvals=reactiveValues(a=0)
observeEvent(input$run, {
for(i in 1:10){
textvals$a=i # Expect output to update here, but doesn't
Sys.sleep(0.1) # Slight pause so isn't instantaneous
}
})
output$textbox <- renderText({
textvals$a
})
}
# Run the application
shinyApp(ui = ui, server = server)
What I would expect is that the display would update 1, 2, 3, ... 10 as the loop executes. Instead, it just jumps straight from 0 to 10. How can I force an update partway through the loop?
Thank you.
With using invalidateLater you can get something closed to what you want. Not the shortest way to do it I think, but it may help you to find a better solution.
library(shiny)
# Basic interface
ui <- fluidPage(
actionButton("run", "Run"),
textOutput("textbox")
)
# Basic server with loop
server <- function(input, output, session) {
textvals <- reactiveVal(0)
active <- reactiveVal(FALSE)
output$textbox <- renderText({
textvals()
})
observe({
invalidateLater(1000, session)
isolate({
if (active()) {
textvals(textvals() + 1)
if (textvals() > 9) {
active(FALSE)
}
}
})
})
observeEvent(input$run, {
active(TRUE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
By the way, reactive and for loops don't really get on well. This may help : https://gist.github.com/bborgesr/e1ce7305f914f9ca762c69509dda632e
When I want to render multiple outputs linked to a single observer, they are rendered after both outputs are calculated. If there is a long calculation between the outputs it takes a long time before all outputs are displayed.
Is it possible in a Shiny application to render outputs, linked to a single observer, individually or in parallel? Instead of waiting with rendering until all outputs are calculated.
Example
library(shiny)
ui <- fluidPage(
actionButton('button', 'klik'),
textOutput('first'),
textOutput('second')
)
server <- function(input, output, session) {
observeEvent({input$button},{
output$first <- renderText({Sys.Date()})
Sys.sleep(10)
output$second <- renderText({Sys.Date()})
})
}
shinyApp(ui, server)
Thanks to #BertilBaron I found out a way to avoid waiting for long calculations in R-Shiny. The article that I used can be found here.
Basically what you do is to run each process in parallel using the package future. With this package every time the user clicks on the button the calculation will be performed. So keep in mind that you have to build in a block for impatient users.
My working example
library(shiny)
library(promises)
library(future)
plan(multiprocess)
ui <- fluidPage(
actionButton('button', 'klik'),
textOutput('first'),
textOutput('second')
)
server <- function(input, output) {
nclicks <- reactiveVal(0)
nclicks2 <- reactiveVal(0)
result_val <- reactiveVal()
result_val2 <- reactiveVal()
observeEvent(input$button,{
# Don't do anything if analysis is already being run
if(nclicks() != 0 | nclicks2() != 0){
showNotification("Already running analysis")
return(NULL)
}
# Increment clicks and prevent concurrent analyses
nclicks(nclicks() + 1)
nclicks2(nclicks2() + 1)
result <- future({
# Long Running Task
Sys.sleep(10)
#Some results
Sys.time()
}) %...>% result_val()
result2 <- future({
#Some results
Sys.time()
}) %...>% result_val2()
# Catch inturrupt (or any other error) and notify user
result <- catch(result,
function(e){
result_val(NULL)
print(e$message)
showNotification(e$message)
})
result2 <- catch(result2,
function(e){
result_val2(NULL)
print(e$message)
showNotification(e$message)
})
# After the promise has been evaluated set nclicks to 0 to allow for anlother Run
result <- finally(result,
function(){
nclicks(0)
})
result2 <- finally(result2,
function(){
nclicks2(0)
})
# Return something other than the promise so shiny remains responsive
NULL
})
output$first <- renderText({
req(result_val())
})
output$second <- renderText({
req(result_val2())
})
}
# Run the application
shinyApp(ui = ui, server = server)
My shiny app does clustering using %dopar% from doParallel library. There is one thing that bothers me: if an operation takes, for example, 10 minutes to calculate, but user closes the window of an app before it's done - calculations will continue to happen until they're finished.
What I'm trying to do is to force stop them on session end. I tried to do something like this
session$onSessionEnded(function() {
stopCluster(clu)
print("stopped")
})
to stop calculations on window closure, but it is evaluated after the calculations are done. Here is a test app i'm trying to get it to work on:
server.r
library(shiny)
library(doParallel)
shinyServer(function(input, output, session) {
wd <- getwd()
rv <- reactiveValues()
clu <- makeCluster(2)
registerDoParallel(clu)
observeEvent(input$loadDataButton, {
rv$listDF <- readRDS(paste0(wd, "/iris15k.RData"))
})
observeEvent(input$clusterButton, {
if (input$clusterButton >= 1) {
df <- rv$listDF
rv$resultTime <- system.time(
rv$r <- foreach(icount(100)) %dopar% {
table <- kmeans(as.data.frame(df), centers = 3)
}
)
}
})
observeEvent(rv$listDF, {
output$done <- renderText("Done loading!")
})
observeEvent(rv$resultTime, {
output$time <- renderText(c("Done caltulating, time:", rv$resultTime))
print(rv$resultTime)
})
session$onSessionEnded(function() {
stopCluster(clu)
print("stopped")
})
})
ui.r
library(shiny)
shinyUI(fluidPage(
actionButton(
inputId = "loadDataButton",
label = "load data"
),
actionButton(
inputId = "clusterButton",
label = "Do clustering"
),
textOutput("done"),
textOutput("time")
))
iris15k.RData is a simple iris dataset with replicated rows to make the operation longer.
There is a way to write a bash script that will do the job and kill the processes in very straight way, but I'd rather do it from R side as I know little of it and it seems to be right to get it work withing an app code.
Any suggestions?
I want to keep reflashing until 10:05, after 10:05 I got the tplus0_dt and stop to processing invalidaterLater().
Before 10:00, tplus0_dt doesn't exist, so I need to keep reflashing until 10:05. After 10:05, it is no need to refalsh, and when the tplus0_dt becomes very lage the invalidaterLater() will effects the displaying of table1, the screen and plots go GRAY every 1 seconds so it looks like the page is dead while the updating occurs.
So how can I do to stop processing the invalidateLater() and keep showing the data after 10:05? Thanks for help! My example code were below.
require(shiny)
require(data.table)
app <- shinyApp(
server = function(input, output, session){
get_tplus0_data <- reactive({
time <- substr(as.character(Sys.time()), 12, 16)
invalidateLater(1000)
if(time >= "10:05"){
# tplus0_dt<-data.table(read.csv("/data/df_highest_after_signal.csv",header = T, sep = ",", stringsAsFactors = F))
tplus0_dt<- data.table(a = c(1, 2, 3, 4), b = c(3, 4, 5, 8))
return(tplus0_dt)
}
})
output$table1 <- renderTable({get_tplus0_data()})
},
ui = fluidPage( tableOutput("table1") )
)
runApp(app)
Although you'd never realize it from the Shiny documentation, invalidateLater() actually only returns to your reactive once. The reason it seems to return repeatedly is that on each trip the invalidateLater() function gets run again.
So the solution is to use a conditional around the function so that you don't keep repeatedly calling it:
if(runMeAgain) {
invalidateLater(n)
}
runMeAgain = TRUE # your reactive re-runs every n milliseconds
runMeAgain = FALSE # your reactive does not re-run
Also note that:
invalidateLater() is non-blocking (other code can run while you
wait)
invalidateLater() doesn't stop the rest of the reactive from
running. If you want to stop the reactive at that point in the code, put a return() after invalidateLater()
invalidateLater() gets isolated() inside an observeEvent() or eventReactive() and consequently doesn't work; you have to use observe() or reactive(). It might also work inside a render function, but I haven't ever had a reason to try that.
In terms of the original question, the reactive should look like this:
get_tplus0_data <- reactive({
time <- substr(as.character(Sys.time()), 12, 16)
if(time >= "10:05"){
tplus0_dt<- data.table(a = c(1, 2, 3, 4), b = c(3, 4, 5, 8))
return(tplus0_dt)
} else {
invalidateLater(1000)
return()
}
})
How about you override the function to your needs?
If you enter invalidateLaterNew in the console, the code of the function will be printed.
To overwrite a function within a package this post will help: Override a function that is imported in a namespace
Then you will have to consider that the functions .getReactiveEnvironment() and timerCallbacks() are not accessible outside the namespace. But you can call them like this: shiny:::.getReactiveEnvironment()
Bring it together:
You add an additional parameter (e.g. update), which will enable you to stop the invalideLater() whenever you want.
invalidateLaterNew <- function (millis, session = getDefaultReactiveDomain(), update = TRUE)
{
if(update){
ctx <- shiny:::.getReactiveEnvironment()$currentContext()
shiny:::timerCallbacks$schedule(millis, function() {
if (!is.null(session) && session$isClosed()) {
return(invisible())
}
ctx$invalidate()
})
invisible()
}
}
unlockBinding("invalidateLater", as.environment("package:shiny"))
assign("invalidateLater", invalidateLaterNew, "package:shiny")
Example:
I used the example given in ?invalidateLater to demonstrate the effect:
(invalidateLater will stop when input$nis bigger than 800. So you can adapt this example to your time restriction).
I decided not to use your time restriction example as it wouldnt be that handy to test ;)
ui <- fluidPage(
sliderInput("n", "Number of observations", 2, 1000, 500),
plotOutput("plot")
)
server <- function(input, output, session) {
observe({
# Re-execute this reactive expression after 1000 milliseconds
invalidateLater(1000, session, input$n < 800)
# Do something each time this is invalidated.
# The isolate() makes this observer _not_ get invalidated and re-executed
# when input$n changes.
print(paste("The value of input$n is", isolate(input$n)))
})
# Generate a new histogram at timed intervals, but not when
# input$n changes.
output$plot <- renderPlot({
# Re-execute this reactive expression after 2000 milliseconds
invalidateLater(2000, session, input$n < 800)
hist(rnorm(isolate(input$n)))
})
}
shinyApp(ui, server)