如何在不使用观察者的情况下观察触发事件并在 R Shiny 中应用条件？

Question

在运行下面的 R Shiny 代码时，用户更改

sliderInput()

（对象

input$periods

）会重置所有称为“X/Y 子表”的变量用户输入表，如代码中所示，并在

lapply() 之前添加注释

生成它们的块，如下图所示。请注意，这些 X/Y 子表反应性地从父表接收值

base_input

也在代码中进行了注释，如下图所示。反应性必须始终流动，并且更改

base_input

值始终正确地完全重置适用的链接 X/Y 子表。

这个想法是消除 X/Y 子表中 X 列值 > 新值

input$periods

的任何行，同时保留父子反应流。

注释后的代码块

# Observe changes to input$periods and print revised X/Y child tables

部分通过对象

reviseTable

让我到达那里。该代码部分删除了其列 X 值 > 修改后的

input$periods

值的所有数据帧行。如何用

lapply()

对象替换由生成 X/Y 表的

reviseTable

块生成的表，而不将该

lapply()

块包装在观察者中？用

observeEvent()

包裹可以停止需要维护的父子反应流。

input$periods

作为整个时间窗口的上限。 X 列中的变量表示更改变量 Y 的时间段。因此 X 必须始终 <=

input$periods

。

代码：

library(shiny)
library(rhandsontable)

ui <- fluidPage(
  sliderInput("periods", "Time window (W):", min = 1, max = 10, value = 5),
  h5(strong("Variable (Y) over window (W):")),
  rHandsontableOutput("base_input"),  
  uiOutput("Vectors")
)

server <- function(input, output, session) {
  numVars <- 2  
  varValues <- lapply(1:numVars, function(i) {reactiveValues(data = 20)})
  
  # Parent table "base_input"
  output$base_input <- renderRHandsontable({
    rhandsontable(
      data.frame(Inputs = sapply(varValues, function(x) x$data)),
      readOnly = FALSE,
      colHeaders = c('Inputs'),
      rowHeaders = paste0("Var ", LETTERS[1:numVars]),
      contextMenu = FALSE
    )
  })
  
  observeEvent(input$base_input, {
    newValues <- hot_to_r(input$base_input)$Inputs
    for (i in 1:numVars) {
      varValues[[i]]$data <- newValues[i]
    }
  })
  
  # Observe changes to input$periods and print revised X/Y child tables
  observeEvent(input$periods, {
    for (i in 1:numVars) {
      varInputId <- paste0("var_", i, "_input")
      reviseTable <- hot_to_r(input[[varInputId]])
      reviseTable <- subset(reviseTable, X <= input$periods)
      print(paste("Revised X/Y table for Var", LETTERS[i], "after updating input$periods:"))
      print(reviseTable)
    }
  }, ignoreInit = TRUE)  
  
  # Builds X/Y child tables
  lapply(1:numVars, function(i) {
    varInputId <- paste0("var_", i, "_input")
    output[[varInputId]] <- renderRHandsontable({
      df <- data.frame(X = 1, Y = varValues[[i]]$data)
      rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
        hot_validate_numeric(col = 1, min = 1, max = input$periods)
    })
  })
  
  output$Vectors <- renderUI({
    lapply(1:numVars, function(i) {
      varInputId <- paste0("var_", i, "_input")
      list(
        h5(strong(paste("Adjust Var ", LETTERS[i], " (Y) at time X:"))),
        rHandsontableOutput(varInputId)
      )
    })
  })
  
}

shinyApp(ui, server)

Answer 1

看起来工作正常：

library(shiny)
library(rhandsontable)
library(htmlwidgets)

js <- "function(el, x) {
  var hot = this.hot;
  Shiny.addCustomMessageHandler('removeRows', function(indices) {
    for(var i of indices) {
      hot.alter('remove_row', i, 1);
    }
  });
}"

ui <- fluidPage(
  sliderInput("periods", "Time window (W):", min = 1, max = 10, value = 5),
  h5(strong("Variable (Y) over window (W):")),
  rHandsontableOutput("base_input"),  
  uiOutput("Vectors")
)

server <- function(input, output, session) {
  numVars <- 2  
  varValues <- lapply(1:numVars, function(i) {reactiveValues(data = 20)})
  
  # Parent table "base_input"
  output$base_input <- renderRHandsontable({
    rhandsontable(
      data.frame(Inputs = sapply(varValues, function(x) x$data)),
      readOnly = FALSE,
      colHeaders = c('Inputs'),
      rowHeaders = paste0("Var ", LETTERS[1:numVars]),
      contextMenu = FALSE
    )
  })
  
  observeEvent(input$base_input, {
    newValues <- hot_to_r(input$base_input)$Inputs
    for (i in 1:numVars) {
      varValues[[i]]$data <- newValues[i]
    }
  })
  
  # Observe changes to input$periods and remove rows
  observeEvent(input$periods, {
    for (i in 1:numVars) {
      varInputId <- paste0("var_", i, "_input")
      reviseTable <- hot_to_r(input[[varInputId]])
      toRemove <- which(reviseTable$X > input$periods)
      if(length(toRemove)) {
        session$sendCustomMessage("removeRows", as.list(rev(toRemove) - 1))
      }
    }
  }, ignoreInit = TRUE)  
  
  # Builds X/Y child tables
  lapply(1:numVars, function(i) {
    varInputId <- paste0("var_", i, "_input")
    output[[varInputId]] <- renderRHandsontable({
      df <- data.frame(X = 1, Y = varValues[[i]]$data)
      rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
        hot_validate_numeric(col = 1, min = 1, max = input$periods) %>% 
        onRender(js)
    })
  })
  
  output$Vectors <- renderUI({
    lapply(1:numVars, function(i) {
      varInputId <- paste0("var_", i, "_input")
      list(
        h5(strong(paste("Adjust Var ", LETTERS[i], " (Y) at time X:"))),
        rHandsontableOutput(varInputId)
      )
    })
  })
  
}

shinyApp(ui, server)