R Shiny子级筛选自动填充：禁用SelectInput或替代方案咨询

针对你的需求，有两种可行的实现方式：

方式一：禁用SelectInput的选择功能 #

通过shinyjs将project_sublevel的下拉框设置为禁用状态，用户无法手动选择，但它的inputId依然可以被读取用于数据筛选，同时保持自动更新的逻辑不变。

修改后的完整代码 #

library(tidyverse)
library(plotly)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)


full_data <- tibble(
  Project_Level = c(0,1,1,2,2,2,2, 0,1,1,2,2,2,2),
  Project_Sublevel = c(1,2,2,3,3,3,3, 1,2,2,3,3,3,3),
  Project_Type = c("House", "Bedrooms", "Bathrooms", "Bed", "Closet", "Toliet", "Shower",
                   "House", "Bedrooms", "Bathrooms", "Bed", "Closet", "Toliet", "Shower"),
  Project_Scope = c("None", "House", "House", "Bedrooms", "Bedrooms", "Bathrooms", "Bathrooms",
                    "None", "House", "House", "Bedrooms", "Bedrooms", "Bathrooms", "Bathrooms"),
  Year = c("2008", "2008", "2008", "2008", "2008", "2008", "2008",
           "2009", "2009", "2009", "2009", "2009", "2009", "2009"),
  Cost = c(1000, 500, 500, 250, 250, 250, 250, 
           2000, 1000, 1000, 500, 500, 500, 500)
)


ui <- fluidPage(
  useShinyjs(),
  selectInput(
    inputId = "year",
    label = "Year",
    multiple = TRUE,
    choices = unique(full_data$Year),
    selected = unique(full_data$Year)
  ),
  selectInput(
    inputId = "project_level",
    label = "Project Level",
    multiple = FALSE,
    choices = unique(full_data$Project_Level),
    selected = "0"
  ),
  selectInput(
    inputId = "project_sublevel",
    label = "Project Sub-Level",
    multiple = FALSE,
    choices = unique(full_data$Project_Sublevel)
  ),
  plotlyOutput("housing_cost", height = 400),
  shinyjs::hidden(actionButton("clear", "Return to Project Level"))
)


server <- function(input, output, session) {
  # 初始化时禁用子级下拉框
  shinyjs::disable("project_sublevel")
  
  observeEvent(input$project_level, {
    if (input$project_level == "<select>") {
      choice <- ""
    } else {
      choice <- as.numeric(input$project_level) + 1
    }
    updateSelectInput(
      session = session,
      inputId = "project_sublevel",
      choices = choice,
      selected = choice
    )
    # 更新后维持禁用状态
    shinyjs::disable("project_sublevel")
  })
  

  drills <- reactiveValues(category = NULL,
                           sub_category = NULL)
  

  house_reactive <- reactive({
    full_data %>%
      filter(Year %in% input$year) %>%
      filter(Project_Level %in% input$project_level)
  })
  

  house_reactive_2 <- reactive({
    full_data %>%
      filter(Year %in% input$year) %>%
      filter(Project_Level %in% input$project_sublevel) %>%
      filter(Project_Scope %in% drills$category)
  })
  

  house_data <- reactive({
    if (is.null(drills$category)) {
      return(house_reactive())
    }
    else {
      return(house_reactive_2())
    }
  })
  

  output$housing_cost <- renderPlotly({
    if (is.null(drills$category)) {
      plot_title <- paste0("Cost of Project Level Components")
    } else {
      plot_title <- paste0("Cost of ",  drills$category)
    }
    

    house_data() %>%
      plot_ly(
        x = ~ Year,
        y = ~ Cost,
        color = ~ Project_Type,
        key = ~ Project_Type,
        source = "housing_cost",
        type = "bar"
      ) %>%
      layout(
        barmode = "stack",
        showlegend = T,
        xaxis = list(title = "Year"),
        yaxis = list(title = "Cost"),
        title = plot_title
      )
  })
  

  observeEvent(event_data("plotly_click", source = "housing_cost"), {
    x <- event_data("plotly_click", source = "housing_cost")$key
    if (is.null(x))
      return(NULL)
    if (is.null(drills$category)) {
      drills$category <- unlist(x)
    }  else {
      drills$sub_category <- NULL
    }
  })
  

  observe({
    if (!is.null(drills$category)) {
      shinyjs::show("clear")
    }
  })
  

  observeEvent(c(input$clear, input$project_level), {
    drills$category <- NULL
    shinyjs::hide("clear")
  })
}


shinyApp(ui, server)

方式二：用文本输出替代SelectInput #

