Advanced layouts

Flexible and responsive column-first layouts

Recap: value boxes

  • show-and-tell
  • sparklines examples/app-sparkline.R
#| standalone: true
#| components: [editor, viewer]
#| editorHeight: 600
## file: app.R
library(shiny)
library(bslib)
library(plotly)
library(tidyverse)
library(collegeScorecard)

# Directly from bslib docs (Components > Value Boxes > Expandable Sparklines)
# https://rstudio.github.io/bslib/articles/value-boxes/index.html#expandable-sparklines
plotly_sparkline <- function(data, x, y, ..., color = "white", formatter = identity) {
  plot_ly(data) %>%
    add_lines(
      x = x,
      y = y,
      text = as.formula(sprintf("~ formatter(%s)", as.character(y[[2]]))),
      hoverinfo = "text",
      color = I(color),
      span = I(1),
      fill = "tozeroy",
      alpha = 0.2
    ) %>%
    layout(
      xaxis = list(visible = FALSE, showgrid = FALSE, title = ""),
      yaxis = list(visible = FALSE, showgrid = FALSE, title = ""),
      hovermode = "x",
      margin = list(t = 0, r = 0, l = 0, b = 0),
      font = list(color = color),
      paper_bgcolor = "transparent",
      plot_bgcolor = "transparent"
    ) %>%
    config(displayModeBar = FALSE) %>%
    htmlwidgets::onRender(
      "function(el) {
        el.closest('.bslib-value-box')
          .addEventListener('bslib.card', function(ev) {
            Plotly.relayout(el, {'xaxis.visible': ev.detail.fullScreen});
          })
      }"
    )
}

# 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 = "Value Boxes with Sparklines",
  sidebar = sidebar(
    selectInput("name", "School Name", NULL),
    actionButton("random_school", "Random School", fontawesome::fa_i("shuffle"))
  ),
  layout_columns(
    fill = FALSE,
    value_box(
      title = "Undergrad Students",
      value = textOutput("text_n_undergrads"),
      showcase = plotlyOutput("sparkline_n_undergrads"),
      showcase_layout = "bottom",
      full_screen = TRUE
    ),
    value_box(
      title = "Average Yearly Cost",
      value = textOutput("text_cost_avg"),
      theme = "primary",
      showcase = plotlyOutput("sparkline_cost_avg"),
      showcase_layout = "bottom",
      full_screen = TRUE
    ),
    value_box(
      title = "Completion Rate",
      value = textOutput("text_rate_completion"),
      theme = "bg-gradient-orange-red",
      showcase = plotlyOutput("sparkline_rate_completion"),
      showcase_layout = "bottom",
      full_screen = TRUE
    )
  ),

  # 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") |>
      arrange(academic_year)
  })

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

  output$sparkline_n_undergrads <- renderPlotly({
    plotly_sparkline(
      r_scorecard(),
      x = ~academic_year,
      y = ~n_undergrads,
      color = "black",
      formatter = scales::label_number(big.mark = ",")
    )
  })

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

  output$sparkline_cost_avg <- renderPlotly({
    plotly_sparkline(
      r_scorecard(),
      x = ~academic_year,
      y = ~cost_avg,
      formatter = scales::label_dollar(accuracy = 10)
    )
  })

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

  output$sparkline_rate_completion <- renderPlotly({
    plotly_sparkline(
      r_scorecard(),
      x = ~academic_year,
      y = ~rate_completion,
      formatter = scales::label_percent(accuracy = 0.1)
    )
  })
}

shinyApp(ui, server)

Column layouts

  • layout_column_wrap() equally sized things
    • widths
    • heights_equal
  • layout_columns() = row() + column()
#| standalone: true
#| components: [editor, viewer]
#| editorHeight: 600
## file: app.R
library(shiny)
library(bslib)
library(glue)
library(tidyverse)
library(collegeScorecard)

