Как заставить связанные элементы выбора пользовательского интерфейса на стороне сервера в приложении R Shiny?

Question

У меня есть приложение R Shiny с двумя селекторами пользовательского интерфейса, каждый из которых имеет большой список элементов Я знаю, как сделать серверный элемент для одного элемента. Но как сделать два связанных элемента selectInput на стороне сервера. Таким образом, когда существует изменение в одном элементе - другой должен отражать соответственно.

Пример.

1. Первый список содержит 97 310 элементов.

2. Второй список должен иметь:

2,1. для 1-го элемента "Aaban" - 2 связанных значения (10, 11)

2,2. для 2-го элемента "Aabha" - 1 относительное значение (12)

2,3. для 3-го элемента "Aabid" - 3 связанных значения (13, 14, 15)

Вот код R.

library(shiny)
library(dplyr)
library(babynames)

# 1. Data sets

# 1.1. First data set (list)
list_names <- babynames::babynames %>% 
  distinct(name) %>%
  pull(name) %>%
  sort()

# 1.2. Second data set (data frame) for 3 first 'names' elements
df_ages <- data.frame(
  name = c("Aaban", "Aaban", "Aabha", "Aabid", "Aabid", "Aabid"),
  age  = c(10, 11, 12, 13, 14, 15))

# 2. UI
ui <- fluidPage(
  fluidRow(selectInput("si_name", "Name", multiple = FALSE, choices = character(0))),
  fluidRow(selectInput("si_age", "Age", multiple = FALSE, choices = character(0))))

# 3. Server
server <- function(input, output, session) {
  updateSelectizeInput(session, "si_name", choices = list_names, server = TRUE)
  updateSelectizeInput(session, "si_age", choices = df_ages$age, server = TRUE)
}

# 4. App
shinyApp(ui, server)

Спасибо!

Answer 1

Я думаю, что вы хотите:

# 2. UI
ui <- fluidPage(
  fluidRow(selectInput("si_name", "Name", multiple = FALSE, 
                       choices = unique(df_ages$name))),
  fluidRow(selectInput("si_age", "Age", multiple = FALSE, choices = character(0)))
)

# 3. Server
server <- function(input, output, session) {

  observeEvent(input$si_name, {
    ages <- df_ages[df_ages$name == input$si_name, "age"]
    updateSelectizeInput(session, "si_age", choices = ages, server = TRUE)
  })

}