WebDev4R: Shiny Explained

In this blog post, I document my YouTube series on Shiny. No explanations. Just the explainer videos and the code.

Shiny in a Nutshell

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)

ui <- bslib::page_fluid(
  sliderInput(
    'my_slider', # Input ID
    'Select your number', # Input label
    # Input-specifc stuff
    min = 0,
    max = 1,
    value = 0.5,
    step = 0.1
  ),

  selectInput(
    'my_dropdown_menu', # Input ID
    'Pick your color', # Input label
    # Input-specifc stuff
    choices = c('red', 'green', 'blue')
  ),

  textOutput('my_generated_text')
)

server <- function(input, output, session) {
  output$my_generated_text <- renderText({
    paste(
      input$my_dropdown_menu,
      input$my_slider
    )
  })
}

shinyApp(ui, server) |> print()

Understanding Reactivity

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)
ui <- bslib::page_fluid(
  sliderInput(
    'slider',
    'Slider',
    min = 1,
    max = 100,
    value = 50
  ),
  actionButton('button', 'Button'),
  textOutput('text')
)

server <- function(input, output, session) {
  observeEvent(
    input$button,
    {
      output$text <- renderText({
        print(input$button)
        isolate(input$slider)
      })
    }
  )
}

shinyApp(ui, server) |> print()

Understanding Reactive Expressions

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(tidyverse)
library(shiny)

ui <- bslib::page_fluid(
  bslib::layout_column_wrap(
    selectInput(
      'species',
      'Choose your species',
      unique(palmerpenguins::penguins$species)
    ),
    selectInput(
      'island',
      'Choose your island',
      unique(palmerpenguins::penguins$island)
    )
  ),
  bslib::layout_column_wrap(
    plotOutput('plot'),
    DT::dataTableOutput('tbl')
  )
)

server <- function(input, output, session) {
  filtered_data <- reactiveValues()
  observe({
    dat <- palmerpenguins::penguins |>
      filter(
        !is.na(sex),
        species == input$species,
        island == input$island
      )

    filtered_data$dat <- dat
  })

  output$tbl <- DT::renderDT({
    filtered_data$dat
  })

  output$plot <- renderPlot({
    filtered_data$dat |>
      ggplot(
        aes(
          x = flipper_length_mm,
          y = bill_depth_mm
        )
      ) +
      geom_point(size = 3)
  })
}

# Print inside Positron
shinyApp(ui, server) |> print()

Dynamic/Interactive UI Outputs

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)

ui <- bslib::page_fluid(
  actionButton('button', 'Move slider to 7'),
  sliderInput(
    'slider',
    'Move me!',
    min = 1,
    max = 10,
    value = 5
  )
)

server <- function(input, output, session) {
  observe({
    updateSliderInput(
      inputId = 'slider',
      value = 7,
      label = 'This has been moved!'
    )
  }) |>
    bindEvent(input$button)
}

# Print to display in Positron
shinyApp(ui, server) |> print()

Shiny Modules

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)
library(ggplot2)
plot_UI <- function(id) {
  ns <- NS(id)
  tagList(
    plotOutput(ns("plot"))
  )
}

plot_Server <- function(id, shared_data) {
  moduleServer(
    id,
    function(input, output, session) {
      output$plot <- renderPlot({
        if (shared_data$dropdown_choice == "bar") {
          p <- ggplot(
            mtcars,
            aes(x = factor(cyl))
          ) +
            geom_bar(fill = 'dodgerblue4')
        } else {
          p <- ggplot(
            mtcars,
            aes(x = factor(cyl), y = mpg)
          ) +
            geom_boxplot(
              color = 'dodgerblue4',
              linewidth = 1.5
            )
        }

        p +
          theme_minimal(base_size = 16)
      })
    }
  )
}

ui <- bslib::page_fluid(
  selectInput(
    "dropdown",
    "Choose a chart",
    choices = c("bar", "boxplot")
  ),
  plot_UI("plot")
)

server <- function(input, output, session) {
  # shared_data <- reactiveValues()
  # observe({
  #   shared_data$dropdown_choice <- input$dropdown
  # })
  shared_data <- list(dropdown_choice = 'bar')
  plot_Server("plot", shared_data)
}

shinyApp(ui, server) |> print()

