我想找到一个资源,该资源将允许我的Shiny 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)
答案 0 :(得分:3)
library(shiny)
onInitialize <- '
function(){
this.$dropdown_content.on("mousedown", function(e){
e.preventDefault();
return false;
});
$("body").on("click", ".optgroup-header", function(){
$(this).siblings().toggle();
});
}'
onDropdownOpen <- '
function(){
setTimeout(function(){
$(".optgroup .option").hide();
}, 0);
}'
shinyApp(
ui = fluidPage(
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(
onInitialize = I(onInitialize),
onDropdownOpen = I(onDropdownOpen)
)
),
textOutput("result")
),
server = function(input, output) {
output$result <- renderText({
paste("You chose", input$state)
})
}
)
答案 1 :(得分:2)
史蒂芬·洛朗(StéphaneLaurent)的回答非常棒,但仅在页面上有一个下拉菜单时,此方法才有效。如果您有多个下拉菜单,以下是他的答案的略微修改版本,可用于多种输入:
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)
})
}
)
答案 2 :(得分:1)
这可能是您的一个开始,尽管可能并非您想要的那样。我认为您需要一个基于学校类型(小学,中学...)的动态选择列表。您可以使用以下方法通过2个选择列表进行操作,其中下一个是动态的,以响应上选择列表中的选择。
我还试图简化您的数据设置。您可以复制/粘贴代码以运行它。
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)