How to set up an independent progress bar

Question

I'm trying to include a progress bar during the computations in my shiny application. Description of my problem:

• My computation takes a while, like 30 seconds
• I'm able to evaluate in advance the exact time a computation will take
• however, the computation is in one chunk, not splitable in small parts that I could use to manually increment the progress bar, think of it as a large model fitting process.

Currently there are some questions related to the problem but no satisfying answer: here, here for instance.

Is there a way to implement an bar that progresses on top of a calculation, independently and continuously, for a fixed amount of time (or maybe insert an animation of the bar in a pop-up that mimics the bar?)

Thanks

Edit: I tried to mimic a progress bar with an animated sliderInput, but I couldn't find how programmatically trigger the animation...

Answer 1

I think this would be a lot easier when Shiny releases its async support. But for now, it'd have to be a custom, client-side JavaScript solution.

My take on it uses the same Bootstrap 3 progress bars that Shiny uses. Out of laziness, I also leveraged Shiny's progress bar CSS classes (top bar style), so this will conflict with Shiny's progress bars. Ideally it'd be a widget with its own styles.

I used jQuery's animate to set the width of the progress bar over a fixed duration. animate has some nice options out of the box like easing. I also let the progress bar linger after 100% by default, thinking it'd be better for the server to explicitly close the progress bar in case the timing isn't exact.

library(shiny)

progressBarTimer <- function(top = TRUE) {
  progressBar <- div(
    class = "progress progress-striped active",
    # disable Bootstrap's transitions so we can use jQuery.animate
    div(class = "progress-bar", style = "-webkit-transition: none !important;
              transition: none !important;")
  )

  containerClass <- "progress-timer-container"

  if (top) {
    progressBar <- div(class = "shiny-progress", progressBar)
    containerClass <- paste(containerClass, "shiny-progress-container")
  }

  tagList(
    tags$head(
      tags$script(HTML("
        $(function() {
          Shiny.addCustomMessageHandler('progress-timer-start', function(message) {
            var $progress = $('.progress-timer-container');
            var $bar = $progress.find('.progress-bar');
            $bar.css('width', '0%');
            $progress.show();
            $bar.animate({ width: '100%' }, {
              duration: message.duration,
              easing: message.easing,
              complete: function() {
                if (message.autoClose) $progress.fadeOut();
              }
            });
          });

          Shiny.addCustomMessageHandler('progress-timer-close', function(message) {
            var $progress = $('.progress-timer-container');
            $progress.fadeOut();
          });
        });
      "))
    ),

    div(class = containerClass, style = "display: none;", progressBar)
  )
}

startProgressTimer <- function(durationMsecs = 2000, easing = c("swing", "linear"),
                               autoClose = FALSE, session = getDefaultReactiveDomain()) {
  easing <- match.arg(easing)
  session$sendCustomMessage("progress-timer-start", list(
    duration = durationMsecs,
    easing = easing,
    autoClose = autoClose
  ))
}

closeProgressTimer <- function(session = getDefaultReactiveDomain()) {
  session$sendCustomMessage("progress-timer-close", list())
}

ui <- fluidPage(
  numericInput("seconds", "how many seconds your calculation will last?", value = 6),
  progressBarTimer(top = TRUE),
  actionButton("go", "Compute")
)

server <- function(input, output, session) {
  observeEvent(input$go, {
    startProgressTimer(input$seconds * 1000, easing = "swing")
    Sys.sleep(input$seconds) # simulate computation
    closeProgressTimer()
    showNotification("Computation finished!", type = "error")
  })
}

shinyApp(ui, server)