Show that Shiny is busy (or loading) when changing tab panels

Question

(Code follows after problem description)

I am working on making a web app with Shiny, and some of the R commands that I am executing take minutes to complete. I found that I need to provide the user with some indication that Shiny is working, or they will continuously change the parameters I provide in the side panel, which just causes Shiny to reactively restart the calculations once the initial run is completed.

So, I created a conditional panel that shows a "Loading" message (referred to as a modal) with the following (thanks to Joe Cheng on the Shiny Google group for the conditional statement):

# generateButton is the name of my action button
loadPanel <- conditionalPanel("input.generateButton > 0 && $('html').hasClass('shiny-busy')"),
                              loadingMsg)

This is working as intended if the user remains on the current tab. However, the user can switch to another tab (that may contain some calculations that need to be run for some time), but the loading panel appears and disappears immediately, all while R chugs away at the calculations, and then refreshing the content only after it is done.

Since this may be hard to visualize, I provided some code to run below. You will notice that clicking the button to start the calculations will produce a nice loading message. However, when you switch to tab 2, R starts running some calculations, but fails to show the loading message (maybe Shiny does not register as being busy?). If you restart the calculations by pressing the button again, the loading screen will show up correctly.

I want the loading message to appear when switching to a tab that is loading!

ui.R

library(shiny)

# Code to make a message that shiny is loading
# Make the loading bar
loadingBar <- tags$div(class="progress progress-striped active",
                       tags$div(class="bar", style="width: 100%;"))
# Code for loading message
loadingMsg <- tags$div(class="modal", tabindex="-1", role="dialog", 
                       "aria-labelledby"="myModalLabel", "aria-hidden"="true",
                       tags$div(class="modal-header",
                                tags$h3(id="myModalHeader", "Loading...")),
                       tags$div(class="modal-footer",
                                loadingBar))
# The conditional panel to show when shiny is busy
loadingPanel <- conditionalPanel(paste("input.goButton > 0 &&", 
                                       "$('html').hasClass('shiny-busy')"),
                                 loadingMsg)

# Now the UI code
shinyUI(pageWithSidebar(
  headerPanel("Tabsets"),
  sidebarPanel(
    sliderInput(inputId="time", label="System sleep time (in seconds)", 
                value=1, min=1, max=5),
    actionButton("goButton", "Let's go!")
  ),

  mainPanel(
    tabsetPanel(
      tabPanel(title="Tab 1", loadingPanel, textOutput("tabText1")), 
      tabPanel(title="Tab 2", loadingPanel, textOutput("tabText2")) 
    )
  )
))

server.R

library(shiny)

# Define server logic for sleeping
shinyServer(function(input, output) {
  sleep1 <- reactive({
    if(input$goButton==0) return(NULL)
    return(isolate({
      Sys.sleep(input$time)
      input$time
    }))
  })

  sleep2 <- reactive({
    if(input$goButton==0) return(NULL)
    return(isolate({
      Sys.sleep(input$time*2)
      input$time*2
    }))
  })

  output$tabText1 <- renderText({
    if(input$goButton==0) return(NULL)
    return({
      print(paste("Slept for", sleep1(), "seconds."))
    })
  })

  output$tabText2 <- renderText({
    if(input$goButton==0) return(NULL)
    return({
      print(paste("Multiplied by 2, that is", sleep2(), "seconds."))
    })
  })
})

Answer 1

Via the Shiny Google group, Joe Cheng pointed me to the shinyIncubator package, where there is a progress bar function that is being implemented (see ?withProgress after installing the shinyIncubator package).

Maybe this function will be added to the Shiny package in the future, but this works for now.

Example:

UI.R

library(shiny)
library(shinyIncubator)

shinyUI(pageWithSidebar(
  headerPanel("Testing"),
  sidebarPanel(
    # Action button
    actionButton("aButton", "Let's go!")
  ),

  mainPanel(
    progressInit(),
    tabsetPanel(
      tabPanel(title="Tab1", plotOutput("plot1")),
      tabPanel(title="Tab2", plotOutput("plot2")))
  )
))

SERVER.R

library(shiny)
library(shinyIncubator)

shinyServer(function(input, output, session) {
  output$plot1 <- renderPlot({
    if(input$aButton==0) return(NULL)

    withProgress(session, min=1, max=15, expr={
      for(i in 1:15) {
        setProgress(message = 'Calculation in progress',
                    detail = 'This may take a while...',
                    value=i)
        print(i)
        Sys.sleep(0.1)
      }
    })
    temp <- cars + matrix(rnorm(prod(dim(cars))), nrow=nrow(cars), ncol=ncol(cars))
    plot(temp)
  })

  output$plot2 <- renderPlot({
    if(input$aButton==0) return(NULL)

    withProgress(session, min=1, max=15, expr={
      for(i in 1:15) {
        setProgress(message = 'Calculation in progress',
                    detail = 'This may take a while...',
                    value=i)
        print(i)
        Sys.sleep(0.1)
      }
    })
    temp <- cars + matrix(rnorm(prod(dim(cars))), nrow=nrow(cars), ncol=ncol(cars))
    plot(temp)
  })
})

Answer 2

Here is a possible solution using your original approach.

First use an identifier for the tabs:

tabsetPanel(
  tabPanel(title="Tab 1", loadingPanel, textOutput("tabText1")), 
  tabPanel(title="Tab 2", loadingPanel, textOutput("tabText2")),
  id="tab"
)

Then, if you connect tabText1 to input$tab:

  output$tabText1 <- renderText({
    if(input$goButton==0) return(NULL)
    input$tab
    return({
      print(paste("Slept for", sleep1(), "seconds."))
    })
  })

you will see that it works when you go from the first tab to the second one.

Update

A cleanest option consists in defining a reactive object catching the active tabset. Just write this anywhere in server.R :

  output$activeTab <- reactive({
    return(input$tab)
  })
  outputOptions(output, 'activeTab', suspendWhenHidden=FALSE)

See https://groups.google.com/d/msg/shiny-discuss/PzlSAmAxxwo/eGx187UUHvcJ for some explanation.