Покажите, что Shiny занят (или загружается) при смене вкладок

(Код следует после описания проблемы)

Я работаю над созданием веб-приложения с помощью Shiny, а некоторые из команд R, которые я выполняю, занимают минуты. Я обнаружил, что мне нужно предоставить пользователю некоторые указания о том, что Shiny работает, или они будут постоянно изменять параметры, которые я предоставляю на боковой панели, что просто заставляет Shiny реагировать на перезапуск вычислений после завершения начального запуска.

Итак, я создал условную панель, которая показывает сообщение "Загрузка" (называемое модальным) со следующим (спасибо Джо Ченгу из группы "Блестящая группа" для условного оператора):

# 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 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."))
    })
  })
})

Ответ 1

Через группу Shiny Google Джо Ченг указал мне на пакет shinyIncubator, где реализуемая функция выполнения (см. ?withProgress после установки пакета shinyIncubator).

Возможно, эта функция будет добавлена в пакет Shiny в будущем, но сейчас это работает.

Пример:

UI.R

library(shiny)
library(shinyIncubator)

shinyUI(pageWithSidebar(
  headerPanel("Testing"),
  sidebarPanel(
    # Action button
    actionButton("aButton", "Let 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)
  })
})

Ответ 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."))
    })
  })

вы увидите, что он работает, когда вы переходите от первой вкладки ко второй.

Update

Самый чистый вариант заключается в определении реактивного объекта, который ловит активный таблеток. Просто напишите это где-нибудь в server.R:

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

См. https://groups.google.com/d/msg/shiny-discuss/PzlSAmAxxwo/eGx187UUHvcJ для некоторых объяснений.

Ответ 3

Я думаю, что самым простым вариантом будет использование функции busyIndicator в пакете shinysky. Для получения дополнительной информации следуйте за ссылка