如何优化R Shiny应用响应性？页面加载过慢求助

问题诊断 #

1. Output定义嵌套触发反应式混乱：将output$page2.tab1、output$page2.tab2等输出对象定义在observeEvent(input$page2.button)内部，每次点击按钮都会重新创建这些输出，导致Shiny反应式系统反复追踪、计算，引发循环和大量冗余操作。
2. 冗余反应式依赖：page2.plot.title作为响应式对象嵌套在按钮事件中，其依赖input$page2_input1的变化会触发额外计算，与按钮触发逻辑冲突。
3. 重复数据计算：每次绘图都对60万行的原始数据执行过滤、分组、汇总操作，未缓存中间结果，大幅消耗计算资源。
4. 调试代码冗余：多个observeEvent(input$xxx, print(...))会增加反应式系统的追踪负担。

修复方案与优化代码 #

全局声明与数据预处理 #

# 加载依赖包
library(shiny)
library(tidyverse)
library(plotly)
library(bslib)
library(shinyWidgets)
library(shinycssloaders)

options = shinyWidgets::pickerOptions(style = "btn-outline-primary")

# 定义选项向量
options.vector <- c("Option 1", "Option 2", "Option 3")
opt1.vec <- c("Level01", "Level02", "Level03", "Level04", "Level05", "Level06", 
              "Level07", "Level08", "Level09", "Level10", "Level11", "Level12")
opt2.vec <- c("Level01", "Level02", "Level03", "Level04", "Level05", "Level06", 
              "Level07", "Level08", "Level09", "Level10", "Level11", "Level12", 
              "Level13", "Level14", "Level15")
opt3.vec <- c("Level01", "Level02", "Level03", "Level04", "Level05", "Level06", 
              "Level07", "Level08", "Level09", "Level10", "Level11", "Level12", 
              "Level13", "Level14", "Level15", "Level16")
group2.vec <- c("Level01", "Level02", "Level03", "Level04", "Level05", "Level06", "Level07", "Level08", "Level09", "Level10", "Level11")

# 生成模拟数据并预处理
groupOpt <- c(rep("Option 1", times =200000), rep("Option 2", times =200000), rep("Option 3", times =200000))
group1 <- c(sample(x=opt1.vec, size=200000, replace= TRUE),
            sample(x=opt2.vec, size=200000, replace= TRUE),
            sample(x=opt3.vec, size=200000, replace= TRUE))
group2 <- sample(x=group2.vec, size=600000, replace= TRUE)

data0 <- data.frame(groupOpt, group1, group2)

# 提前完成g1字段的映射，避免绘图时重复计算
data <- data0 %>% 
  mutate(g1 = str_replace(group1, "Level", "L"))

UI代码（无核心修改，仅保持原结构） #

theme0 <- bs_theme(bootswatch="spacelab")

