Javascript 展开/折叠选择输入函数

我想找到一个资源，使我的selectInput函数能够根据我创建的类别标题展开/折叠。我已经搜索了一些引导资源，但尚未成功。请原谅我的最小工作示例，我承认可能有更有效的方法来提供MWE。谢谢你提供的任何建议

library(shiny)
library(tidyverse)
#create a quick dataset to plot
schools <-  as.data.frame(table(
    c('Adams', 'Van Buren', 'Clinton', 'Douglas', 'Edwards', 
              'Franklin', 'Grant', 'Harrison', 'Ignatius', 'Justice', 
              'Kellogg', 'Lincoln'), 
    dnn = list("school")))

enrollment <- as.data.frame(table(
    c(300, 305, 265, 400, 500, 450, 475, 900, 800, 850, 1200, 1500), 
    dnn = list("enrollment")))

schoolsDataframe <- schools %>% 
    bind_cols(enrollment) %>% 
    select(school, enrollment)

#define data elements for selectInput choices argument
elem <- c('Adams', 'Van Buren', 'Clinton', 'Douglas')
mid <- c('Edwards', 'Franklin', 'Grant')
high <- c('Harrison', 'Ignatius', 'Justice')
multi <- c('Kellogg', 'Lincoln')

# Define UI 
ui <- fluidPage(
    tags$style(".optgroup-header { color: #FFFFFF !important; background: #000000 !important; }"),
    # Application title
    titlePanel("Expandable selectInput"),

    # Sidebar with a select input
    sidebarLayout(
        sidebarPanel(
            selectInput(inputId = 'schoolsInput',
                        label = 'Select a school',
                        choices = list('Elementary' = elem, 
                                       'Middle' = mid, 
                                       'High' = high, 
                                       'Multi-level' = multi), 
                        selectize = TRUE)
        ),

        # Show a plot 
        mainPanel(
           plotOutput("myPlot")
        )
    )
)

# Define server logic required to draw a plot
server <- function(input, output) {

    output$myPlot <- renderPlot({
        #filter the data based on selectInput
schoolsDataframe <- schoolsDataframe %>% 
    filter(school == input$schoolsInput)
        # draw the plot
ggplot(data = schoolsDataframe, 
       mapping = aes(x = school, 
                     y = enrollment))+
    geom_col()
    })
}

# Run the application 
shinyApp(ui = ui, server = server)

库（闪亮）
图书馆（tidyverse）
#创建要打印的快速数据集
学校给你一个开始，尽管这可能不是你想要的。我认为您需要一个基于学校类型（小学、中学…）的动态选择列表。下面是一种方法，您可以使用两个选择列表来实现这一点，其中下一个是动态的，响应上一个选择列表中的选择

我还试图简化您的数据设置。您可以复制/粘贴代码以运行它

library(shiny)
library(tidyverse)

#define data elements 
schools <- data.frame (schoolName=  c('Adams', 'Van Buren', 'Clinton', 'Douglas', 'Edwards','Franklin', 'Grant', 'Harrison', 'Ignatius', 'Justice', 'Kellogg', 'Lincoln'),
                      schoolType = c('Elementary','Elementary','Elementary','Elementary','Middle','Middle','Middle','High','High','High','Multi-level','Multi-level'),
                      schoolEnrollment = c(300, 305, 265, 400, 500, 450, 475, 900, 800, 850, 1200, 1500))

# Define UI 
ui <- fluidPage(
  tags$style(".optgroup-header { color: #FFFFFF !important; background: #000000 !important; }"),
  # Application title
  titlePanel("Expandable selectInput"),

  # Sidebar with a select input
  sidebarLayout(
    sidebarPanel(
      selectInput(inputId = 'schoolType',
                  label = 'Select a School Type',
                  choices = list('Elementary',
                                 'Middle', 
                                 'High', 
                                 'Multi-level'), 
                  ),
      selectInput("schoolName", "Select School:","Elementary"),
    ),

    # Show a plot 
    mainPanel(
      plotOutput("myPlot")
    )
  )
)

