如何要求 R Shiny 创建几个“选择框” - 基于先前的输入答案

【问题标题】：How to ask R Shiny to create several "select boxes" - based on previous input如何要求 R Shiny 创建几个“选择框” - 基于先前的输入
【发布时间】：2019-03-28 16:13:38
【问题描述】：

在我的小闪亮应用程序中，我问用户：你想把你的时间序列分成多少个时间段？例如，用户选择 3。我想使用此输入来获取固定的日期向量，并使用户可以从中选择时间段 1（在选择框 1 中）和时间段 2（在选择框 2 中）的所需最后日期。（时间段 3 的最后一个日期将是最后一个日期，所以我不需要问）。

我不知道该怎么做。我明白，因为我事先不知道所需的时间段数，所以我必须创建一个列表。但是我如何从这些选择框中收集输入？

非常感谢！

library(shiny)

### UI #######################################################################

ui = shinyUI(fluidPage(

  titlePanel("Defining time periods"),

  # Sidebar: 
  sidebarLayout(
    sidebarPanel(
      # Slider input for the number of time periods:
      numericInput("num_periodsnr", label = "Desired number of time periods?",
                  min = 1, max = 10, value = 2),
      uiOutput("period_cutpoints")
    ),


    # Show just the number of periods so far.
    mainPanel(
      textOutput("nr_of_periods")
    )
  )
))



### SERVER ##################################################################

server = shinyServer(function(input, output, session) {

  library(lubridate)

  output$nr_of_periods <- renderPrint(input$num_periodsnr)

    # Define our dates vector:
  dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')


  # STUCK HERE:
  # output$period_cutpoints<-renderUI({
  #   list.out <- list()
  #   for (i in 1:input$num_periodsnr) {
  #     list.out[[i]] <- renderPrint(paste0("Sometext", i), ,
  #                                  )
  #   }
  #   return(list.out)
  # })

})

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

【问题讨论】：

标签： r shiny

【解决方案1】：

这类似于我提出的一个问题，随后我回答了here。大的变化（可以预见）在服务器中。

UI 中无需更改任何内容，但正如您将在下面看到的，我添加了另一个 textOutput 以便您可以看到最终选择的日期，我还添加了一个 actionButton，它我稍后会解释。

服务器功能有几个附加功能，我将首先描述它们，然后放在最后。没错，您需要在renderUI 中创建一个输入对象列表，您可以通过lapply 来完成。在这一步，您将创建尽可能多的selectInputs，因为您说不需要最后一个，所以减去一个：

output$period_cutpoints<-renderUI({
    req(input$num_periodsnr)
    lapply(1:(input$num_periodsnr-1), function(i) {
      selectInput(inputId=paste0("cutpoint",i), 
                  label=paste0("Select cutpoint for Time Period ", i, ":"),
                  choices=dates)
    })
  })

接下来，您需要访问在每个选项中选择的值，您可以使用您首先创建的 reactiveValues 对象以相同的方式执行此操作，并将新值分配给它。在我的这个问题的版本中，我不知道如何在不使用actionButton 触发列表的情况下更新列表。简单的reactive() 或observe() 不起作用，但我真的不知道为什么。

seldates <- reactiveValues(x=NULL)
  observeEvent(input$submit, {
    seldates$x <- list()
    lapply(1:(input$num_periodsnr-1), function(i) { 
      seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
    })
  })

完整的工作应用代码如下所示：

library(shiny)

ui = shinyUI(fluidPage(

  titlePanel("Defining time periods"),

  sidebarLayout(
    sidebarPanel(
      numericInput("num_periodsnr", label = "Desired number of time periods?",
                   min = 1, max = 10, value = 2),
      uiOutput("period_cutpoints"),
      actionButton("submit", "Submit")
    ),
    mainPanel(
      textOutput("nr_of_periods"),
      textOutput("cutpoints")
    )
  )
))

server = shinyServer(function(input, output, session) {

  library(lubridate)

  output$nr_of_periods <- renderPrint(input$num_periodsnr)

  dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')

  output$period_cutpoints<-renderUI({
    req(input$num_periodsnr)
    lapply(1:(input$num_periodsnr-1), function(i) {
      selectInput(inputId=paste0("cutpoint",i), 
                  label=paste0("Select cutpoint for Time Period ", i, ":"),
                  choices=dates)
    })
  })

  seldates <- reactiveValues(x=NULL)
  observeEvent(input$submit, {
    seldates$x <- list()
    lapply(1:(input$num_periodsnr-1), function(i) { 
      seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
    })
  })

  output$cutpoints <- renderText({as.character(seldates$x)})
})

shinyApp(ui = ui, server = server)

【讨论】：

非常感谢您的精彩解释！

【解决方案2】：

您可以在 lapply 内动态制作这些框并将它们作为 1 个输出对象发送到 ui

require("shiny")
require('shinyWidgets')

ui = shinyUI(fluidPage(

  titlePanel("Defining time periods"),

  # Sidebar: 
  sidebarLayout(
    sidebarPanel(
      # Slider input for the number of time periods:
      numericInput("num_periodsnr", label = "Desired number of time periods?",
                   min = 1, max = 10, value = 2),
      uiOutput("period_cutpoints")
    ),


    # Show just the number of periods so far.
    mainPanel(
      textOutput("nr_of_periods")
    )
  )
))


# Define server logic ----
server <- function(session, input, output) {

  output$period_cutpoints<- renderUI({
    req(input$num_periodsnr > 0)
    lapply(1:input$num_periodsnr, function(el) {
      airDatepickerInput(inputId = paste('PeriodEnd', el, sep = ''), label = paste('Period End', el, sep = ' '), clearButton = TRUE, range = F, update_on = 'close')
    })
})

}

# Run the app ----
shinyApp(ui = ui, server = server)

由于您没有提供数据集来应用输入，而且我不知道您的数据有哪些日期范围，所以我没有添加代码来设置日期选择器上的最小值/最大值，并且不确定是什么类型的为您提供使用数据的代码。您确实需要写一些东西才能将它们放入列表中

values <- reactiveValues(datesplits = list(), 
previous_max = 0)

observeEvent(input$num_periodsnr, { 
  if(input$num_periodsnr > values$previous_max) {
    lapply(values$previous_max:input$num_periodsnr, function(el) { 
      observeEvent(input[[paste(paste('PeriodEnd', el, sep = '')]], {
        values$datesplits[el] <- input[[paste(paste('PeriodEnd', el, sep = '')]]
      })

    values$previous_max <- max(values$previous_max, input$num_periodsnr)
    })
  }
})

然后将日期列表用于我认为您需要对它们做的任何事情。

我使用从 previous_max 到 input$num_periodsnr if(input$num_periodsnr > values$previous_max){} 运行 lapenter code hereply 的技巧来避免在为相同的 input element 重复创建 observers 时创建的问题。 ui 元素在循环中创建时会被覆盖，observeEvents 是作为副本制作的，因此每次循环触发时，您都会制作另一个 observers 1:n 的副本。这会导致每次都触发所有副本，直到您有 100 万个 observers 全部触发，这可能会产生奇怪的错误、不需要的效果和速度损失。

【讨论】：