在更改选项卡面板时显示 Shiny 正忙（或正在加载）

Question

（问题描述后的代码）

我正在使用 Shiny 制作一个 Web 应用程序，而我正在执行的一些 R 命令需要几分钟才能完成。我发现我需要向用户提供一些表明 Shiny 正在工作的指示，否则他们会不断更改我在侧面板中提供的参数，这只会导致 Shiny 在初始运行完成后反应性地重新开始计算。

因此，我创建了一个条件面板，显示“正在加载”消息（称为模式），其中包含以下内容（感谢 Shiny Google 小组的 Joe Cheng 的条件语句）：

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

如果用户保持在当前选项卡上，这将按预期工作。但是，用户可以切换到另一个选项卡（其中可能包含一些需要运行一段时间的计算），但是加载面板会立即出现和消失，而 R 会在计算中突然消失，然后仅在之后刷新内容完成了。

由于这可能难以想象，我提供了一些代码在下面运行。您会注意到单击按钮开始计算将产生一个很好的加载消息。但是，当您切换到选项卡 2 时，R 开始运行一些计算，但无法显示加载消息（也许 Shiny 没有注册为忙？）。如果再次按下按钮重新开始计算，加载屏幕将正确显示。

我希望在切换到正在加载的标签时显示加载消息！

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

通过Shiny Google group，Joe Cheng 将我指向shinyIncubator 包，其中正在实现一个进度条功能（安装shinyIncubator 包后请参阅?withProgress）。

也许这个功能将来会添加到 Shiny 包中，但现在可以。

例子：

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

这是使用您的原始方法的可能解决方案。

首先使用标签的标识符：

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

那么，如果您将tabText1 连接到input$tab：

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

当您从第一个选项卡转到第二个选项卡时，您会发现它有效。

更新

最简洁的选项在于定义一个响应式对象来捕获活动的标签集。写在server.R的任何地方：

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

请参阅https://groups.google.com/d/msg/shiny-discuss/PzlSAmAxxwo/eGx187UUHvcJ 以获得一些解释。

Answer 3

我认为最简单的选择是在 shinysky 包中使用 busyIndi​​cator 函数。更多信息请关注link