Trouble with advanced Shiny app used in crew examples

[wlandau]

In the high-throughput coin flip example from the documentation of crew version 0.9.3, many of the coin flip results are missed. I managed to reproduce this with a version of the app that runs with mirai directly and not crew.

It doesn't happen every time, but sometimes the app hangs with not all tasks completed:

App code:

library(mirai)
library(shiny)

flip_coin <- function() {
  Sys.sleep(0.1)
  rbinom(n = 1, size = 1, prob = 0.501)
}

ui <- fluidPage(
  div("Is the coin fair?"),
  actionButton("task", "Flip 1000 coins"),
  textOutput("status"),
  textOutput("outcomes")
)

server <- function(input, output, session) {
  # mirai setup
  daemons(n = 10)
  onStop(function() daemons(n = 0))
  
  # Keep running totals of heads, tails, and task errors.
  flips <- reactiveValues(heads = 0, tails = 0, flips = 0)
  
  # Create an extended task to invalidate 
  cue <- ExtendedTask$new(func = identity)
  
  # List of mirai tasks
  tasks <- new.env(parent = emptyenv())
  tasks$tasks <- list()
  
  # Button to submit a batch of coin flips.
  observeEvent(input$task, {
    flips$flips <- flips$flips + 1000
    for (task in seq_len(1000)) {
      task <- mirai(flip_coin(), flip_coin = flip_coin)
      tasks$tasks <- c(tasks$tasks, task)
      cue$invoke(task)
    }
  })
  
  # Print time and task status.
  output$status <- renderText({
    input$task
    cue$status()
    invalidateLater(millis = 1000)
    time <- format(Sys.time(), "%H:%M:%S")
    sprintf("%s %s flips submitted", time, flips$flips)
  })
  
  # Print number of heads and tails.
  output$outcomes <- renderText(
    sprintf("%s heads %s tails", flips$heads, flips$tails)
  )
  
  # Observe new flips.
  observe({
    cue$result() # invalidates the observe()
    invalidateLater(1000)
    new_flip <- NULL
    for (index in seq_along(tasks$tasks)) {
      task <- tasks$tasks[[index]]
      if (!unresolved(task)) {
        new_flip <- task$data
        tasks$tasks[[index]] <- NULL
        break
      }
    }
    req(new_flip)
    flips$heads <- flips$heads + new_flip
    flips$tails <- flips$tails + (1 - new_flip)
  })
}

shinyApp(ui = ui, server = server)

[shikokuchuo]

This is an ordinary number of workers, and the throughput is quite low due to the delay you've put in.

I know that the promises/later integration is rock solid due to the million promises challenge, which is real high throughput. If you also encounter an issue there let me know: https://shikokuchuo.net/mirai/articles/promises.html#the-one-million-promises-challenge (actually increase the number in the example to 1e6 + you'll need to ensure enough RAM to run it).

I've tested on multiple machines, and no matter if I increase the flips per click to 10,000 and/or reduce the sleep time to zero, this isn't reproducible for me.

This example also doesn't use Shiny ExtendedTask in the usual way - I wonder if it's because the mirai is launched independently of the promise creation.

When you say 'hang', what do you mean exactly, does the clock still tick, but the counter stops increasing?

Also when you encounter this, is it always on the first click after starting the app? If it works on the first click, can you get this to occur on subsequent clicks? This is an important point as to whether it is some sort of state / initialization issue.

Also does this occur with versions 1.0.0 of nanoext/mirai or only more recent builds?

[wlandau]

I'm starting to think it's a Shiny or extended task issue. In the modified app below, the app still hangs sometimes (tasks counts stay the same, clock keeps ticking) but the print statements show that the mirai tasks are resolving. Somehow, the observe() block stops running, even though I put in an extra invalidateLater().

I'm not sure I could reproduce this without mirai because I would need future.promises and there is a lot more overhead there.

All I think I can do on my end is migrate crew away from ExtendedTask integration for the purposes of documentation and our upcoming conferences.

library(shiny)

flip_coin <- function() {
  Sys.sleep(0.1)
  rbinom(n = 1, size = 1, prob = 0.501)
}

ui <- fluidPage(
  div("Is the coin fair?"),
  actionButton("button", "Flip 1000 coins"),
  textOutput("results")
)