将原有的SelectInput替换为verbatimTextOutput（或textOutput）展示子级值，同时用reactiveVal存储该值，作为数据筛选的依据。这种方式完全隐藏输入控件，只展示结果。

修改后的完整代码 #

library(tidyverse)
library(plotly)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)


full_data <- tibble(
  Project_Level = c(0,1,1,2,2,2,2, 0,1,1,2,2,2,2),
  Project_Sublevel = c(1,2,2,3,3,3,3, 1,2,2,3,3,3,3),
  Project_Type = c("House", "Bedrooms", "Bathrooms", "Bed", "Closet", "Toliet", "Shower",
                   "House", "Bedrooms", "Bathrooms", "Bed", "Closet", "Toliet", "Shower"),
  Project_Scope = c("None", "House", "House", "Bedrooms", "Bedrooms", "Bathrooms", "Bathrooms",
                    "None", "House", "House", "Bedrooms", "Bedrooms", "Bathrooms", "Bathrooms"),
  Year = c("2008", "2008", "2008", "2008", "2008", "2008", "2008",
           "2009", "2009", "2009", "2009", "2009", "2009", "2009"),
  Cost = c(1000, 500, 500, 250, 250, 250, 250, 
           2000, 1000, 1000, 500, 500, 500, 500)
)


ui <- fluidPage(
  useShinyjs(),
  selectInput(
    inputId = "year",
    label = "Year",
    multiple = TRUE,
    choices = unique(full_data$Year),
    selected = unique(full_data$Year)
  ),
  selectInput(
    inputId = "project_level",
    label = "Project Level",
    multiple = FALSE,
    choices = unique(full_data$Project_Level),
    selected = "0"
  ),
  # 替换为文本输出组件
  tags$div(
    tags$label("Project Sub-Level"),
    verbatimTextOutput("project_sublevel_display")
  ),
  plotlyOutput("housing_cost", height = 400),
  shinyjs::hidden(actionButton("clear", "Return to Project Level"))
)


server <- function(input, output, session) {
  # 用reactiveVal存储子级值，作为筛选依据
  project_sublevel_val <- reactiveVal()
  
  observeEvent(input$project_level, {
    if (input$project_level == "<select>") {
      choice <- ""
    } else {
      choice <- as.numeric(input$project_level) + 1
    }
    project_sublevel_val(choice)
  })
  
  # 渲染子级文本内容
  output$project_sublevel_display <- renderPrint({
    project_sublevel_val()
  })
  

  drills <- reactiveValues(category = NULL,
                           sub_category = NULL)
  

  house_reactive <- reactive({
    full_data %>%
      filter(Year %in% input$year) %>%
      filter(Project_Level %in% input$project_level)
  })
  

  house_reactive_2 <- reactive({
    full_data %>%
      filter(Year %in% input$year) %>%
      # 使用reactiveVal存储的值进行筛选
      filter(Project_Level %in% project_sublevel_val()) %>%
      filter(Project_Scope %in% drills$category)
  })
  

  house_data <- reactive({
    if (is.null(drills$category)) {
      return(house_reactive())
    }
    else {
      return(house_reactive_2())
    }
  })
  

  output$housing_cost <- renderPlotly({
    if (is.null(drills$category)) {
      plot_title <- paste0("Cost of Project Level Components")
    } else {
      plot_title <- paste0("Cost of ",  drills$category)
    }
    

    house_data() %>%
      plot_ly(
        x = ~ Year,
        y = ~ Cost,
        color = ~ Project_Type,
        key = ~ Project_Type,
        source = "housing_cost",
        type = "bar"
      ) %>%
      layout(
        barmode = "stack",
        showlegend = T,
        xaxis = list(title = "Year"),
        yaxis = list(title = "Cost"),
        title = plot_title
      )
  })
  

  observeEvent(event_data("plotly_click", source = "housing_cost"), {
    x <- event_data("plotly_click", source = "housing_cost")$key
    if (is.null(x))
      return(NULL)
    if (is.null(drills$category)) {
      drills$category <- unlist(x)
    }  else {
      drills$sub_category <- NULL
    }
  })
  

  observe({
    if (!is.null(drills$category)) {
      shinyjs::show("clear")
    }
  })
  

  observeEvent(c(input$clear, input$project_level), {
    drills$category <- NULL
    shinyjs::hide("clear")
  })
}


shinyApp(ui, server)

说明 #

• 方式一保留了下拉框的视觉样式，但用户无法交互，适合需要保持界面布局一致性的场景。
• 方式二完全用文本展示，更简洁，适合不需要输入控件样式的场景。两种方式都能实现根据主级自动更新子级，且子级值可用于数据筛选的需求。

内容的提问来源于stack exchange，提问作者Harry Kalsted