r - 如何对 Shiny 的 ObserveEvent 中执行的所有计算使用“withProgress”？

问题描述

嗨，感谢您阅读我，我正在 Shiny 中制作一个应用程序，该应用程序使用神经网络计算预测图。模型（和图形）加载大约需要 9 秒，我希望在该等待时间内出现一个进度条，但我无法让它正常工作，因为显然它只出现在图形。你知道我可以让所有计算的栏出现吗？

代码（和数据）如下：

library(readxl)
library(dplyr)
library(shiny)
library(highcharter)
library(forecast)

datos <- data.frame(
  Servicio = sample(c("Servicio 1", "Servicio 2", "Servicio 3"), 162, replace = TRUE),
  Año_mes = seq(as.Date("1980-01-01"), as.Date("2020-05-31"), by = "quarter"),
  servs = rnorm(162, mean = 500)
) |> 
  setNames(c("Servicio", "Año_mes", "Número de Servicios"))

datos1 <- datos |> 
  group_by(Año_mes, Servicio) |> 
  summarise(total = sum(`Número de Servicios`)) 

datos_select <- datos |> 
  group_by(Servicio) |> 
  summarise(total = sum(datos$`Número de Servicios`))




datos_select <- datos_select$Servicio
datos_select

ui <- fluidPage(
  column(
    width = 6,
    selectInput("var",
                "Escoge un servicio a modelar", choices = datos_select
    ),
    numericInput("rezagosnoest", "Escoge un número de rezagos no estacionales:",1, min = -1000, max = 1000),
    numericInput("rezagossiest", "Escoge un número de rezagos estacionales:",1, min = -1000, max = 1000),
    numericInput("neuronas", "Escoge la cantidad de neuronas usadas para el cálculo:",1, min = 1, max = 1000),
    #numericInput("futuros", "Escoge el número de periodos (meses) a pronosticar:",1, min = 1, max = 1000),
    actionBttn(
      inputId = "modelar",
      label = "Generar pronóstico", 
      style = "bordered",
      color = "success",
      icon = icon("sliders")
    )),
  column(width = 6,
                  highchartOutput("grafico"))
)


server <- function(input, output){
  
  observeEvent(
    input$modelar,{
      filtrado <- datos1 |> 
        filter(Servicio == input$var) 
      temporal <- ts(filtrado$total, start = 2017, frequency = 12)
      set.seed(50)
      modelo <- nnetar(temporal, p=input$rezagossiest,P=input$rezagosnoest,
                       size=input$neuronas)
      nnetforecast <- forecast(modelo, h = 12, PI = T)
      output$grafico <- renderHighchart({
        withProgress(message = 'Calculando el modelo',
                     detail = 'Espera un momento...', value = 0, {
                       for (i in 1:15) {
                         incProgress(1/15)
                       }
                     })
        hchart(nnetforecast)
        
      })
    }
    
    
  )
  
}

shinyApp(ui, server)

标签： rshinyloadr-highcharter

解决方案

我认为你不能添加一个精确的进度条而不抽动使用的函数来给你关于实际进度的反馈，或者有另一个函数来根据用户输入来估计所需的时间。

如果您没有时间深入研究，我鼓励您使用以下一个或两个软件包：

-https://dreamrs.github.io/shinybusy/

-https://github.com/daattali/shinycssloaders

两者都提供了良好的服务，让用户知道您的应用程序没有崩溃。

我提供以下示例，添加一个条件面板以隐藏绘图，直到单击操作按钮。

添加 CSS 加载器和条件面板

library(shinycssloaders)
library(shiny)

ui <- fluidPage(
  
  column(
    width = 6,
    selectInput("var",
                "Escoge un servicio a modelar", choices = datos_select
    ),
    numericInput("rezagosnoest", "Escoge un número de rezagos no estacionales:",1, min = -1000, max = 1000),
    numericInput("rezagossiest", "Escoge un número de rezagos estacionales:",1, min = -1000, max = 1000),
    numericInput("neuronas", "Escoge la cantidad de neuronas usadas para el cálculo:",1, min = 1, max = 1000),
    #numericInput("futuros", "Escoge el número de periodos (meses) a pronosticar:",1, min = 1, max = 1000),
    actionBttn(
      inputId = "modelar",
      label = "Generar pronóstico", 
      style = "bordered",
      color = "success",
      icon = icon("sliders")
    )),
  column(width = 6,
         
         conditionalPanel("input.modelar > 0",
                          shinycssloaders::withSpinner(
                            highchartOutput("grafico")
                          ),
         )
  ) 
)

