如何让R Shiny创建几个“选择框” - 基于之前的输入

问题描述 投票：0回答：2

在我的小型Shiny应用程序中，我问用户：您希望将时间序列缩短到多少个时间段？例如，用户选择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)
shiny
2个回答
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)
1
投票

你可以在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)
    })
  }
})

然后使用日期列表，我想你需要做些什么。

我使用从enter code here运行lapprevious_maxply到input$num_periodsnr if(input$num_periodsnr > values$previous_max){}的技巧，以避免你为同一个observers input重复创建element时创建的问题。当ui元素在循环中创建时被覆盖，而observeEvents被制作为副本，因此每次你的循环触发时，你都会制作observers 1:n的另一个副本。这导致所有副本每次都会发射，直到你有一百万个observers全部射击，造成可能的奇怪错误，不必要的效果和速度损失。

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.