Shiny应用模块与Observer反应性问题求助：重复创建观察者致崩溃

问题背景 #

预期流程：

• 用户进行初始选择
• 基于选择调用数据库获取MAIN_DATA（非即时操作）
• 通过单选按钮初步过滤得到MAIN_DATA_FILTERED（即时）
• 根据选中标签二次过滤并展示MAIN_DATA_FILTERED_FILTERED（即时）

遇到的问题：

• 切换标签或修改最后一步选择菜单时，会重复弹出模态框，n次操作弹出n个模态框，最终导致系统崩溃
• 每次切换标签、修改选择都会为组件创建额外观察者，造成反应性逻辑混乱

核心问题分析 #

代码中存在多处重复创建模块服务器实例的问题：

1. 最外层server用observe包裹mainPageServer调用，导致每次反应式环境变化都会重新初始化主模块
2. mainPageServer中，每次点击getData后，又在observeEvent(input$testFilter)里重复调用testServer，多次创建测试模块实例
3. testServer中，每次切换input$tab都调用lastSelectionsServer，重复创建最后选择模块的实例，导致观察者被多次注册

这些重复实例会各自维护独立的反应性逻辑，每次触发操作时所有实例都会响应，最终出现多模态框、性能崩溃的问题。

修复后的完整代码 #

# Load necessary libraries
library(shiny)
library(dplyr)

# Define the UI for the selections module
selectionsUI <- function(id) {
  ns <- NS(id)
  selectInput(ns("variableSelect"), "Choose some:", choices = c("X", "Z"), multiple = TRUE)
}

# Define the server logic for the selections module
selectionsServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    reactive({
      input$variableSelect
    })
  })
}

# Define the UI for the last selections module
lastSelectionsUI <- function(id) {
  ns <- NS(id)
  tagList(
    actionButton(ns("infoButton"), "INFORMATION BUG"),
    uiOutput(ns("lastSelector"))
  )
}

# Define the server logic for the last selections module
lastSelectionsServer <- function(id, selectionsSnapshot, selectedTab) {
  moduleServer(id, function(input, output, session) {
    lastFilter <- reactiveVal(NULL)
    
    observeEvent(input$infoButton, {
      showModal(
        modalDialog(
          title = "Now working correctly!",
          paste0("Selected tab: ", selectedTab())
        )
      )
    })

    output$lastSelector <- renderUI({
      ns <- session$ns
      if (selectedTab() == "Y below zero") {
        selectInput(label = "LAST FILTER", ns("filterAgain"), choices = selectionsSnapshot(), multiple = TRUE)
      } else {
        tagList()
      }
    })

    observeEvent(input$filterAgain, {
      lastFilter(input$filterAgain)
      print(lastFilter())
    }, ignoreNULL = FALSE)

    return(lastFilter)
  })
}

# Define the UI for the test module
testUI <- function(id) {
  ns <- NS(id)
  tagList(
    column(2, lastSelectionsUI(ns("last"))),
    column(6, tabsetPanel(
      id = ns("tab"),
      tabPanel("Y above zero", uiOutput(ns("Y_above_zero"))),
      tabPanel("Y below zero", uiOutput(ns("Y_below_zero")))
    ))
  )
}

# Define the server logic for the test module
testServer <- function(id, data, selectionsSnapshot) {
  moduleServer(id, function(input, output, session) {
    # 仅初始化一次lastSelections模块
    lastFilter <- lastSelectionsServer("last", selectionsSnapshot, reactive(input$tab))

    # Create a reactive expression that filters data based on the selected tab and the last filter
    filteredData <- reactive({
      df <- data()
      if (input$tab == "Y above zero") {
        df <- df[df$Y > 0, ]
      } else if (input$tab == "Y below zero") {
        df <- df[df$Y <= 0, ]
      }

      # Filter based on the last filter
      filterValue <- lastFilter()
      if (!is.null(filterValue)) {
        df <- df %>% select(all_of(filterValue))
      }
      df
    })

    # Add an action button to the UI for each tab
    output$Y_above_zero <- renderUI({
      if (input$tab == "Y above zero") {
        actionButton(ns("showDataAbove"), "Show Data")
      }
    })

    output$Y_below_zero <- renderUI({
      if (input$tab == "Y below zero") {
        actionButton(ns("showDataBelow"), "Show Data")
      }
    })

    # Show the filtered data in a modal when the button is clicked
    observeEvent(input$showDataAbove, {
      showModal(modalDialog(
        title = "Data where Y is above zero",
        renderTable(filteredData())
      ))
    })

    observeEvent(input$showDataBelow, {
      showModal(modalDialog(
        title = "Data where Y is below zero",
        renderTable(filteredData())
      ))
    })
  })
}

# Define the main page UI
mainPageUI <- function(id) {
  ns <- NS(id)
  fluidPage(
    h1("Main filter"),
    selectionsUI(ns("selections")),
    actionButton(ns("getData"), "Get data from database"),
    tags$hr(),
    tags$br(),
    h1("Intermediate on-the-fly filter"),
    radioButtons(ns("testFilter"), "Filter data", choices = c("X Above zero", "X Below zero")),
    tags$hr(),
    tags$br(),
    wellPanel(fluidRow(testUI(ns("test"))))
  )
}

# Define the main page server
mainPageServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    selections <- selectionsServer("selections")
    
    # 初始化数据相关反应式变量
    rawData <- reactiveVal(NULL)
    selectionsSnapshot <- reactiveVal(NULL)
    
    observeEvent(input$getData, {
      req(selections())
      print("Getting data from database")
      # Save a snapshot of the selections
      selectionsSnapshot(selections())
      # Get some data from a database
      rawData(data.frame(X = rnorm(10), Y = rnorm(10), Z = rnorm(10)))
      print("Got data from database")
    })
    
    # 实时过滤数据
    filteredData <- reactive({
      req(rawData())
      if (input$testFilter == "X Above zero") {
        rawData()[rawData()$X > 0, ]
      } else {
        rawData()[rawData()$X <= 0, ]
      }
    })
    
    # 仅初始化一次test模块
    testServer("test", filteredData, selectionsSnapshot)
  })
}

# Define the shiny server
server <- shinyServer(function(global, input, output, session) {
  # 直接调用主模块，无需包裹observe
  mainPageServer("main_page")
})

# Define the shiny UI
ui <- fluidPage(mainPageUI("main_page"))

# Run the application
shinyApp(ui = ui, server = server)

关键修复说明 #

1. 移除冗余的重复模块初始化

   • 最外层server直接调用mainPageServer，不再用observe包裹，避免主模块重复初始化
   • mainPageServer中，testServer仅初始化一次，依赖反应式的filteredData而非重复创建
   • testServer中，lastSelectionsServer仅初始化一次，传入反应式的selectedTab，而非每次tab切换都重新创建模块

2. 优化反应式逻辑触发时机

   • lastSelectionsServer中，renderUI依赖反应式的selectedTab()，实现tab切换时自动更新UI
   • 将lastFilter的更新改为observeEvent(input$filterAgain)，明确触发条件，避免不必要的重复执行

3. 调整数据传递方式

   • 用reactiveVal存储原始数据和选择快照，替代嵌套的reactive定义，让反应式依赖更清晰
   • filteredData改为直接依赖rawData和input$testFilter，无需嵌套在observeEvent中

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