如何要求 R Shiny 创建多个"select boxes" - 基于以前的输入

Question

在我的小闪亮应用程序中，我问用户：你想把你的时间序列切成多少个时间段？例如，用户选择 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)

Answer 1

这类似于我提出的一个问题，随后在这里找到了答案。最大的变化(可以预见)在服务器中。

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

服务器函数有几个附加功能，我将首先描述，然后在最后放在一起。你是对的，你需要在renderUI内创建一个输入对象列表，你可以通过lapply来完成。在此步骤中，您将创建与切割点一样多的selectInput，减去一个，因为您说不需要最后一个：

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)

Answer 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)

由于您没有提供用于应用输入的数据集，并且我不知道您的数据具有哪些日期范围，因此我没有添加代码来在日期选择器上设置 min/max，并且不确定提供哪种代码供您使用数据。你确实需要写一些东西来将它们放在列表中

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_periodsnrif(input$num_periodsnr > values$previous_max){}的跑圈enter code here的技巧，以避免在为同一inputelement重复创建observers时产生的问题。在循环中创建元素时ui元素会被覆盖，而observeEvents元素是作为副本创建的，因此每次循环触发时，您都会创建另一个observers1:n副本。这会导致每次都会触发所有副本，直到您有一百万observers全部触发，从而产生可能出现的奇怪错误、不良影响和速度损失。