Реактивный выбор входа для обновления таблицы

Question

Я пытаюсь понять реактивную часть в R блестящий.В этом процессе я пытаюсь обновить таблицу вывода на основе изменения ввода при выборе значений из раскрывающегося списка возраста.Кажется, это происходит по первому значению, но когда я изменяю любое значение из выпадающего списка возраста, моя таблица не обновляется.Я использую ввод chooseage.Ниже приведен код, который я использую.

library(shiny)
library(shinydashboard)
library(shinyBS)
library(knitr)
library(kableExtra)
library(shiny)
library(shinythemes)


ui <- dashboardPage(
  dashboardHeader(disable = F, title = "PATH Study"),
  dashboardSidebar(sidebarMenu(
    menuItem(
      "Population Filter",
      uiOutput("choose_age")
    )
  )),
  dashboardBody(box(
    width = 12,
    tabBox(
      width = 12,
      id = "tabBox_next_previous",
      tabPanel("Initiation",
               fluidRow(
                 box(
                   width = 5,
                   solidHeader = TRUE,
                   status = "primary",
                   tableOutput("smoke"),
                   collapsible = F
                 )
               ))
      
    ),
    uiOutput("Next_Previous")
  ))
)
server <- function(input, output, session) {
  # Drop-down selection box for which Age bracket to be selected
  age_levels <- c("18 to 24 years old","25 to 34 years old","35 to 44 years old")
  
  output$choose_age <- renderUI({
    selectInput("selected_age", "Age", as.list(age_levels))
  })
  myData <- reactive({
    with_demo_vars %>%
      filter(age == input$choose_age) %>%
      pct_ever_user(type = "SM")
  })
  output$smoke <-
    renderTable({
      head(myData())
    })
  
}
shinyApp(ui = ui, server = server)

Answer 1

Я думаю, что у вас глянцевое приложение чрезмерно реактивное, так как все функции на сервере выполняются сразу, без ожидания какого-либо выбранного ввода.Так что либо он сломается, либо будет вести себя странно.Таким образом, вы должны отложить реактивность с помощью req(), validate() / need() или любой функции observeEvent или eventReactive().

Может быть, этот фрагмент может помочь вам, хотя было бы несколько способов добиться желаемого поведения.

library(shiny)
library(shinydashboard)
library(dplyr)

data(mtcars)
mtcars$age <- sample(x = c(10,20,30,40,50), size = nrow(mtcars), replace = T)
with_demo_vars <- mtcars

ui <- dashboardPage(
  dashboardHeader(disable = F, title = "PATH Study"),
  dashboardSidebar(sidebarMenu(
    menuItem(text = "Population Filter",
             uiOutput("choose_age")
    )
  )
  ),
  dashboardBody(
    tableOutput("smoke")
  )  
)

server <- function(input, output, session) {
  output$choose_age <- renderUI({
    selectInput("selected_age", "Age", with_demo_vars$age)
  })
  myData <- reactive({
    with_demo_vars %>%
      dplyr::filter(age == input$selected_age) 
  })
  output$smoke <- renderTable({
    req(input$selected_age)
    head(myData())
  })
}
shinyApp(ui = ui, server = server)

Answer 2

Вот быстрый прототип для вашей задачи

library(shiny)
library(tidyverse)
library(DT)

# 1. Dataset
df_demo <- data.frame(
  age = c(16, 17, 18, 19, 20),
  name = c("Peter", "Mary", "Mike", "Nick", "Phillipe"))

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

  # 1. UI element 'Age'
  output$ui_select_age <- renderUI({
    selectInput("si_age", "Age", df_demo$age)
  })

  # 2. Reactive data set
  df_data <- reactive({

    # 1. Read UI element
    age_selected <- input$si_age

    # 2. Filter data
    df <- df_demo %>%
      filter(age == age_selected)

    # 3. Return result
    df
  })

  # 3. Datatable
  output$dt_table <- renderDataTable({
      datatable(df_data())
  })

}

# 3. UI
ui <- fluidPage(
  fluidRow(uiOutput("ui_select_age")),
  fluidRow(dataTableOutput("dt_table"))
)


# 4. Run app
shinyApp(ui = ui, server = server)