WebDev4R: Shiny Explained
[This article was first published on Albert Rapp, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
Shiny in a Nutshell
Video
Checkout the full R-Shiny playlist here 👉 PLAYLIST
Code
Press to unfold 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
Press to unfold 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
Press to unfold 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
Press to unfold 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
Press to unfold 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
Press to unfold 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)
Press to unfold 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 = '')
}),
)
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
Press to unfold 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()
To leave a comment for the author, please follow the link and comment on their blog: Albert Rapp.
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.