如何使 selectInput 选择反应？

Question

在我的代码中，我使用了两个 selectInput() 函数：一个用于指示 start 周期以输入自定义函数，另一个用于指示 end 期间输入相同的自定义函数。底部是代码的简化 MWE 摘录，它不使用此自定义函数，而是使用 rbind() 加入并输出 to/from 数据以简单起见。在完整代码中，结束周期必须始终大于 (>) 自定义函数起作用的开始周期。

我如何让“收件人”(selectInput(inputId = "toPeriod"...) 中的选择仅反映那些值 > 而不是用户在“发件人”(selectInput(inputId = "fromPeriod") 函数中输入的值？

我意识到这需要使 to/from 输入选择反应，所以我开始使用 renderUI 将 selectInput() 函数移动到 server 部分，但我停止了当收到消息“警告：错误：filter() 输入 ..1 出现问题。”即使输出是正确的。无论如何，在将 selectInput() 函数移动到 server 部分之前和之后，这段代码似乎运行很慢。

这张图片更好地解释了：

还有其他帖子遇到同样的问题，但代码示例过于繁琐，或者 questions/answers 编写或解释不当：, R shiny passing reactive to selectInput choices, Vary the choices in selectinput based on other conditions in shiny R，等等

MWE 代码：

library(dplyr)
library(shiny)
library(tidyverse)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
  )

ui <- fluidPage(
  tableOutput("data"),
  uiOutput("fromPeriod"),
  uiOutput("toPeriod"),
  tableOutput("dataSelect")
)

server <- function(input, output) {
  
  output$fromPeriod <- renderUI({
    selectInput(inputId = "fromPeriod",label = "From period:",choices = unique(data$Period), selected = 1)
  })
  
  output$toPeriod <- renderUI({
    selectInput(inputId = "toPeriod",label = "To period:",choices = unique(data$Period), selected = 2)
  })
  
  output$data <- renderTable({data})
  
  output$dataSelect <- renderTable({
    part1 <- data %>% filter(Period == input$fromPeriod)
    part2 <- data %>% filter(Period == input$toPeriod)
    rbind(part1,part2)
  }, rownames = TRUE)
}

shinyApp(ui, server)

Answer 1

感谢您提出明确的问题和出色的最小示例。

您收到警告“警告：错误：filter() 输入问题 ..1。”因为在第一次加载时，fromPeriod 和 toPeriod 最初是 NULL。它们随后立即加载，因此您可以很好地看到结果。您可以通过将 req(input$fromPeriod) 添加到 renderTable({...}) 正文来阻止警告。

可以使用 updateSelectInput 更新 SelectInput。我们需要将它包装在 observe 语句中，以便它对 input$fromPeriod 中的变化做出反应。我在服务器主体的开头创建了一个变量 all_choices 以使代码更具可读性。

library(dplyr)
library(shiny)
library(tidyverse)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
  )

ui <- fluidPage(
  tableOutput("data"),
  uiOutput("fromPeriod"),
  uiOutput("toPeriod"),
  tableOutput("dataSelect")
)

server <- function(input, output, session) {
  all_choices <- unique(data$Period)
  
  output$fromPeriod <- renderUI({
    selectInput(inputId = "fromPeriod", label = "From period:", choices = unique(data$Period), selected = 1)
  })
  
  output$toPeriod <- renderUI({
    selectInput(inputId = "toPeriod", label = "To period:",choices = unique(data$Period), selected = 2)
  })
  
  observe({
    req(input$fromPeriod)
    
    new_choices <- all_choices[all_choices > as.numeric(input$fromPeriod)]
    updateSelectInput(session, inputId = "toPeriod", choices = new_choices, selected = min(new_choices))
  })
  
  output$data <- renderTable({data})
  
  output$dataSelect <- renderTable({
    req(input$fromPeriod)
    part1 <- data %>% filter(Period == input$fromPeriod)
    part2 <- data %>% filter(Period == input$toPeriod)
    rbind(part1,part2)
  }, rownames = TRUE)
}

shinyApp(ui, server)

Answer 2

您应该尽可能避免使用 renderUI 并使用 update* 函数 - 更新速度比 re-rendering:

library(shiny)
library(data.table)

DT <- data.table(
  ID = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
  Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
  Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9)
)

all_choices <- unique(DT$Period)

ui <- fluidPage(
  tableOutput("data"),
  selectizeInput(
    inputId = "fromPeriod",
    label = "From period:",
    choices = setdiff(all_choices, last(all_choices)),
    selected = 1
  ),
  selectizeInput(
    inputId = "toPeriod",
    label = "To period:",
    choices = setdiff(all_choices, first(all_choices)),
    selected = 2
  ),
  tableOutput("dataSelect")
)

server <- function(input, output, session) {
  output$data <- renderTable({
    DT
  })
  
  observeEvent(input$fromPeriod, {
    freezeReactiveValue(input, "toPeriod")
    updateSelectizeInput(
      session,
      inputId = "toPeriod",
      choices = all_choices[all_choices > input$fromPeriod],
      selected = max(all_choices[all_choices > input$fromPeriod])
    )
  }, ignoreInit = TRUE)
  
  output$dataSelect <- renderTable({
    # in one line, however you seem to need part1 / part2 for your custom function
    # setorder(DT[Period %in% c(input$fromPeriod, input$toPeriod)], Period)
    part1 <- DT[Period == input$fromPeriod]
    part2 <- DT[Period == input$toPeriod]
    rbindlist(list(part1, part2))
  }, rownames = TRUE)
}

shinyApp(ui, server)

为避免不必要地触发反应或输出，在 Mastering Shiny 中的 shiny. Please see this related chapter 中使用 update* 函数时，您几乎应该始终使用 freezeReactiveValue .

如何使 selectInput 选择反应？

How to make selectInput choices reactive?

r

shiny

shiny-reactivity

selectinput