Shiny：仅让控件依赖数据框的指定列子集

问题描述 #

拥有返回data.frame的reactive对象my_data，需求是让部分控件仅依赖其中的rel_1、rel_2列——仅当这两列的值变化时触发控件刷新；修改irr_1、irr_2等无关列时，控件不应刷新。

尝试创建仅返回相关列的reactive对象relevant_data并绑定控件后，发现点击所有按钮（包括修改无关列的按钮）都会触发verbatimTextOutput刷新，不符合预期。

原因分析 #

Shiny的reactive依赖机制默认只检测reactive对象是否被重新计算，而非对象内部的内容是否变化。当my_data被修改（哪怕仅修改无关列），依赖它的relevant_data会被重新运行，即使运行结果和之前完全一致，Shiny也会认为它发生了“变化”，进而触发绑定的输出刷新。

解决方案 #

通过reactiveVal存储相关列的内容，并手动比较新旧值，仅当内容确实变化时才更新reactiveVal。这样绑定到该reactiveVal的控件只会在相关列内容改变时触发刷新。

修改后的完整代码 #

library(shiny)
library(DT)
library(dplyr)
library(glue)

dat <- tibble(
  rel_1 = LETTERS[1:3],
  rel_2 = letters[1:3],
  irr_1 = 1:3,
  irr_2 = 101:103
)

ui <- fluidPage(
  fluidRow(
    column(
      width = 4,
      actionButton("chng_all", "Change All Columns")
    ),
    column(
      width = 4,
      actionButton("chng_irr", "Change Irrelevant Columns")
    ),
    column(
      width = 4,
      actionButton("chng_rel", "Change Relevant Columns")
    )
  ),
  fluidRow(
    column(
      width = 12,
      DTOutput("tbl")
    )    
  ),
  fluidRow(
    column(
      width = 12,
      verbatimTextOutput("dbg")
    )    
  )
)

server <- function(input, output, session) {
  my_data <- reactiveVal(dat)
  
  change_values <- function(data, cols) {
    data %>% 
      mutate(
        across(all_of(cols),
               ~ if (is.numeric(.x)) sample(100, 3) else sample(LETTERS, 3))
      )
  }
  
  # 初始化reactiveVal存储相关列内容
  relevant_data <- reactiveVal(dat %>% select(starts_with("rel")))
  
  # 监听my_data变化，仅当相关列内容改变时更新relevant_data
  observe({
    current_rel <- my_data() %>% select(starts_with("rel"))
    # 用identical严格比较数据框内容是否一致
    if (!identical(current_rel, relevant_data())) {
      relevant_data(current_rel)
    }
  })
  
  observe({
    my_data(change_values(my_data(), c(paste0("irr_", 1:2),
                                       paste0("rel_", 1:2))))
  }) %>% 
    bindEvent(input$chng_all)
  
  observe({
    my_data(change_values(my_data(), paste0("irr_", 1:2)))
  }) %>% 
    bindEvent(input$chng_irr)
  
  observe({
    my_data(change_values(my_data(), paste0("rel_", 1:2)))
  }) %>% 
    bindEvent(input$chng_rel)
  
  output$tbl <- renderDT(
    datatable(my_data())
  )
  
  output$dbg <- renderPrint({
    glue("Relevant Data Last Changed: {Sys.time()}")
  }) %>% 
    bindEvent(relevant_data())
  
}

shinyApp(ui, server)

关键改动说明 #

• 将原来的reactive()对象替换为reactiveVal，用于存储相关列的当前状态
• 添加观察者监听my_data的变化，用identical()严格比较当前相关列与reactiveVal中存储的值，仅当内容不同时更新reactiveVal
• 绑定输出的逻辑保持不变，现在只会在相关列真的变化时触发刷新

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