Popovers are like small modals that appear when you click on an element, like an icon. Because they’re persistent, they’re great for a bit of extra information or a small number of additional controls, like plot settings.
Popovers pair well with buttons or icons, like those from bsicons or fontawesome. Just be certain to use recent versions of either package and to include a title attribute for accessibility.
The card_header() or card_footer() is a great place to put popovers, and you can use Bootstrap’s hstack feature and flex utility classes to help position the trigger element.
Tooltips are ephemeral bits of additional context. They work well when paired with an icon in the label of an input.
textInput(
inputId = "school_search",
label = tagList(
"Search for School",
tooltip(
bsicons::bs_icon("info-circle", title = "About search"),
"Regular expressions are not supported, sorry."
)
)
)card_header() and card_footer() are also great places to place tooltips. Again the .hstack Bootstrap class is helpful for organizing a row of icons.
card(
card_header(
class = "hstack justify-content-between",
"Cost vs. Earnings",
div(
class = "hstack gap-2",
popover(
bsicons::bs_icon("gear", title = "Settings"),
"Choose the grouping variable"
),
tooltip(
bsicons::bs_icon("info-circle", title = "Info"),
"You should probably know this by now, but..."
)
)
),
"Imagine a plot here."
) exercises/07_app.R
exercises/07_app.R
library(shiny)
library(bslib)
library(dplyr)
library(plotly)
library(collegeScorecard)
# Inputs ------------------------------------------------------------------
input_group_by <-
radioButtons(
"group_by",
"Group By",
choices = c(
"Campus Setting" = "locale_type",
"Highest Degree" = "deg_highest",
"Testing Requirements" = "adm_req_test"
)
)
# UI ----------------------------------------------------------------------
## Instructions:
## Use a `popover()` to hide the radio buttons until the user is ready for them.
## You can use `bsicon::bs_icon()` for the icon. Check out
## https://icons.getbootstrap.com/ for icon inspiration.
ui <- page_fillable(
title = "06 - Navset Cards",
input_group_by,
card(
card_header("Cost vs Earnings"),
plotlyOutput("plot_cost_earnings")
)
)
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
filter_recent_complete_year <- function(scorecard, column) {
academic_year <- scorecard[!is.na(scorecard[[column]]), ]$academic_year
scorecard |> filter(academic_year == !!max(academic_year))
}
plotly_cost_earnings <- function(group_by) {
scorecard |>
filter_recent_complete_year("amnt_earnings_med_10y") |>
left_join(school, by = "id") |>
plot_ly(
x = ~cost_avg,
y = ~amnt_earnings_med_10y,
color = ~get(group_by),
hoverinfo = "text",
text = ~paste0(
"School: ", name, "<br>",
"Undergrads: ", scales::number(n_undergrads, big.mark=","), "<br>",
"Average Cost: ", scales::dollar(cost_avg), "<br>",
"Median Earnigns: ", scales::dollar(amnt_earnings_med_10y), "<br>",
"Admissions Rate: ", scales::percent(rate_admissions), "<br>",
"Completion Rate: ", scales::percent(rate_completion)
)
) |>
layout(
xaxis = list(title = "Average Cost"),
yaxis = list(title = "Median Earnings"),
margin = list(l = 0, r = 0, b = 0)
) |>
config(displayModeBar = FALSE)
}
output$plot_cost_earnings <- renderPlotly({
plotly_cost_earnings(input$group_by)
})
}
shinyApp(ui, server)Looking back at our use of a navset card in the last exercise, we might be able to improve the design and user experience with a popover.
In exercises/07_app.R, I’ve reset the app to use a single plot output with a radio button input. Use a popover() to hide the radio buttons in a menu in the card header.
💡 Looking for icon inspiration? Check out Bootstrap icons.
Accordions are collapsible sections of content. They follow a similar pattern to navsets: an outer accordion() container holds a collection of one or more accordion_panel() elements.
accordion(
accordion_panel(
"Panel 1",
"Content for panel 1"
),
accordion_panel(
"Panel 2",
"Content for panel 2"
)
)Accordions are great for organizing a lot of content in a small space. They fit well in a sidebar!
Here are a few additional customizations you can try:
accordion(), you can use the…
open argument to decide which panels are open by default.multiple argument to decide if multiple panels can be open at once.accordion_panel(), you can use the…
icon argument to add an icon to the panel header.In the next exercise, use the College Scorecard search page as inspiration to better organize the sidebar inputs using an accordion.
#| standalone: true
#| components: [editor, viewer]
## file: app.R
library(shiny)
library(bslib)
source("app-accordion-support.R", local = TRUE)
# UI ----------------------------------------------------------------------
ui <- page_sidebar(
title = "Accordion Example",
sidebar = sidebar(
input_school_type,
input_deg_predmoninant,
input_n_undergrads,
input_cost_avg
),
layout_columns(
card(
card_header("Admissions Rate"),
plotlyOutput("plot_rate_admissions")
),
card(
card_header("Completion Rate"),
plotlyOutput("plot_rate_completion")
)
)
)
shinyApp(ui, server)
## file: app-accordion-support.R
library(dplyr)
library(plotly)
library(collegeScorecard)
# Data --------------------------------------------------------------------
scorecard_recent <-
scorecard |>
filter(academic_year == max(academic_year)) |>
select(id, n_undergrads, cost_avg, rate_admissions, rate_completion)
school <- left_join(school, scorecard_recent, by = "id")
school_types <- levels(school$control)
school_degrees <- levels(school$deg_predominant) |> setdiff("Graduate")
school_locales <- levels(school$locale_type)
# Inputs ------------------------------------------------------------------
range_slider <- function(data, column, label, by = 15000, step = by) {
val_range <- range(data[[column]], na.rm = TRUE)
val_range[1] <- floor(val_range[1] / by) * by
val_range[2] <- ceiling(val_range[2] / by) * by
sliderInput(
inputId = column,
label = label,
value = val_range,
min = val_range[1],
max = val_range[2],
step = step,
ticks = FALSE
)
}
input_n_undergrads <-
range_slider(
school,
"n_undergrads",
"Number of Undergrad Students",
by = 15000,
step = 5000
)
input_cost_avg <-
range_slider(
school,
"cost_avg",
"Average Yearly Cost",
by = 2500
)
input_school_type <-
checkboxGroupInput(
"school_type",
"Type of School",
choices = school_types,
selected = school_types,
inline = FALSE
)
input_deg_predmoninant <-
selectInput(
"deg_predominant",
"Predominant Degree Type",
choices = school_degrees,
selected = "Bachelor"
)
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
r_scorecard <- reactive({
school_filter <-
school |>
filter(
between(n_undergrads, input$n_undergrads[1], input$n_undergrads[2]),
between(cost_avg, input$cost_avg[1], input$cost_avg[2])
)
if (length(input$school_type)) {
school_filter <-
school_filter |>
filter(control %in% input$school_type)
}
school_filter <-
school_filter |>
filter(deg_predominant == input$deg_predominant)
scorecard |>
semi_join(school_filter, by = "id")
})
plotly_cleaner <- function(x) {
x |>
config(displayModeBar = FALSE) |>
layout(margin = list(l = 0, r = 0, b = 0))
}
filter_recent_complete_year <- function(scorecard, column) {
academic_year <- scorecard[!is.na(scorecard[[column]]), ]$academic_year
scorecard |> filter(academic_year == !!max(academic_year))
}
output$plot_rate_admissions <- renderPlotly({
r_scorecard() |>
filter_recent_complete_year("rate_admissions") |>
filter(!is.na(rate_admissions)) |>
plot_ly(x = ~rate_admissions, type = "histogram") |>
layout(xaxis = list(title = "Rate")) |>
plotly_cleaner()
})
output$plot_rate_completion <- renderPlotly({
r_scorecard() |>
filter_recent_complete_year("rate_completion") |>
filter(rate_completion > 0) |>
plot_ly(x = ~rate_completion, type = "histogram") |>
layout(xaxis = list(title = "Rate")) |>
plotly_cleaner()
})
}