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

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

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

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

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

r shiny
person ialm    schedule 14.08.2013    source источник

Ответы (3)


arrow_upward
21
arrow_downward

В блестящей группе Google Джо Ченг указал мне на 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)
  })
})
person ialm    schedule 04.09.2013
comment
Этой функции больше нет в пакете shinyIncubator, так как она перемещена в основной пакет shiny. Не уверен, когда, но это блестящая версия 0.10.2.2. Также обратите внимание, что функция progressInit () больше не нужна в файле Ui.R. - person Crt Ahlin; 08.01.2015

arrow_upward
10
arrow_downward

Вот возможное решение с использованием вашего оригинального подхода.

Сначала используйте идентификатор для вкладок:

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 для некоторых пояснений.

person Stéphane Laurent    schedule 04.02.2014

arrow_upward
5
arrow_downward

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

person SBista    schedule 03.11.2016
comment
Очень красивое и чистое решение - person mmoisse; 11.11.2016
comment
использование plyr ... плохая идея, потому что конфликтует с dplyr - person Mostafa; 08.02.2017