Concurrent `ExtendedTask`s

[mikkmart]

I’d like to use a single ExtendedTask object to launch multiple simulations to be executed in parallel, allowing the user to tweak parameters and launch new simulations while others are still running.

Here’s a toy example of the use-case, where currently simulation executions are enqueued:

library(shiny)
library(bslib)
library(mirai)

ui <- page_sidebar(
  sidebar = sidebar(
    sliderInput("mean", "Mean", -2, 2, 0),
    actionButton("simulate", "Simulate", class = "btn-primary")
  ),
  span("Simulations launched: ", textOutput("simulation_count", inline = TRUE)),
  verbatimTextOutput("results")
)

server <- function(input, output, session) {
  simulation <- ExtendedTask$new(function(m) {
    mirai({ Sys.sleep(runif(2)); rnorm(5, m) }, m = m)
  })

  observeEvent(input$simulate, {
    simulation$invoke(input$mean)
  })

  output$simulation_count <- renderText(input$simulate)

  results <- reactiveVal(list())
  observeEvent(simulation$result(), {
    result <- list(simulation$result())
    results(c(results(), result))
  })

  output$results <- renderPrint(str(results()))
}

shinyApp(ui, server)

[shikokuchuo]

I think by design Shiny ExtendedTask currently tries to avoid this: https://shiny.posit.co/r/articles/improve/nonblocking/#multiple-invocations

It's possible to work around by not using ExtendedTask, in the manner of: https://shikokuchuo.net/mirai/dev/articles/shiny.html#advanced-non-promise-example-generative-art for example.

The equivalent code is shown below. I've lengthened the sleeps and specified 2 daemons (persistent background processes) so you can see it more clearly - if you click a few times in succession, you'll see the results update 2 at a time.

library(shiny)
library(bslib)
library(mirai)

ui <- page_sidebar(
  sidebar = sidebar(
    sliderInput("mean", "Mean", -2, 2, 0),
    actionButton("simulate", "Simulate", class = "btn-primary")
  ),
  span("Simulations launched: ", textOutput("simulation_count", inline = TRUE)),
  verbatimTextOutput("results")
)

server <- function(input, output, session) {

  # a bit of boilerplate to set up a mirai queue
  q <- list()
  poll_for_results <- reactiveVal(FALSE)

  # each button click launches a mirai and adds it to the queue
  observeEvent(input$simulate, {
    q[[length(q) + 1L]] <<- mirai({ Sys.sleep(3); rnorm(5, m) }, m = input$mean)
    poll_for_results(TRUE)
  })

  output$simulation_count <- renderText(input$simulate)

  results <- reactiveVal(list())

  # if queue is not empty, check for results
  observe({
    req(poll_for_results())
    invalidateLater(millis = 100)
    if (length(q)) {
      if (!unresolved(q[[1L]])) {
        result <- list(q[[1L]][])
        results(c(results(), result))
        q[[1L]] <<- NULL
      }
    } else {
      poll_for_results(FALSE)
    }
  })

  output$results <- renderPrint(str(results()))
}

app <- shinyApp(ui, server)

with(daemons(2), runApp(app))

[jcheng5]

You can also achieve this by creating a single ExtendedTask per simulation. I didn't document this pattern as I was worried it would be too confusing, but it's proving to be useful in some of the apps we've built internally.

library(shiny)
library(bslib)
library(mirai)

ui <- page_sidebar(
  sidebar = sidebar(
    sliderInput("mean", "Mean", -2, 2, 0),
    actionButton("simulate", "Simulate", class = "btn-primary")
  ),
  span("Simulations launched: ", textOutput("simulation_count", inline = TRUE)),
  verbatimTextOutput("results")
)

server <- function(input, output, session) {
  observeEvent(input$simulate, {
    simulation <- ExtendedTask$new(function(m) {
      mirai({ Sys.sleep(5); rnorm(5, m) }, m = m)
    })

    simulation$invoke(input$mean)

    observeEvent(simulation$result(), {
      result <- list(simulation$result())
      results(c(results(), result))
    })
  })

  output$simulation_count <- renderText(input$simulate)

  results <- reactiveVal(list())

  output$results <- renderPrint(str(results()))
}

shinyApp(ui, server)

I know it's weird to see nested observeEvent like this, but when dynamically creating stuff like this I often use this pattern.

I trust that @shikokuchuo's solution will work as well, so maybe it's a matter of which one feels more intuitive to you.

[shikokuchuo]

Oh that's great! I'm all in favour of using ExtendedTask as they make use of the event-driven promises that we put together for mirai (and you @jcheng5 had a key role in designing).

Just a minimal modification to your example, but highlighting that as mirai() has a ... argument, it's even more convenient to use in the context of ExtendedTask. By defining the anonymous function with ..., these arguments are passed straight through, and then you just invoke it with named arguments (here m = input$mean).

library(shiny)
library(bslib)
library(mirai)

ui <- page_sidebar(
  sidebar = sidebar(
    sliderInput("mean", "Mean", -2, 2, 0),
    actionButton("simulate", "Simulate", class = "btn-primary")
  ),
  span("Simulations launched: ", textOutput("simulation_count", inline = TRUE)),
  verbatimTextOutput("results")
)

server <- function(input, output, session) {
  observeEvent(input$simulate, {
    simulation <- ExtendedTask$new(
      function(...) mirai({ Sys.sleep(5); rnorm(5, m) }, ...)
    )

    simulation$invoke(m = input$mean)

    observeEvent(simulation$result(), {
      result <- list(simulation$result())
      results(c(results(), result))
    })
  })

  output$simulation_count <- renderText(input$simulate)

  results <- reactiveVal(list())

  output$results <- renderPrint(str(results()))
}

shinyApp(ui, server)