Shiny App Fortschrittsbalken für ganze Reihe von reaktiven Funktionen

Question

Ich arbeite an einer Shiny-App, wo der Benutzer ein Gen aus einem Dropdown-Menü auswählen kann, drücken Sie eine Absenden-Taste, und dann wird eine Reihe von verschiedenen Grafiken dafür angezeigt Gen. Die Berechnung, um all diese Graphen zu generieren, braucht etwas Zeit und ich möchte, dass Shiny einen Fortschrittsbalken oder eine Benachrichtigung anzeigt, dass es beschäftigt ist, so dass der Benutzer sich von der Senden-Schaltfläche fernhält.

Ich habe withProgress() und das Progress-Objekt in Shiny gefunden, aber - wenn ich das richtig verstanden habe - müssen diese immer innerhalb einer reaktiven Funktion platziert werden und dann den Fortschritt dieser Funktion anzeigen. Ich habe jedoch eine ganze Reihe von verschiedenen renderPlot() - Funktionen, die verarbeitet werden sollen, und möchte den kumulativen Fortschritt aller von ihnen anzeigen.

Bei der Suche im Internet habe ich auch das Paket ShinySky gefunden, das einen busyIndicator enthält, der aktiviert werden kann, wenn Shiny länger als eine bestimmte Zeit beschäftigt ist. Allerdings habe ich die Fehlermeldung "Paket 'shinysky' ist nicht verfügbar (für R Version 3.3.1)", wenn ich versucht habe, es zu installieren.

I erzeugen einen kleinen Dummy-App, die nycflights13 Wetterdaten mit einer Zeitverzögerung mit der Auffrischung des Grundes illustrieren, nachdem die Eingabe zu ändern:

library(shiny) 
library(nycflights13) 

ui <- fluidPage(
    wellPanel(
    fluidRow(
     column(12, offset = 0, 
     titlePanel("Look up airport weather data"))), 
    fluidRow(
     column(3, offset = 0, 
     selectizeInput(inputId = "airportName", label = "", 
      choices = c("EWR", "JFK", "LGA")))), 
    fluidRow(
     column(12, offset = 0, 
     actionButton(inputId = "klickButton", label = "Submit")))), 
    fluidRow(
    column(6, offset = 0, 
     plotOutput(outputId = "windHist")), 
    column(6, offset = 0, 
     plotOutput(outputId = "windData"))), 
    fluidRow(
    column(6, offset = 0, 
     plotOutput(outputId = "precipData")), 
    column(6, offset = 0, 
     plotOutput(outputId = "tempData"))) 
) 


server <- function(input, output) { 
    wSubset <- eventReactive(input$klickButton, { 
    subset(weather, weather$origin == input$airportName)}) 
    output$windHist <- renderPlot({ 
    Sys.sleep(1) 
    hist(wSubset()$wind_dir)}) 
    output$windData <- renderPlot({ 
    Sys.sleep(1) 
    plot(wSubset()$wind_speed, wSubset()$wind_gust)}) 
    output$precipData <- renderPlot({ 
    Sys.sleep(1) 
    plot(wSubset()$humid, wSubset()$precip)}) 
    output$tempData <- renderPlot({ 
    Sys.sleep(1) 
    plot(wSubset()$temp, wSubset()$dewp)}) 
} 


shinyApp(ui = ui, server = server) 

Ich suche nach einer Möglichkeit, einen Fortschrittsbalken anzuzeigen, Startet, wenn die erste Funktion nach dem Drücken der Submit-Taste beschäftigt ist und weiterläuft, bis alle Plots erstellt sind. Wenn das zu kompliziert wird, bin ich auch glücklich mit anderen Mitteln, dem Benutzer zu sagen, dass etwas tatsächlich im Hintergrund passiert, und bitten daher um etwas Geduld.

Answer 1

Dies ist eine Möglichkeit, dies zu lösen, aber mit einem Spinner auf jeder Parzelle. Es basiert vollständig auf this Lösung von Dean Atali. Der JS-Code wird benötigt, um das Drehfeld auszublenden, bevor auf die Schaltfläche "Senden" geklickt wird. Sobald der Button angeklickt ist, wird der Spinner angezeigt. Setzen Sie den spinner.gif und den JS-Code in den www-Ordner.

spinnerManage.js

$(document).ready(function() { 
      $('#klickButton').click(function() { 
      $(".loading-spinner").show(); 
     }); 
    }); 
    $(document).on("shiny:connected", function(e) { 
      $(".loading-spinner").hide(); 
    }); 

app.R

library(shiny) 
    library(nycflights13) 

    mycss <- " 
    .plot-container { 
     position: relative; 
    } 
    .loading-spinner { 
     position: absolute; 
     left: 50%; 
     top: 50%; 
     z-index: -1; 
     margin-top: -33px; /* half of the spinner's height */ 
     margin-left: -33px; /* half of the spinner's width */ 
    } 
    " 

    ui <- fluidPage(
      tags$head(tags$style(HTML(mycss)), 
         includeScript("./www/spinnerManage.js")), 
      wellPanel(
        fluidRow(
          column(12, offset = 0, 
            titlePanel("Look up airport weather data"))), 
        fluidRow(
          column(3, offset = 0, 
            selectizeInput(inputId = "airportName", label = "", 
                choices = c("EWR", "JFK", "LGA")))), 
        fluidRow(
          column(12, offset = 0, 
            actionButton(inputId = "klickButton", label = "Submit")))), 
      fluidRow(
        column(6, offset = 0, 
          div(class = "plot-container", 
             tags$img(src = "spinner.gif", 
               class = "loading-spinner"),   
          plotOutput(outputId = "windHist")) 
        ), 
        column(6, offset = 0, 
          div(class = "plot-container", 
           tags$img(src = "spinner.gif", 
             class = "loading-spinner"),   
           plotOutput(outputId = "windData")) 
          )), 
      fluidRow(
        column(6, offset = 0, 
          div(class = "plot-container", 
           tags$img(src = "spinner.gif", 
             class = "loading-spinner"),   
           plotOutput(outputId = "precipData")) 
          ), 
        column(6, offset = 0, 
          div(class = "plot-container", 
           tags$img(src = "spinner.gif", 
             class = "loading-spinner"),   
           plotOutput(outputId = "tempData")) 
    )) 
    ) 


    server <- function(input, output) { 
      wSubset <- eventReactive(input$klickButton, { 
        subset(weather, weather$origin == input$airportName)}) 
      output$windHist <- renderPlot({ 
        Sys.sleep(1) 
        hist(wSubset()$wind_dir)}) 
      output$windData <- renderPlot({ 
        Sys.sleep(1) 
        plot(wSubset()$wind_speed, wSubset()$wind_gust)}) 
      output$precipData <- renderPlot({ 
        Sys.sleep(1) 
        plot(wSubset()$humid, wSubset()$precip)}) 
      output$tempData <- renderPlot({ 
        Sys.sleep(1) 
        plot(wSubset()$temp, wSubset()$dewp)}) 
    } 


    shinyApp(ui = ui, server = server)