How to set up an independent progress bar - r

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

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.

Answer 3

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?