server <- function(input, output){
 
  observeEvent(
    input$modelar,{
      
      output$grafico <- renderHighchart({  
          filtrado <- datos1 |> 
            filter(Servicio == input$var) 
          temporal <- ts(filtrado$total, start = 2017, frequency = 12)
          set.seed(50)
          modelo <- nnetar(temporal, p=input$rezagossiest,P=input$rezagosnoest,
                           size=input$neuronas)
          nnetforecast <- forecast(modelo, h = 12, PI = T)
          
          hchart(nnetforecast)
      }) 
    }) 
}

shinyApp(ui, server)

这导致我进入另一个问题，您正在使用操作按钮作为提交按钮。如您所见，问题在于输入更改激活了反应性，这就是我添加的原因isolate()：

防止反应

server <- function(input, output){
  
  observeEvent(
    input$modelar,{
      
      output$grafico <- renderHighchart({
        isolate({    
          filtrado <- datos1 |> 
            filter(Servicio == input$var) 
          temporal <- ts(filtrado$total, start = 2017, frequency = 12)
          set.seed(50)
          modelo <- nnetar(temporal, p=input$rezagossiest,P=input$rezagosnoest,
                           size=input$neuronas)
          nnetforecast <- forecast(modelo, h = 12, PI = T)
          
          hchart(nnetforecast)
        })    
      })  
    })
}

如果您仍想添加进度条，我想您可以将其与图表的呈现并行添加：

并行进度条的最终答案

library(readxl)
library(dplyr)
library(shiny)
library(highcharter)
library(forecast)
library(shinycssloaders)

datos <- data.frame(
  Servicio = sample(c("Servicio 1", "Servicio 2", "Servicio 3"), 162, replace = TRUE),
  Año_mes = seq(as.Date("1980-01-01"), as.Date("2020-05-31"), by = "quarter"),
  servs = rnorm(162, mean = 500)
) |> 
  setNames(c("Servicio", "Año_mes", "Número de Servicios"))

datos1 <- datos |> 
  group_by(Año_mes, Servicio) |> 
  summarise(total = sum(`Número de Servicios`)) 

datos_select <- datos |> 
  group_by(Servicio) |> 
  summarise(total = sum(datos$`Número de Servicios`))




datos_select <- datos_select$Servicio
datos_select

ui <- fluidPage(
  
  column(
    width = 6,
    selectInput("var",
                "Escoge un servicio a modelar", choices = datos_select
    ),
    numericInput("rezagosnoest", "Escoge un número de rezagos no estacionales:",1, min = -1000, max = 1000),
    numericInput("rezagossiest", "Escoge un número de rezagos estacionales:",1, min = -1000, max = 1000),
    numericInput("neuronas", "Escoge la cantidad de neuronas usadas para el cálculo:",1, min = 1, max = 1000),
    #numericInput("futuros", "Escoge el número de periodos (meses) a pronosticar:",1, min = 1, max = 1000),
    actionBttn(
      inputId = "modelar",
      label = "Generar pronóstico", 
      style = "bordered",
      color = "success",
      icon = icon("sliders")
    )),
  column(width = 6,
         
         conditionalPanel("input.modelar > 0",
                          shinycssloaders::withSpinner(
                            highchartOutput("grafico")
                          ),
         )
  )
  
)


server <- function(input, output){
  
  
  observeEvent(
    input$modelar,{
      output$grafico <- renderHighchart({
        isolate({    
          filtrado <- datos1 |> 
            filter(Servicio == input$var) 
          temporal <- ts(filtrado$total, start = 2017, frequency = 12)
          set.seed(50)
          modelo <- nnetar(temporal, p=input$rezagossiest,P=input$rezagosnoest,
                           size=input$neuronas)
          nnetforecast <- forecast(modelo, h = 12, PI = T)
          
          hchart(nnetforecast)
        })
        
      })
      
    })
  
  
  observeEvent(input$modelar,{
    withProgress(message = 'Calculando el modelo',
                 detail = 'Espera un momento...', value = 0, {
                   for (i in 1:15) {
                     Sys.sleep(1)
                     incProgress(i/15)
                   }
                 })
  })
  
  
}

shinyApp(ui, server)

最终推荐

进入 nnet 并添加一些进度指示器（迭代或其他东西）将其拉出并与 cssloader 结合使用以涵盖绘图时间。