New layouts

Learn how to lay out UI elements with bslib.

bslib layouts

  • page_sidebar()
  • card()
    • with card parts
  • layout_columns()
  • full screen cards
#| standalone: true
#| components: [editor, viewer]
## file: app.R
library(shiny)
library(bslib)

ui <- page_fluid(

)

server <- function(input, output, session) {

}

shinyApp(ui, server)

πŸ§‘β€πŸ’» Your Turn

exercises/02_app.R

exercises/02_app.R
library(shiny)
library(bslib)
library(dplyr)
library(plotly)
library(collegeScorecard)

# Data --------------------------------------------------------------------
school_types <- levels(school$control)
school_degrees <- levels(school$deg_predominant) |> setdiff("Graduate")
school_locales <- levels(school$locale_type)

# Inputs ------------------------------------------------------------------
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"
  )

input_group_by <-
  radioButtons(
    "group_by",
    "Group By",
    choices = c(
      "Campus Setting" = "locale_type",
      "Highest Degree" = "deg_highest",
      "Testing Requirements" = "adm_req_test"
    )
  )

# UI ----------------------------------------------------------------------

ui <- fluidPage(
  # theme = bs_theme(),
  titlePanel("02 - First bslib Layout"),
  sidebarLayout(
    sidebarPanel(
      input_school_type,
      input_deg_predmoninant,
      hr(),
      input_group_by
    ),
    mainPanel(
      plotlyOutput("plot_rate_admissions"),
      plotlyOutput("plot_rate_completion"),
      plotlyOutput("plot_cost_earnings")
    )
  )
)


# Server ------------------------------------------------------------------

server <- function(input, output, session) {
  r_scorecard <- reactive({
    school_filter <- school
    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()
  })

  output$plot_cost_earnings <- renderPlotly({
    r_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(input$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")
      )
  })
}

shinyApp(ui, server)

We’re in the process of refactoring an older Shiny app to use new features from bslib. I’ve started refactoring exercises/02_app.R by pulling out the inputs so it’s easier to see the layout.

Your task is to migrate the UI section of the app from shiny::fluidPage() and shiny::sidebarLayout() to use page and layout functions from {bslib}.

Value Boxes

#| standalone: true
#| components: [editor, viewer, terminal]
## file: app.R
library(shiny)
library(bslib)
library(collegeScorecard)

ui <- page_fluid(

)

server <- function(input, output, session) {

}

shinyApp(ui, server)

πŸ§‘β€πŸ’» Your Turn

exercises/03_app.R

exercises/03_app.R
library(shiny)
library(bslib)
library(tidyverse)
library(collegeScorecard)

# Feel free to use either of these packages for icons!
# library(fontawesome)  # usage: fontawesome::fa_i("icon-name")
# library(bsicons)      # usage: bsicons::bs_icon("icon-name")

# Data --------------------------------------------------------------------
school_1k <-
  scorecard |>
  slice_max(academic_year, by = id, n = 1) |>
  filter(n_undergrads > 1000) |>
  semi_join(school, y = _, by = "id")

# UI ----------------------------------------------------------------------
ui <- page_sidebar(
  title = "03 - Value Boxes",
  sidebar = sidebar(
    selectInput("name", "School Name", NULL),
    actionButton("random_school", "Random School", fontawesome::fa_i("shuffle"))
  ),

  layout_columns(
    fill = FALSE,
    # !! Put value boxes here using the following outputs !!
    # textOutput("text_n_undergrads")
    # textOutput("text_cost_avg")
    # textOutput("text_rate_completion")
  ),

  # pretend this card is a plot
  card(class = "text-bg-light", style = "min-height: 300px")
)

# Server ------------------------------------------------------------------
server <- function(input, output, session) {
  observe({
    updateSelectizeInput(session, "name", choices = school_1k$name, server = TRUE)
  })

  observeEvent(input$random_school, {
    updateSelectizeInput(session, "name", choices = school_1k$name, selected = sample(school_1k$name, 1), server = TRUE)
  })

  r_scorecard <- eventReactive(input$name, {
    scorecard |>
      semi_join(school_1k |> filter(name == input$name), by = "id") |>
      slice_max(academic_year, n = 1, with_ties = FALSE)
  })

  output$text_n_undergrads <- renderText({
    n_undergrads <- r_scorecard()$n_undergrads
    validate(need(n_undergrads, "No data"))
    scales::number(n_undergrads, big.mark = ",")
  })

  output$text_cost_avg <- renderText({
    cost_avg <- r_scorecard()$cost_avg
    validate(need(cost_avg, "No data"))
    scales::dollar(cost_avg)
  })

  output$text_rate_completion <- renderText({
    rate_completion <- r_scorecard()$rate_completion
    validate(need(rate_completion, "No data"))
    scales::percent(rate_completion)
  })
}

shinyApp(ui, server)

The app in exercises/03_app.R contains the start of a dashboard where the user can pick a specific school and see a quick summary of information about the school.

I’ve set up all of the reactive server-side logic for you. Your job is to create three visually appealing value boxes to describe:

  1. The number of undergraduate students at the school.
  2. The average yearly cost of the school.
  3. The rate of completion at the school.
Tip

Use the Build-A-Box app from the bslib package to explore value box options and to design the three value boxes. The app is available online or locally by running

shiny::runExample("build-a-box", package = "bslib")