ui <- page_navbar(
  title = "Dashboard Name",
  id = "navbar",
  theme = theme0, 
  header = tags$head(
    tags$style(HTML("
  .pickerClass {font-size: 75%; line-height: 1.6;}
                  ")
    )
  ),
  nav_panel(
    id="page2",
    title = "Page 2",
    navset_card_pill(
      id="page2_navset",
      title = "Page 2 Title",
      sidebar = sidebar(
        radioGroupButtons(
          inputId = "page2_input1",
          label = "Option:",
          selected = "Option 3",
          choices = options.vector,
          status = "info",
          size = "sm"
        ),
        conditionalPanel(
          "input.page2_navset === 'Page 2 Tab 2 Title'",
          pickerInput(
            inputId = "page2_input2",
            label = "Select options:",
            choices = NULL,
            selected = NULL,
            multiple = TRUE,
            options = list(
              `actions-box` = TRUE,
              `selected-text-format` = "count",
              `count-selected-text` = "{0} options chosen",
              `none-selected-text` = "Select at least one option",
              style = "pickerClass"
            ),
            choicesOpt = list(
              style = rep_len("font-size: 75%; line-height: 1.6;", 16)
            )
          )
        ),
        actionButton("page2.button",
                     "Update Plot",
                     width = "80%",
                     class="btn-warning",
                     style="position:absolute; bottom: 15px;",
                     icon=icon("refresh")
        )
      ),
      nav_panel(
        id="page2_tab1",
        title="Page 2 Tab 1 Title",
        card_body(
          h3(textOutput('page2.tab1.title'), align = "center"),
          withSpinner(plotlyOutput("page2.tab1"), type=4)
        )
      ),
      nav_panel(
        id="page2_tab2",
        title="Page 2 Tab 2 Title",
        card_body(
          h3(textOutput('page2.tab2.title'), align = "center"),
          withSpinner(plotlyOutput("page2.tab2"), type=4)
        )
      )
    )
  )
)

Server代码（核心修改） #

server <- function(input, output, session) {
  
  options(warn = -1) 
  
  # 更新pickerInput选项（保留原逻辑）
  observeEvent(input$page2_input1, {
    page2PickerOptions <- data %>% 
      filter(groupOpt == input$page2_input1) %>% 
      distinct(group1) %>% 
      pull()
    
    updatePickerInput(
      session = session,
      inputId = "page2_input2",
      label = "Select options:",
      choices = page2PickerOptions,
      selected = page2PickerOptions,
      options = list(
        actionsBox = TRUE,
        selectedTextFormat = "count",
        countSelectedText = "{0} options chosen",
        noneSelectedText = "Select at least one option",
        style = "pickerClass"
      ),
      choicesOpt = list(
        style = rep_len("font-size: 75%; line-height: 1.6;", length(page2PickerOptions))
      )
    )
  })
  
  # 用eventReactive缓存按钮触发后的筛选数据，避免重复计算
  filtered_data <- eventReactive(input$page2.button, {
    list(
      tab1_data = data %>% 
        filter(groupOpt == input$page2_input1) %>% 
        distinct(group2) %>% 
        count(group2, name = "count"),
      tab2_data = data %>% 
        filter(groupOpt == input$page2_input1, group1 %in% input$page2_input2) %>% 
        count(group2, g1, group1, name = "ppl.in.group2")
    )
  })
  
  # 定义绘图标题（移至顶层，仅依赖input$page2_input1）
  page2.plot.title <- reactive({
    switch(input$page2_input1,
           "Option 1" = "Option 1 Plot Title",
           "Option 2" = "Option 2 Plot Title",
           "Option 3" = "Option 3 Plot Title")
  })
  
  # 输出标题（直接定义在顶层）
  output$page2.tab1.title <- renderText({
    "Page 2 Tab 1 Title"
  })
  output$page2.tab2.title <- renderText({
    "Page 2 Tab 2 Title"
  })
  
  # 绘制Tab1饼图
  output$page2.tab1 <- renderPlotly({
    req(filtered_data()$tab1_data)
    
    filtered_data()$tab1_data %>% 
      plot_ly(labels=~group2, values=~count, sort=FALSE) %>% 
      add_pie(hole=0.5) %>% 
      layout(title = page2.plot.title(), showlegend= T,
             xaxis = list(showgrid=FALSE, zeroline=FALSE, showticklabels=FALSE),
             yaxis = list(showgrid=FALSE, zeroline=FALSE, showticklabels=FALSE)) %>% 
      config(displaylogo = FALSE)
  })
  
  # 绘制Tab2堆叠柱状图
  output$page2.tab2 <- renderPlotly({
    req(filtered_data()$tab2_data)
    
    filtered_data()$tab2_data %>% 
      plot_ly(x=~ppl.in.group2, y=~g1, color=~group2, type='bar', name=~group2) %>% 
      layout(title = page2.plot.title(), 
             yaxis = list(title = 'Group 2', categoryorder='trace', autorange='reversed'),
             xaxis = list(title = 'Percent of people'),
             barmode = 'stack', barnorm='percent') %>% 
      config(displaylogo = FALSE)
  })
  
  session$onSessionEnded(function() {
    stopApp()
  })  
}

if (interactive())
  shinyApp(ui = ui, server = server)

关键优化说明 #

1. Output移至顶层：所有输出对象直接绑定在server函数下，避免动态创建引发的反应式循环。
2. 缓存中间数据：通过eventReactive在按钮点击时一次性完成数据过滤与汇总，后续绘图直接使用缓存结果。
3. 简化数据处理：用str_replace替代冗长的case_when完成g1字段映射，用count()替代group_by()+summarise()简化统计逻辑。
4. 移除冗余代码：删除不必要的调试用observeEvent，减少反应式系统的追踪负担。

内容的提问来源于stack exchange，提问作者prizzlywizzly