Robust Shiny Apps with Golem

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

Link to repository: repo

Client-side Code & Dynamic Tables with {shiny} and `{gt}

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)
library(gt)


df_pizza <- gt::pizzaplace |>
  dplyr::slice(1:500) |>
  dplyr::mutate(
    cryptic_id = purrr::map_chr(id, \(x) {
      sample(c(letters, LETTERS, 0:9), size = 30, replace = TRUE) |>
        paste0(collapse = '')
    }),
  ) |>
  dplyr::mutate(
    cryptic_id_link = purrr::map_chr(
      cryptic_id,
      \(x) {
        a(
          '👀 Show me',
          onclick = glue::glue(
            'Shiny.setInputValue("clicked_id", ""); 
            Shiny.setInputValue("clicked_id", "{x}")'
          ),
          style = htmltools::css(
            background = '#F2FDFF',
            border = '1px solid #101935',
            border_radius = '5px',
            padding = '5px',
            cursor = 'pointer'
          )
        ) |>
          as.character()
      }
    )
  )

ui <- bslib::page_fluid(
  h3('Dynamic Tables'),
  gt_output('tbl')
)

server <- function(input, output, session) {
  output$tbl <- render_gt({
    df_pizza |>
      dplyr::select(date, time, price, cryptic_id_link) |>
      gt() |>
      fmt_markdown(
        columns = 'cryptic_id_link'
      ) |>
      opt_interactive(page_size_default = 5)
  })

  observe({
    print(input$clicked_id)

    showModal(
      modalDialog(
        df_pizza |>
          dplyr::filter(cryptic_id == input$clicked_id) |>
          dplyr::select(-c(cryptic_id, cryptic_id_link)) |>
          tidyr::pivot_longer(
            cols = tidyr::everything(),
            values_transform = as.character
          ) |>
          gt()
      )
    )
  }) |>
    bindEvent(input$clicked_id)
}

shinyApp(ui, server) |> print()

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code (modularized)

library(shiny)
library(gt)

df_pizza <- gt::pizzaplace |>
  dplyr::slice(1:500) |>
  dplyr::mutate(
    cryptic_id = purrr::map_chr(id, \(x) {
      sample(c(letters, LETTERS, 0:9), size = 30, replace = TRUE) |>
        paste0(collapse = '')
    }),
  )


tbl_UI <- function(id) {
  ns <- NS(id)
  tagList(
    gt_output(ns('tbl'))
  )
}

tbl_Server <- function(id) {
  moduleServer(
    id,
    function(input, output, session) {
      ns <- session$ns
      df_pizza <- df_pizza |>
        dplyr::mutate(
          cryptic_id_link = purrr::map_chr(
            cryptic_id,
            \(x) {
              a(
                '👀 Show me',
                onclick = glue::glue(
                  'Shiny.setInputValue("{ns("clicked_id")}", ""); 
                  Shiny.setInputValue("{ns("clicked_id")}", "{x}")'
                ),
                style = htmltools::css(
                  background = '#F2FDFF',
                  border = '1px solid #101935',
                  border_radius = '5px',
                  padding = '5px',
                  cursor = 'pointer'
                )
              ) |>
                as.character()
            }
          )
        )

      output$tbl <- render_gt({
        df_pizza |>
          dplyr::select(date, time, price, cryptic_id_link) |>
          gt() |>
          fmt_markdown(
            columns = 'cryptic_id_link'
          ) |>
          opt_interactive(page_size_default = 5)
      })

      observe({
        print(input$clicked_id)

        showModal(
          modalDialog(
            df_pizza |>
              dplyr::filter(cryptic_id == input$clicked_id) |>
              dplyr::select(-c(cryptic_id, cryptic_id_link)) |>
              tidyr::pivot_longer(
                cols = tidyr::everything(),
                values_transform = as.character
              ) |>
              gt()
          )
        )
      }) |>
        bindEvent(input$clicked_id)
    }
  )
}


ui <- bslib::page_fluid(
  h3('Dynamic Tables'),
  tbl_UI('tbl')
)

server <- function(input, output, session) {
  tbl_Server('tbl')
}

shinyApp(ui, server) |> print()

Advanced Widgets with {shinywidgets}

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)
library(bslib)
library(ggplot2)

df_pizza <- gt::pizzaplace |>
  dplyr::mutate(date_sold = readr::parse_date(date)) |>
  dplyr::select(-c(date, time))


plot_revenue_by_timeframe <- function(
  df,
  timeframe,
  primary_color = '#007bc2'
) {
  if (!(timeframe %in% c('month', 'quarter', 'week'))) {
    cli::cli_abort('Unsupported timeframe')
  }
  if (timeframe == 'month') {
    fn_aggregate <- lubridate::month
  }
  if (timeframe == 'quarter') {
    fn_aggregate <- lubridate::quarter
  }
  if (timeframe == 'week') {
    fn_aggregate <- lubridate::week
  }

  df |>
    dplyr::mutate(timeframe = fn_aggregate(date_sold)) |>
    dplyr::summarize(
      price = sum(price),
      .by = timeframe
    ) |>
    ggplot(aes(x = timeframe, y = price)) +
    geom_col(fill = primary_color) +
    labs(x = element_blank(), y = element_blank()) +
    scale_y_continuous(labels = scales::label_dollar()) +
    theme_minimal(base_size = 24, base_family = 'Source Sans Pro') +
    theme(
      panel.grid.major.x = element_blank(),
      panel.grid.minor = element_blank(),
    )
}

ui <- page_navbar(
  title = 'My {bslib} App',
  nav_panel(
    'Stats',
    page_sidebar(
      shinyWidgets::useSweetAlert(),
      sidebar = sidebar(
        sliderInput(
          'slider_timepoint',
          'Timeframe',
          min = min(df_pizza$date_sold),
          max = max(df_pizza$date_sold),
          value = range(df_pizza$date_sold),
          width = 225
        ),
        width = 300
      ),
      layout_column_wrap(
        value_box(
          'Pizzas sold',
          value = textOutput('nmbr_pizzas_sold', inline = TRUE),
          showcase = shiny::icon('pizza-slice')
        ),
        value_box(
          'Revenue generated',
          value = textOutput('nmbr_revenue_genrated', inline = TRUE),
          showcase = shiny::icon('sack-dollar')
        ),
        fill = FALSE,
        width = '300px',
        min_height = '100px'
      ),
      card(
        card_header(
          'Revenue by month'
        ),
        card_body(
          plotOutput('plot_by_month')
        ),
        full_screen = TRUE
      ),
      navset_card_tab(
        nav_panel(
          'Revenue by week',
          card(
            card_body(plotOutput('plot_by_week')),
            full_screen = TRUE
          )
        ),
        nav_panel(
          'Revenue by quarter',
          card(
            card_body(plotOutput('plot_by_quarter')),
            full_screen = TRUE
          )
        ),
        nav_spacer(),
        nav_item(
          actionLink(
            'btn_settings',
            label = 'Settings',
            icon = shiny::icon('gear')
          )
        )
      )
    )
  ),
  nav_panel(
    'Other Stuff',
    'Here is where your content could live.'
  )
)

server <- function(input, output, session) {
  df_filtered_pizza <- reactive({
    df_pizza |>
      dplyr::filter(
        date_sold >= input$slider_timepoint[1],
        date_sold <= input$slider_timepoint[2],
      )
  })

  output$nmbr_pizzas_sold <- renderText({
    df_filtered_pizza() |>
      dplyr::pull(price) |>
      length() |>
      scales::number(big.mark = ',')
  })
  output$nmbr_revenue_genrated <- renderText({
    df_filtered_pizza() |>
      dplyr::pull(price) |>
      sum() |>
      scales::dollar()
  })

  output$plot_by_month <- renderPlot({
    req(df_filtered_pizza)
    plt <- df_filtered_pizza() |>
      plot_revenue_by_timeframe(timeframe = 'month')
    plt + scale_x_continuous(breaks = 1:12)
  })

  output$plot_by_week <- renderPlot({
    req(df_filtered_pizza)
    plt <- df_filtered_pizza() |>
      plot_revenue_by_timeframe(timeframe = 'week')
    plt + scale_x_continuous(breaks = 1:53)
  })

  output$plot_by_quarter <- renderPlot({
    req(df_filtered_pizza)
    plt <- df_filtered_pizza() |>
      plot_revenue_by_timeframe(timeframe = 'quarter')
    plt + scale_x_continuous(breaks = 1:4)
  })

  observe({
    shinyWidgets::show_alert(
      title = 'Hooraay!',
      text = 'You clicked something',
      type = 'success'
    )
  }) |>
    bindEvent(input$btn_settings)
}

shinyApp(ui, server) |> print()

The Easiest Way to Export Data From Your R-Shiny Apps

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)
library(bslib)
library(ggplot2)

ui <- page_sidebar(
  sidebar = sidebar(
    selectInput(
      'in_species',
      'Penguin species',
      choices = palmerpenguins::penguins$species |> unique()
    ),
    downloadButton(
      'btn_export_pdf',
      'Export Report',
      icon = shiny::icon('file-pdf')
    ),
    downloadButton(
      'btn_export_excel',
      'Export Report',
      icon = shiny::icon('file-excel')
    )
  ),

  h1('Penguins are cool!'),
  value_box(
    'Number of penguins',
    value = textOutput('out_n_penguins'),
    showcase = shiny::icon('hashtag'),
    min_height = 100,
    max_height = 150
  ),

  card(
    card_header('Look at them penguins!'),
    card_body(plotOutput('out_plt_penguins'))
  )
)

server <- function(input, output, session) {
  r_df_penguins <- reactive({
    palmerpenguins::penguins |>
      dplyr::filter(species == input$in_species)
  })

  output$out_n_penguins <- renderText({
    r_df_penguins() |> nrow()
  })

  output$btn_export_pdf <- downloadHandler(
    filename = function() {
      glue::glue("{input$in_species}_report.pdf")
    },
    content = function(file) {
      quarto::quarto_render(
        input = here::here('114_pdf_export/report_template.qmd'),
        execute_params = list(species = input$in_species)
      )
      fs::file_copy(
        here::here('114_pdf_export/report_template.pdf'),
        file
      )
    }
  )

  output$btn_export_excel <- downloadHandler(
    filename = function() {
      glue::glue("{input$in_species}_raw.xlsx")
    },
    content = function(file) {
      wb <- openxlsx::createWorkbook()
      openxlsx::addWorksheet(wb, "Data")

      header_style <- openxlsx::createStyle(textDecoration = "bold")
      openxlsx::writeData(
        wb,
        "Data",
        r_df_penguins(),
        headerStyle = header_style
      )
      openxlsx::setColWidths(
        wb,
        "Data",
        cols = 1:ncol(r_df_penguins()),
        widths = c(rep(20, 6), 10, 5)
      )

      openxlsx::saveWorkbook(wb, file, overwrite = TRUE)
    }
  )

  output$out_plt_penguins <- renderPlot({
    palmerpenguins::penguins |>
      dplyr::filter(!is.na(sex)) |>
      ggplot(
        aes(
          x = body_mass_g,
          y = flipper_length_mm,
          fill = (species == input$in_species)
        )
      ) +
      geom_point(
        size = 4,
        shape = 21,
        col = 'white',
        show.legend = FALSE
      ) +
      geom_point(
        data = r_df_penguins(),
        size = 4,
        shape = 21,
        col = 'white',
        show.legend = FALSE
      ) +
      scale_fill_manual(
        values = c("TRUE" = 'dodgerblue4', "FALSE" = 'grey80')
      ) +
      theme_minimal(base_size = 12, base_family = 'Source Sans Pro') +
      labs(x = 'Weight (g)', y = 'Flipper length (mm)')
  })
}

shinyApp(ui, server) |> print()

Additional Files

• report_template.qmd
• typst-show.typ
• typst-template.typ

How To Build ANY R-Shiny App You Want (with custom HTML, CSS & JS)

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)
library(bslib)


replies_names <- c(
  markdown("Teach them about `ctrl + shift + F10`."),
  "Set their computer on fire.",
  "Do nothing.",
  "Run for your life."
)

replies_values <- c(
  'teach',
  'fire',
  'nothing',
  'run'
)

replies_correct_values <- c(
  'teach',
  'fire',
  'run'
)

ui <- page_fluid(
  theme = bs_theme(primary = '#404040'),
  includeCSS('www/styles_recordings.css'),
  shinyjs::useShinyjs(),
  div(
    div(
      h1(
        'A silly little quiz',
        class = 'd-flex m-auto pt-4',
        style = 'width: fit-content'
      )
    ),
    div(
      class = 'p-4',
      div(
        class = 'm-auto w-75 p-4 rounded shadow-lg',
        style = htmltools::css(
          outline = '1px solid black',
          min_width = '300px',
          max_width = '500px'
        ),
        markdown(
          "What is the correct response when you look into someone's R code and see `rm(list = ls())`?"
        ),
        div(
          id = 'reply_area',
          shinyWidgets::checkboxGroupButtons(
            inputId = "reply_answer",
            label = NULL,
            choiceNames = replies_names,
            choiceValues = replies_values,
            direction = "vertical",
            width = '100%'
          ),
        ),
        div(
          class = 'd-flex',
          actionButton(
            'btn_check',
            'Check answers',
            class = 'ms-auto'
          )
        )
      )
    )
  )
)

server <- function(input, output, session) {
  observe({
    if (!isTruthy(input$reply_answer)) {
      showNotification(
        'Pick at least one answer.',
        type = 'error'
      )
    }

    req(isTruthy(input$reply_answer))

    correct_number_of_replies <- (length(input$reply_answer) ==
      length(replies_correct_values))
    all_correct_answers <- correct_number_of_replies &&
      all(
        sort(input$reply_answer) == sort(replies_correct_values)
      )
    if (all_correct_answers) {
      shinyWidgets::show_alert(
        title = 'HOOORAY!',
        text = 'Yes, you answered everything correctly.',
        type = 'success'
      )
    } else {
      shinyWidgets::show_alert(
        title = 'Oh no!',
        text = 'This is not the (fully) correct answer.',
        type = 'error'
      )
    }

    class_replies <- ifelse(
      replies_values %in% replies_correct_values,
      'correct_reply',
      'incorrect_reply'
    )
    label_command_replies <- glue::glue(
      "labels[{seq_along(class_replies) - 1}].classList.add('{class_replies}');",
    ) |>
      stringr::str_flatten()

    shinyjs::runjs(
      paste0(
        "var labels = document.querySelectorAll('label.btn.checkbtn');",
        label_command_replies,
        collapse = ''
      )
    )
  }) |>
    bindEvent(input$btn_check)
}

shinyApp(ui, server) |> print()

Additional Files

• styles_recordings.css

3 Easy Ways to Stop Bad Inputs in R-Shiny Apps

Video

Checkout the full R-Shiny playlist here 👉 PLAYLIST

Code

library(shiny)
library(bslib)
library(shinyvalidate)

ui <- page_fluid(
  div(
    class = 'm-2',
    h1('Shiny Validation Demo'),
    div(
      class = 'd-flex',
      textInput('in_txt_name', 'What is your name?'),
      div(
        class = 'ms-2',
        selectizeInput(
          'in_select_month',
          'Select your desired month',
          choices = month.name,
          multiple = TRUE,
          #options = list(maxItems = 3)
        )
      )
    ),
    verbatimTextOutput('out_verbatim_txt')
  )
)

server <- function(input, output, session) {
  iv <- InputValidator$new()
  iv$add_rule("in_txt_name", sv_required())
  iv$add_rule("in_select_month", sv_required())
  iv$add_rule("in_txt_name", \(x) {
    is_long_enough_name <- stringr::str_length(x) >= 3
    if (!is_long_enough_name) {
      "Please provide a name of length that is at least 3"
    }
  })
  iv$add_rule("in_select_month", \(x) {
    is_only_three_months <- length(x) <= 3
    if (!is_only_three_months) {
      "Please provide at most 3 months"
    }
  })
  iv$enable()

  output$out_verbatim_txt <- renderPrint({
    is_long_enough_name <- stringr::str_length(input$in_txt_name) >= 3
    is_at_least_one_month <- length(input$in_select_month) >= 1
    is_only_three_months <- length(input$in_select_month) <= 3

    validate(
      need(
        is_long_enough_name,
        "Please provide a name of length that is at least 3"
      ),
      need(is_at_least_one_month, "Please provide a month"),
      need(is_only_three_months, "Please provide at most 3 months"),
    )

    epoxy::epoxy(
      "Hi {input$in_txt_name}, you selected {.and input$in_select_month}."
    )
  })
}

shinyApp(ui, server) |> print()