Forcing updates to htmlOutput within a long running function - r

Question

I have a Shiny application that runs a long process and I would like to alert the user that the process is actually running. In the example below, I have a toggle switch that executes a block of code with a 1 second delay (my actual application runs for about 20 seconds), and I have an HTMLoutput box that should let the user know something is happening. But, since the underlying bootstrap process only updates the UI elements after the function exits, users only see the last message, "Done".
I've seen other questions like this one with answers that suggest creating a reactive value and then wrapping the renderUI() function in an observe() function (here, for example), but this has the same problem.
I also tried wrapping the htmlOutput() in withSpinner() from the shinycssloaders package, but I get an error saying "missing value where TRUE/FALSE needed". I assume this is coming from shinydashboardPlus because it doesn't like the withspinner() output in the tagList() elements. I was hopeful that this would at least give me an animated spinner on the HTMLoutput indicating that it is running.
Any input on getting this specific setup to work or alternatives to give users some feedback that the process is active is greatly appreciated.
library(shiny)
library(shinycssloaders)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
# Define UI for application that draws a histogram
ui <- dashboardPage(skin = 'blue',
shinydashboardPlus::dashboardHeader(title = 'Example',
leftUi = tagList(
switchInput(inputId = 'swtLabels', label = 'Labels', value = TRUE,
onLabel = 'Label 1', offLabel = 'Label 2',
onStatus = 'info', offStatus = 'info', size = 'mini',
handleWidth = 230),
htmlOutput(outputId = 'labelMessage')
#withSpinner(htmlOutput(outputId = 'labelMessage')) # leads to error noted in text
)
),
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output) {
rv <- reactiveValues()
rv$labelMessage <- 'Start'
observeEvent(input$swtLabels, {
rv$labelMessage <- 'Updating labels...'
Sys.sleep(1)
rv$labelMessage <- 'Done'
})
output$labelMessage <- renderUI(HTML(rv$labelMessage))
}
# Run the application
shinyApp(ui = ui, server = server)

Answer 1

I found a workaround for this using the shinyjs package, code below. The take home message is that by using shinjs::html(), the effect on the htmlOutput is immediate. I even added a fancy fade out at the end to hide the message.
It does create yet another package dependency, but it solves the problem. I'm sure there is a way that one could write a small JavaScript function and add it to the Shiny application to accomplish this same result. Unfortunately, I don't know JavaScript. (References for including JS code in a Shiny app - JavaScript Events in Shiny, Add JavaScript and CSS in Shiny)
library(shiny)
library(shinycssloaders)
library(shinydashboard)
library(shinyjs)
library(shinydashboardPlus)
library(shinyWidgets)
# Define UI for application that draws a histogram
ui <- dashboardPage(skin = 'blue',
shinydashboardPlus::dashboardHeader(title = 'Example',
leftUi = tagList(
useShinyjs(),
switchInput(inputId = 'swtLabels', label = 'Labels', value = TRUE,
onLabel = 'Label 1', offLabel = 'Label 2',
onStatus = 'info', offStatus = 'info', size = 'mini',
handleWidth = 230),
htmlOutput(outputId = 'labelMessage')
#withSpinner(htmlOutput(outputId = 'labelMessage')) # leads to error noted in text
)
),
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output) {
observeEvent(input$swtLabels, {
shinyjs::html(id = 'labelMessage', html = 'Starting...')
shinyjs::showElement(id = 'labelMessage')
Sys.sleep(1)
shinyjs::html(id = 'labelMessage', html = 'Done')
shinyjs::hideElement(id = 'labelMessage', anim = TRUE, animType = 'fade', time = 2.0)
})
}
# Run the application
shinyApp(ui = ui, server = server)