在更改选项卡面板时显示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小组,Joe Cheng向我指出了shinyIncubator包,其中有一个正在实施的进度条功能(请参阅?withProgress安装shinyIncubator包后).

也许这个功能将来会被添加到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."))
    })
  })

当你从第一个标签转到第二​​个标签时,你会看到它有效.

更新

最干净的选择包括定义捕获活动tabset的反应对象.只需在以下位置写下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函数。有关更多信息，请点击此链接