Добавление индикатора выполнения для отображения прогресса ggplotting в Shiny

Question

Основная цель моего приложения Shiny - отображать большие объемы данных через (интерактивные) ggplots. При наличии достаточного количества данных время, необходимое для отображения графиков, может достигать ~ 10 секунд, и я хотел бы отобразить индикатор выполнения для обеспечения обратной связи.

Я пробовал оба с withProgress и winProgressBar, но ни один из них не отражает время, необходимое для появления ggplots: оба индикатора выполнения исчезают задолго до того, как отображаются реальные графики.

Итак, мой вопрос: как мне реализовать (любой тип) индикатор выполнения, чтобы отразить время, необходимое для появления ggplots на экране?

library(shiny)
library(ggplot2)
library(dplyr)

ui = fluidPage(
    mainPanel(
      uiOutput("plots")
    )
)

server = function(input, output) {

  #list of things I want to plot, which will be split over column wt
  plotlist = sort(unique(mtcars$wt))[1:4]

  observe({
    pb = winProgressBar(                                 #test 1: winProgressBar
      title = 'observe',                                 #test 1: winProgressBar
      label = 'plotting'                                 #test 1: winProgressBar
    )                                                    #test 1: winProgressBar
    message({                                            #test 1: winProgressBar

      withProgress(message = 'ggplotting', value = 0, {  #test 2: withProgress

        for (i in plotlist) local({

          nm <- i
          temp.data <- filter(mtcars, wt == plotlist[nm])

          plotAname  <- paste0("plotA", nm)
          output[[plotAname]] <- renderPlot(ggplot(temp.data, aes(x = mpg, y= cyl)) + geom_point())

          plotBname  <- paste0("plotB", nm)
          output[[plotBname]] <- renderPlot(ggplot(temp.data, aes(x = mpg, y= drat)) + geom_point())

          plotCname  <- paste0("plotC", nm)
          output[[plotCname]] <- renderPlot(ggplot(temp.data, aes(x = mpg, y= disp)) + geom_point())

          plotDname  <- paste0("plotD", nm)
          output[[plotDname]] <- renderPlot(ggplot(temp.data, aes(x = mpg, y= hp)) + geom_point())

          setWinProgressBar(pb, value = nm/10)         #test 1: winProgressBar
          incProgress(1/(length(plotlist)))            #test 2: withProgress
        }) #end of for()
      }) #end of withProgress                          #test 2: withProgress

    close(pb)                                          #test 1: winProgressBar
    }) #end of message                                 #test 1: winProgressBar
  }) #end of observe

  output$plots <- renderUI({

    withProgress(message = 'rendering', value = 0, {   #test 3: withProgress

      plot_output_list <- lapply(plotlist, function(i) { 

        incProgress(1/(length(plotlist)))              #test 3: withProgress

        #encompass everything in a div because lapply can only returns a single result per loop cycle. 
        div(style = "padding: 0px; margin: 0px;",
            div(style = "position:relative; margin-bottom: -5px; padding: 0px;",
                plotOutput(paste0("plotA", i))
            ),
            div(style = "position:relative; margin-bottom: -5px; padding: 0px;",
                plotOutput(paste0("plotB", i))
            ),
            div(style = "position:relative; margin-bottom: -5px; padding: 0px;",
                plotOutput(paste0("plotC", i))
            ),
            plotOutput(paste0("plotD", i))
        )
      }) #end of lapply
    }) #end of withProgress                          #test 3: withProgress
  }) #end of output$plots

}

shinyApp(ui = ui, server = server)

Этот пример занимает около 4 секунд, чтобы отобразить его графики. Все три индикатора выполнения теста закончились примерно через ~ 1 секунду.

Спасибо, что нашли время, чтобы пройти через это! Если я могу дать какие-либо разъяснения, пожалуйста, дайте мне знать.

Answer 1

На самом деле это не индикатор выполнения, который вы хотите сгенерировать. Но вместо этого вы можете отобразить сообщение о загрузке в баннере, поэтому я полагаю, что это может быть полезно здесь. Просто скопируйте следующий фрагмент кода в пользовательскую часть приложения и настройте цвета по мере необходимости.

info_loading <- "Shiny is busy. Please wait."
your_color01 <- # define a color for the text
your_color02 <- # define a color for the background of the banner

tags$head(tags$style(type="text/css",
                                      paste0("
                                             #loadmessage {
                                             position: fixed;
                                             top: 0px;
                                             left: 0px;
                                             width: 100%;
                                             padding: 5px 0px 5px 0px;
                                             text-align: center;
                                             font-weight: bold;
                                             font-size: 100%;
                                             color: ", your_color01,";
                                             background-color: ", your_color02,";
                                             z-index: 105;
                                             }
                                             "))),
                 conditionalPanel(condition="$('html').hasClass('shiny-busy')",
                                  tags$div(info_loading,id="loadmessage"))

Не стесняйтесь настраивать параметры (например, верхнее положение) по мере необходимости. Вы также можете увидеть: блестящая полоса загрузки для htmlwidgets