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)

Answer 2

Thanks to the answer of @GyD, I now propose an improved solution (that has something of a hack I admit). The long computation is simulated here by a sys.sleep of the desired duration. You see that there is still slider movement during the 'sleep'. I put the animated slider into a RenderUI so we can control the speed:

library(shiny); library(shinyjs); library(shinyWidgets)
jscode <- "
shinyjs.play = function() {
$('.slider-animate-button').trigger('click');
}
"
ui <- fluidPage(
     tags$head(tags$style(HTML('.irs-from, .irs-to, .irs-min, .irs-max, .irs-grid-text, .irs-grid-pol, .irs-slider {visibility:hidden !important;}'))),
     useShinyjs(), extendShinyjs(text = jscode),
     numericInput("seconds", "how many seconds your calculation will last?", value=6),
     uiOutput("UI"),
     actionButton("go", "Compute"))
server <- function(input, output,session) {
     disable("slider")
     observeEvent(input$go, priority=10, {
          js$play()
          Sys.sleep(input$seconds) # simulate computation
          showNotification("Computation finished!", type="error")})
     output$UI = renderUI({
          sliderInput("slider", label = "", width = '300px',min = 0,max = 100,value = 0,step = 1,
                      post="% done",
                      animate = animationOptions(
                           interval = (as.numeric(input$seconds)*8),
                           playButton = "",
                           pauseButton = ""))})}
shinyApp(ui, server)

The slider really looks like a bar, doesn't it?

Answer 3

Not a complete answer, since my suggestion would be to use progress bars, but I hope it helps a bit.

Here's a way to trigger clicking a slider animate button using some javascript with the shinyjs package:

library(shiny)
library(shinyjs)

jscode <- "
  shinyjs.play = function() {
    $('.slider-animate-button').trigger('click');
  }
"

ui <- fluidPage(
  useShinyjs(),
  extendShinyjs(text = jscode),
  sliderInput("slider", label = "", width = '600px',
              min = 0,
              max = 20,
              value = 0,
              step = 1,
              animate = animationOptions(
                interval = 100,
                playButton = "Play",
                pauseButton = "Pause"
              )
  )
)

server <- function(input, output,session) {
  observe( {
    js$play()
  })
}

shinyApp(ui, server)

Please note that the js code references the slider-animate-button class, so it will trigger every slider animation option in the app.