ui <- page_fillable(
  sliderInput("n", "Top N Schools", min = 1, max = 20, value = 9, ticks = FALSE),
  uiOutput("layout_cards")
)

server <- function(input, output, session) {
  output$layout_cards <- renderUI({
    # layout cards here
  })

  top_n_schools <- reactive({
    scorecard |>
      filter(n_undergrads > 1000) |>
      slice_max(academic_year, n = 1) |>
      slice_max(cost_avg, n = input$n) |>
      arrange(desc(cost_avg)) |>
      left_join(school, by = "id")
  })

  colors <- c("blue", "indigo", "purple", "pink", "red", "orange", "yellow", "green", "teal", "cyan")

  cards <- reactive({
    req(top_n_schools())
    set.seed(42**3.8)

    ## Create a value box for each of the top-N most costly schools
    # value_box(
    #   title = name,
    #   value = scales::dollar(cost_avg),
    #   theme = sample(colors, 1)
    # )
  })
}

shinyApp(ui, server)

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

exercises/04_app.R

exercises/04_app.R
library(shiny)
library(bslib)
library(leaflet)
library(plotly)
library(tidyverse)
library(collegeScorecard)


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

# UI ----------------------------------------------------------------------
ui <- page_sidebar(
  title = "04 - Column Layouts",
  sidebar = sidebar(
    selectInput("name", "School Name", NULL),
    actionButton("random_school", "Random School", fontawesome::fa_i("shuffle"))
  ),
  value_box(
    title = "Undergrad Students",
    value = textOutput("text_n_undergrads"),
    showcase = fontawesome::fa_i("people-roof")
  ),
  value_box(
    title = "Average Yearly Cost",
    value = textOutput("text_cost_avg"),
    theme = "primary",
    showcase = fontawesome::fa_i("money-check-dollar")
  ),
  value_box(
    title = "Completion Rate",
    value = textOutput("text_rate_completion"),
    theme = "bg-gradient-orange-red",
    showcase = fontawesome::fa_i("user-graduate")
  ),

  plotlyOutput("plot_cost_by_income"),
  leafletOutput("map_school")
)

# Server ------------------------------------------------------------------
server <- function(input, output, session) {
  # School Selection ----
  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 |>
      inner_join(school_1k |> filter(name == input$name), by = "id") |>
      slice_max(academic_year, n = 1, with_ties = FALSE)
  })

  # Value box text ----
  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)
  })

  # Plot: Cost by income ----
  output$plot_cost_by_income <- renderPlotly({
    income_level <- c(
      "0_30k" = "$0 - $30k",
      "30_48k" = "$30k - $48k",
      "48_75k" = "$48k - $75k",
      "75_110k" = "$75k - $110k",
      "110k_plus" = "$110k+"
    )

    r_scorecard() |>
      slice_max(academic_year, n = 1) |>
      select(starts_with("cost_avg_income")) |>
      pivot_longer(everything(), names_prefix = "cost_avg_income_") |>
      mutate(name = factor(name, names(income_level), income_level)) |>
      plot_ly(
        x = ~value,
        y = ~name,
        type = "bar",
        hoverinfo = "text",
        textposition = "none",
        text = ~paste0(
          "Income Level: ", name, "<br>",
          "Average Cost: ", scales::dollar(value)
        )
      ) |>
      layout(
        xaxis = list(title = "Average Yearly Cost"),
        yaxis = list(title = "Income Level")
      ) |>
      plotly::config(displayModeBar = FALSE)
  })

  # Map: School location ----
  output$map_school <- renderLeaflet({
    validate(need(r_scorecard()$latitude, "No location data"))

    r_scorecard() |>
      leaflet() |>
      addTiles() |>
      addMarkers(
        lng = ~longitude,
        lat = ~latitude,
        popup = ~name
      )
  })
}

shinyApp(ui, server)

The app in exercises/04_app.R includes three value boxes, one plot and one map, but they’re unorganized. Use one layout_columns() and one layout_column_wrap() to better lay out the dashboard.