server <- function(input, output, session) {
  # Set up mirai daemons
  mirai::daemons(n = 10)
  onStop(\() mirai::daemons(n = 0))
  
  # Keep running totals of heads, tails, and total flips.
  flips <- reactiveValues(heads = 0, tails = 0, total = 0)
  
  # Create an extended task to invalidate reactive expressions.
  extended_task <- ExtendedTask$new(func = identity)
  
  # List of mirai tasks
  tasks <- new.env(parent = emptyenv())
  tasks$tasks <- list()
  
  
  # button to submit a batch of coin flips
  observeEvent(input$button, {
    flips$flips <- flips$flips + 1000
    for (task in seq_len(1000)) {
      task <- mirai::mirai(flip_coin(), flip_coin = flip_coin)
      tasks$tasks <- c(tasks$tasks, task)
      extended_task$invoke(task)
    }
  })
  
  # Print time and flip counts.
  output$results <- renderText({
    invalidateLater(millis = 500)
    pattern <- "%s | %s heads %s tails %s total"
    time <- format(Sys.time(), "%H:%M:%S")
    
    print(length(tasks$tasks))
    print(sum(unlist(lapply(tasks$tasks, mirai::unresolved))))
    print("")
    
    sprintf(pattern, time, flips$heads, flips$tails, flips$total)
  })
  
  # Observe new flips.
  observe({
    extended_task$result()
    invalidateLater(millis = 500)
    new_flip <- NULL
    for (index in seq_along(tasks$tasks)) {
      task <- tasks$tasks[[index]]
      if (!mirai::unresolved(task)) {
        new_flip <- task$data
        tasks$tasks[[index]] <- NULL
        break
      }
    }
    req(new_flip)
    flips$heads <- flips$heads + new_flip
    flips$tails <- flips$tails + 1 - new_flip
    flips$total <- flips$total + 1
  })
}

shinyApp(ui = ui, server = server)

[shikokuchuo]

The above works perfectly for me as well, both the text in the app as well as the print statements to the console.

The below is an alternative I quickly hacked together using mirai_map() that doesn't use ExtendedTask (note: I don't think it's an issue with ExtendedTask, but possibly the non-standard way it is being used, with the additional observe). It may not be the best way to do things, but minimally modifies your original example.

library(mirai)
library(shiny)

flip_coin <- function(...) {
  Sys.sleep(0.1)
  rbinom(n = 1, size = 1, prob = 0.501)
}

ui <- fluidPage(
  div("Is the coin fair?"),
  actionButton("task", "Flip 1000 coins"),
  textOutput("status"),
  textOutput("outcomes")
)

server <- function(input, output, session) {
  # mirai setup
  daemons(n = 10)
  onStop(function() daemons(n = 0))
  
  # Keep running totals of heads, tails, and task errors.
  flips <- reactiveValues(heads = 0, tails = 0, flips = 0)

  # List of mirai tasks
  n <- 0L
  
  # Button to submit a batch of coin flips.
  observeEvent(input$task, {
    flips$flips <- flips$flips + 1000
    m <- mirai_map(1:1000, flip_coin, flip_coin = flip_coin, .promise = function(x) {
      if (x) flips$heads <- flips$heads + 1 else flips$tails <- flips$tails + 1
      n <<- n + 1L
      if (n == 1000) n <<- 0L
    })
  })
  
  # Print time and task status.
  output$status <- renderText({
    input$task
    invalidateLater(millis = 1000)
    time <- format(Sys.time(), "%H:%M:%S")
    sprintf("%s %s flips submitted", time, flips$flips)
  })
  
  # Print number of heads and tails.
  output$outcomes <- renderText(
    sprintf("%s heads %s tails", flips$heads, flips$tails)
  )

}

shinyApp(ui = ui, server = server)

I think this at least shouldn't suffer from the issue you seem to be encountering.

[wlandau]

That's really nice! I updated the crew Shiny vignette to avoid extended tasks, and the promises-powered version now works perfectly on my end. To me that proves the issue is something to do with extended tasks, which is a moot point now that this promises-only pattern already has everything I need.

[shikokuchuo]

Fantastic! Much smoother operation using promises.

[shikokuchuo]

@wlandau would you try your original reprex on the current build of mirai (1.1.1.9019)? I could never get the issue to reproduce in the first place, but recent updates may have fixed usage in this context. EDIT: to be clear I've not made any changes specifically for this.

[wlandau]

Just tested locally, and the coin flips stop here (while the clock, workers, and dispatcher keeps running):

[shikokuchuo]

Ok never mind. I've been doing some stress-testing on different patterns and all well so far - the one million promises challenge comes in at under 6 mins now on my laptop! Needless to say, the coin flip example is working here on Linux.

[shikokuchuo]

Just had a thought - could it be something to do with how the binaries are built for Mac, if you're downloading binaries instead of building from source? Could be either nanonext/NNG or later causing the oddity.

[wlandau]

I compiled the dev pkg from the source.