shiny：仅依赖于列的子集

Question

假设我有一个

reactive

，它返回一个

data.frame

。我希望我的一些控件仅依赖于其列的子集，也就是说，只有在任何“相关”列（此处为

rel_1

和

rel_2

）中的值发生变化时，它才应该触发，而“不相关”列（此处为

irr_1

和

irr_2

）不应触发刷新。

我认为创建一个仅返回相关列的

reactive

应该可以解决问题，但以下代码显示所有按钮都会触发

verbatimTextOutput

的刷新。我的期望是按“更改不相关列”不会触发刷新，因为相关列中的值保持不变。

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))
      )
  }
  
  relevant_data <- reactive(
    my_data() %>% 
      select(starts_with("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)

Answer 1

reactiveVal

代替

reactive

来实现所需的行为：

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))
      )
  }
  
  relevant_data <- reactiveVal()
  
  observe({relevant_data(
    my_data() %>% 
      select(starts_with("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)

Winston Chang对此的解释

这里

如下：

简而言之：失效从反应值开始，并且“推动” 下游的所有后代立即失效。但执行 反应从另一端开始。在冲洗周期中，观察者 “拉”它们的输入值，仅在以下情况下执行上游反应 必要的。

另请参阅

this

相关博客文章。