New inputs

Two new bslib inputs

Switch

Binary on-off options are common in web apps these days, and input_switch() provides a simple way to add them to your Shiny app. They are more-or-less a drop-in replacement for checkboxInput().

Let’s use input_switch() to recreate the example above from the College Scorecard website.

#| standalone: true
#| components: [editor, viewer]
#| editorHeight: 500
library(shiny)
library(bslib)
library(dplyr)
library(leaflet)
library(collegeScorecard)

ui <- page_fillable(
  h2("Input Switch Example"),
  layout_column_wrap(
    width = 1 / 2,
    fill = FALSE,
    div(
      checkboxInput("most_get_in", "Most People Get In", TRUE),
      checkboxInput("most_graduate", "Most People Graduate", TRUE),
      checkboxInput("require_test", "Requires Test Scores", TRUE),
    ),
    div(
      checkboxInput("want_certificate", "I Want a Certificate", FALSE),
      checkboxInput("want_associates", "I Want an Associate's Degree", FALSE),
      checkboxInput("want_bachelors", "I Want a Bachelor's Degree", FALSE)
    )
  ),
  card(
    card_body(
      padding = 0,
      leafletOutput("map")
    )
  )
)

server <- function(input, output, session) {
  schools <- reactive({
    sc_filter <-
      scorecard |>
      slice_max(academic_year, by = id, n = 1)

    if (input$most_get_in) {
      sc_filter <- sc_filter |> filter(rate_admissions > 0.5)
    }

    if (input$most_graduate) {
      sc_filter <- sc_filter |> filter(rate_completion > 0.5)
    }

    school_filter <- school |>
      filter(
        between(latitude, 24.4, 49.4),
        between(longitude, -125.0, -67.0),
      )

    if (input$require_test) {
      school_filter <- school_filter |> filter(adm_req_test %in% c("Required", "Recommended"))
    }
    deg_want <- c(
      if (input$want_certificate) "Certificate",
      if (input$want_associates) "Associate",
      if (input$want_bachelors) "Bachelor"
    )
    if (length(deg_want)) {
      school_filter <- school_filter |> filter(deg_predominant %in% deg_want)
    }

    if (nrow(school_filter) > 500) {
      school_filter <- school_filter |> slice_sample(n = 500)
    }

    school_filter
  })

  output$map <- renderLeaflet({
    leaflet() |>
      addTiles() |>
      addMarkers(
        data = schools(),
        lat = ~latitude,
        lng = ~longitude,
        popup = ~name
      )
  })
}

shinyApp(ui, server)

Task Button

Shiny 1.8.1 introduced an exciting new feature: truly non-blocking operations with ExtendedTask. We don’t have time to explore ExtendedTask in detail. If you’re interested, I highly recommend Joe Cheng’s talk Managing long-running operations in Shiny.

The idea behind ExtendedTask is to use a limited amount of asynchronous programming to allow one task to extend beyond a single reactive lifecycle.

Extended tasks pair well with a new function we added to bslib: input_task_button(). This input doesn’t require an extended task, but it does work well with it. You can drop input_task_button() into your app where you previously used actionButton() when you know that the button triggers a long-running operation.

Let’s update the app from above to use input_task_button().

#| standalone: true
#| components: [editor, viewer]
#| editorHeight: 500
library(shiny)
library(bslib)
library(dplyr)
library(leaflet)
library(collegeScorecard)

ui <- page_fillable(
  h2("Input Task Button Example"),
  layout_column_wrap(
    width = 1 / 2,
    fill = FALSE,
    fillable = FALSE,
    heights_equal = "row",
    div(
      input_switch("most_get_in", "Most People Get In", TRUE),
      input_switch("most_graduate", "Most People Graduate", TRUE),
      input_switch("require_test", "Requires Test Scores", TRUE),
    ),
    div(
      input_switch("want_certificate", "I Want a Certificate", FALSE),
      input_switch("want_associates", "I Want an Associate's Degree", FALSE),
      input_switch("want_bachelors", "I Want a Bachelor's Degree", FALSE)
    ),
    actionButton("search", "Search")
  ),
  card(
    card_body(
      padding = 0,
      leafletOutput("map")
    )
  )
)

server <- function(input, output, session) {
  schools <- eventReactive(input$search, {
    sc_filter <-
      scorecard |>
      slice_max(academic_year, by = id, n = 1)

    if (input$most_get_in) {
      sc_filter <- sc_filter |> filter(rate_admissions > 0.5)
    }

    if (input$most_graduate) {
      sc_filter <- sc_filter |> filter(rate_completion > 0.5)
    }

    school_filter <- school |>
      filter(
        between(latitude, 24.4, 49.4),
        between(longitude, -125.0, -67.0),
      )

    if (input$require_test) {
      school_filter <- school_filter |> filter(adm_req_test %in% c("Required", "Recommended"))
    }
    deg_want <- c(
      if (input$want_certificate) "Certificate",
      if (input$want_associates) "Associate",
      if (input$want_bachelors) "Bachelor"
    )
    if (length(deg_want)) {
      school_filter <- school_filter |> filter(deg_predominant %in% deg_want)
    }

    if (nrow(school_filter) > 500) {
      school_filter <- school_filter |> slice_sample(n = 500)
    }

    school_filter
  })

  output$map <- renderLeaflet({
    leaflet() |>
      addTiles() |>
      addMarkers(
        data = schools(),
        lat = ~latitude,
        lng = ~longitude,
        popup = ~name
      )
  })
}

shinyApp(ui, server)