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()