# Define server logic required to draw a plot
server <- function(input, output, session) {

  # Set up the selection for counties
  observe ({
    selectionSchoolNames <- sort(unique(unlist(subset(schools$schoolName,schools$schoolType==input$schoolType))))
    updateSelectInput(session, "schoolName", choices = selectionSchoolNames)
  })

  output$myPlot <- renderPlot({
    #filter the data based on selectInput
    schoolsDataframe <- schools %>% 
      filter(schoolType == input$schoolType)
    # draw the plot
    ggplot(data = schoolsDataframe, 
           mapping = aes(x = schoolName, 
                         y = schoolEnrollment))+
      geom_col()
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

库（闪亮）
图书馆（tidyverse）
#定义数据元素
学校
图书馆（闪亮）
onInitialize来自Stéphane Laurent的答案非常棒，但它只在页面上有一个下拉列表时才起作用。如果您有多个下拉列表，下面是他的答案的一个稍加修改的版本，可用于多个输入：

library(shiny)

onInitialize <- '
$(function() {
  $("body").on("mousedown", ".selectize-dropdown-content", function(e){
    e.preventDefault(); 
    return false;
  }); 
  $("body").on("click", ".optgroup-header", function(){
    $(this).siblings().toggle();
  });
});'

onDropdownOpen <- '
function(el){
  setTimeout(function(){
    $(el).find(".optgroup .option").hide();
  }, 0);
}'

shinyApp(
  
  ui = fluidPage(
    tags$script(HTML(onInitialize)),
    selectizeInput("state", "Choose a state:",
                   list(`East Coast` = list("NY", "NJ", "CT"),
                        `West Coast` = list("WA", "OR", "CA"),
                        `Midwest` = list("MN", "WI", "IA")),
                   options = list(
                     onDropdownOpen = I(onDropdownOpen)
                   )
    ),
    textOutput("result"),
    selectizeInput("state2", "Choose a state:",
                   list(`East Coast` = list("NY", "NJ", "CT"),
                        `West Coast` = list("WA", "OR", "CA"),
                        `Midwest` = list("MN", "WI", "IA")),
                   options = list(
                     onDropdownOpen = I(onDropdownOpen)
                   )
    ),
    textOutput("result2")
  ),
  
  server = function(input, output) {
    output$result <- renderText({
      paste("You chose", input$state)
    })
    output$result2 <- renderText({
      paste("You chose", input$state2)
    })
  }
  
)

库（闪亮）
也许是初始化？谢谢你的评论，我查看了你提供的链接。我想知道如何从bsplus嵌入bs_手风琴，谢谢你提供了这个想法。
library(shiny)

onInitialize <- '
$(function() {
  $("body").on("mousedown", ".selectize-dropdown-content", function(e){
    e.preventDefault(); 
    return false;
  }); 
  $("body").on("click", ".optgroup-header", function(){
    $(this).siblings().toggle();
  });
});'

onDropdownOpen <- '
function(el){
  setTimeout(function(){
    $(el).find(".optgroup .option").hide();
  }, 0);
}'

shinyApp(
  
  ui = fluidPage(
    tags$script(HTML(onInitialize)),
    selectizeInput("state", "Choose a state:",
                   list(`East Coast` = list("NY", "NJ", "CT"),
                        `West Coast` = list("WA", "OR", "CA"),
                        `Midwest` = list("MN", "WI", "IA")),
                   options = list(
                     onDropdownOpen = I(onDropdownOpen)
                   )
    ),
    textOutput("result"),
    selectizeInput("state2", "Choose a state:",
                   list(`East Coast` = list("NY", "NJ", "CT"),
                        `West Coast` = list("WA", "OR", "CA"),
                        `Midwest` = list("MN", "WI", "IA")),
                   options = list(
                     onDropdownOpen = I(onDropdownOpen)
                   )
    ),
    textOutput("result2")
  ),
  
  server = function(input, output) {
    output$result <- renderText({
      paste("You chose", input$state)
    })
    output$result2 <- renderText({
      paste("You chose", input$state2)
    })
  }
  
)