Как попросить R Shiny создать несколько «блоков выбора» - на основе предыдущего ввода

Question

В моем крошечном приложении 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)

Answer 1

вы можете динамически создавать коробки внутри лапы и отправлять их как 1 выходной объект в пользовательский интерфейс

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 ply от previous_max до input$num_periodsnr if(input$num_periodsnr > values$previous_max){}, чтобы избежать проблемы, которую вы создаете при повторном создании observers для одного и того же input element. В то время как ui элементы перезаписываются при создании в цикле, observeEvents создаются как копии, поэтому каждый раз, когда запускается ваш цикл, вы делаете еще одну копию observers 1:n. Это приводит к тому, что все копии будут срабатывать каждый раз, пока у вас не будет миллиона observers всех запусков, создавая возможные странные ошибки, нежелательные эффекты и потерю скорости.

Answer 2

Это похоже на вопрос, который я задал и впоследствии разработал ответ на здесь .Большие изменения (как и ожидалось) происходят на сервере.

Ничего не нужно менять в пользовательском интерфейсе, но, как вы увидите ниже, я включил еще один textOutput, чтобы вы могли видеть даты, которые вы в конечном итогевыбрав, и я также добавил actionButton, который я объясню позже.

У функции сервера есть пара дополнений, которые я сначала опишу, а затем соберу в конце.Вы правы, что вам нужно создать список входных объектов внутри renderUI, что вы можете сделать с помощью lapply.На этом шаге вы создаете столько selectInput s, сколько у вас будет точек отсечения, минус один, потому что вы говорите, что вам не нужно последнее:

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)