Update computation flag status

[olivier6088]

I'd like to update a computation status flag.

Basically this flag should have 4 states {NULL when starting the app, "running" when pushing START button, "queue" when waiting the end of the previous computation, "done" when the computation is done}.

I've made a few lines of code to illustrate the behaviour but of course it does not work as expected.

library(shiny)

ui <- shinyUI(fluidPage(
  titlePanel("Test update computation status flag"),
  sidebarLayout(
    sidebarPanel(
      fluidRow(
        column(8,
               "Status:",
               textOutput("status1")
        ),
        column(4,
               "Box1"
        )
      ),
      hr(),
      fluidRow(
        column(8,
               "Status:",
               textOutput("status2")
        ),
        column(4,
               "Box2"
        )
      ),
      hr(),
      fluidRow(align = "center",
               actionButton("startButton", "START")
      )
    ),
    mainPanel()
  )
))

server <- shinyServer(function(input, output, session) {
  cal1 <- reactiveVal(NULL)
  cal2 <- reactiveVal(NULL)
  stat1 <- reactiveVal(NULL)
  stat2 <- reactiveVal(NULL)
  observeEvent(input$startButton, {
    stat1("running")
    stat2("queue")
    Sys.sleep(2)
    cal1(1)
  })
  observeEvent(!is.null(cal1()), {
    stat1("done")
    stat2("running")
    Sys.sleep(2)
    cal2(2)
  })
  observeEvent(!is.null(cal2()), {
    stat2("done")
  })
  output$status1 <- renderText(stat1())
})

shinyApp(ui = ui, server = server)

Thanks for any help

[cpsievert]

Hi @olivier6088, if you have long running computations, you may want to leverage shiny's new asynchronous programming support which allows you to perform these expensive computations in a background process, and thus, free up your main shiny-server R process to do other things while those expensive computation(s) run. In this context, your queue notification may no longer relevant/informative, since you could use this infrastructure to instantly spin-off multiple jobs.

Getting started with async is difficult, but it may be worth your trouble

Abstractions for Promise-Based Asynchronous Programming

A relevant challenge that async introduces is communication between the background thread(s) and the main R shiny-server process, which is needed if you need to do something like update a progress bar for the computation running in the background thread. The ipc package process some nice tools for this, though:

https://cran.r-project.org/web/packages/ipc/vignettes/shinymp.html

[olivier6088]

Hi @cpsievert, I was thinking about asynchronous programming and you gave me confirmation. Thank you.

[olivier6088]

Here is a code solution:

library(shiny)
library(ipc)
library(future)
plan(multiprocess)

calc <- function(i) {
  Sys.sleep(i * 2)
}

ui <- shinyUI(fluidPage(
  titlePanel("Test update computation status flag"),
  sidebarLayout(
    sidebarPanel(
      fluidRow(
        column(8,
               "Status:",
               textOutput("status1")
        ),
        column(4,
               "Box1"
        )
      ),
      hr(),
      fluidRow(
        column(8,
               "Status:",
               textOutput("status2")
        ),
        column(4,
               "Box2"
        )
      ),
      hr(),
      fluidRow(align = "center",
               actionButton("startButton", "START")
      )
    ),
    mainPanel()
  )
))

server <- shinyServer(function(input, output, session) {
  
  queue <- shinyQueue()
  queue$consumer$start(100) # Execute signals every 100 milliseconds
  
  stat1 <- reactiveVal(NULL)
  stat2 <- reactiveVal(NULL)
  
  observeEvent(input$startButton, {
    future({
      for(i in 1:2) {
        queue$producer$fireAssignReactive(paste0("stat",i), "queue")
      }
      for(i in 1:2) {
        queue$producer$fireAssignReactive(paste0("stat",i), "running")
        calc(i)
        queue$producer$fireAssignReactive(paste0("stat",i), "done")
      }
    })
    #Return something other than the future so we don't block the UI
    NULL
  })
  output$status1 <- renderText(stat1())
  output$status2 <- renderText(stat2())
})

shinyApp(ui = ui, server = server)