如何在Shiny的ObserveEvent内为所有计算过程使用withProgress进度条

嘿，我懂你的困扰——进度条只在图表渲染的瞬间闪一下，根本没覆盖模型训练和预测的整个9秒等待过程对吧？这是因为你把真正耗时的核心计算逻辑放在了renderHighchart()函数外面，进度条只包裹了一个空循环，完全没作用在实际花时间的步骤上。

问题根源 #

原来的代码逻辑是：

1. 点击按钮后，先默默跑完所有计算（过滤数据、构建时间序列、训练nnetar模型、生成预测）
2. 等所有计算都完成了，才触发renderHighchart()，这时候进度条才启动，但核心工作已经做完了，所以进度条只闪一下就消失。

解决方案 #

把所有耗时的计算步骤都放到withProgress()的包裹范围内，让进度条跟踪从数据处理到模型预测的全流程。另外，我们可以给每个关键步骤绑定进度更新，让进度条更贴合真实的计算进度，还能给用户显示当前正在做什么，体验更友好。

修改后的完整代码如下：

library(readxl)
library(dplyr)
library(shiny)
library(highcharter)
library(forecast)
library(shinyWidgets) # 注意：actionBttn依赖这个包，原代码可能遗漏了

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

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),
    actionBttn(
      inputId = "modelar",
      label = "Generar pronóstico",
      style = "bordered",
      color = "success",
      icon = icon("sliders")
    )),
  column(width = 6, highchartOutput("grafico"))
)

server <- function(input, output){
  # 用reactiveVal存储计算结果，分离计算和渲染逻辑
  forecast_result <- reactiveVal(NULL)
  
  observeEvent(input$modelar,{
    withProgress(message = 'Calculando el modelo', detail = 'Iniciando...', value = 0, {
      # 步骤1：过滤目标服务数据
      incProgress(1/5, detail = "Filtrando datos del servicio...")
      filtrado <- datos1 |> filter(Servicio == input$var)
      
      # 步骤2：转换为时间序列格式
      incProgress(1/5, detail = "Preparando serie temporal...")
      temporal <- ts(filtrado$total, start = 2017, frequency = 12)
      
      # 步骤3：训练神经网络模型（最耗时的步骤）
      incProgress(1/5, detail = "Entrenando modelo neuronal...")
      set.seed(50)
      modelo <- nnetar(temporal, p=input$rezagossiest,P=input$rezagosnoest, size=input$neuronas)
      
      # 步骤4：生成未来12期预测
      incProgress(1/5, detail = "Generando pronóstico...")
      nnetforecast <- forecast(modelo, h = 12, PI = T)
      
      # 步骤5：准备图表渲染数据
      incProgress(1/5, detail = "Preparando gráfico...")
      forecast_result(nnetforecast)
    })
  })
  
  output$grafico <- renderHighchart({
    req(forecast_result()) # 确保只有计算完成后才渲染图表
    hchart(forecast_result())
  })
}

shinyApp(ui, server)

关键改动说明 #

• 新增forecast_result这个reactiveVal来存储计算好的预测结果，把计算逻辑和图表渲染逻辑分离开，代码更清晰
• 将所有耗时步骤（数据过滤、时间序列转换、模型训练、预测生成）都放到withProgress()内部，每个步骤后调用incProgress()更新进度
• 给每个incProgress()添加detail参数，让用户清楚知道当前正在进行的步骤，等待体验更顺畅
• 用req(forecast_result())确保图表渲染只在计算完成后触发，避免空渲染

这样修改后，进度条就会从你点击按钮的那一刻开始，全程覆盖整个计算流程，完美解决你遇到的问题！

内容的提问来源于stack exchange，提问作者Jorge Hernández