Chapter 10 Dynamic UI
This chapter is in development...
Exercise 10.1.5.1
Complete the user interface below with a server function that updates input$date so that you can only select dates in input$year.
ui <- fluidPage(
numericInput("year", "year", value = 2020),
dateInput("date", "date")
)Solution.
Solution
This solution was a little wonky because it required shinyjs for the dateInput to properly update. I opened up an issue here since I think this is not the most intuitive answer.
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs() ,
numericInput("year", "year", value = 2020),
dateInput("date", "date", value = Sys.Date())
)
server <- function(input, output, session) {
observeEvent(input$year, {
req(input$year) # stop if year is blank
daterange <- range(as.Date(paste0(input$year, "-01-01")),as.Date(paste0(input$year, "-12-31")))
updateDateInput(session, "date", min = daterange[1], max = daterange[2] )
delay(250, # delay 250ms
updateDateInput(session,"date",
value = daterange[1]
))
})
}
shinyApp(ui = ui, server = server)Exercise 10.1.5.2
Complete the user interface below with a server function that updates input$county choices based on input$state. For an added challenge, also change the label from “County” to “Parrish” for Louisana and “Borrough” for “Alaska”.
library(openintro)
states <- unique(county$state)
ui <- fluidPage(
selectInput("state", "State", choices = states),
selectInput("county", "County", choices = NULL)
)Solution.
Solution
We can use updateSelectInput to filter the county choices based on the user selected state. By making the label of input$county a reactive, we can use switch to change the label when either Alaska or Louisiana is selected.
library(shiny)
library(tidyverse)
library(openintro)
states <- unique(county$state)
counties <- unique(county$state)
ui <- fluidPage(
selectInput("state", "State", choices = states),
selectInput("county", "County", choices = NULL)
)
server <- function(input, output, session) {
label <- reactive({
switch(input$state,
"Alaska" = "Burrough",
"Louisiana" = "Parish",
"County")
})
observeEvent( input$state, {
updateSelectInput(session, "county", label = label(),
choices = county %>%
filter(state == input$state) %>%
select(name) %>%
distinct())
})
}
shinyApp(ui = ui, server = server)Exercise 10.1.5.3
Complete the user interface below with a server function that updates input$country choices based on the input$continent. Use output$data to display all matching rows.
library(gapminder)
continents <- unique(gapminder$continent)
ui <- fluidPage(
selectInput("continent", "Continent", choices = continents),
selectInput("country", "Country", choices = NULL),
tableOutput("data")
)Solution.
Solution
As the question above, we are filtering the country input based on the continent by using updateSelectInput in the server. By storing the selected data in a reactive, selected_data() we can use the same filtered dataset for our selectInput and the table, reducing code redundancy.
library(shiny)
library(gapminder)
continents <- unique(gapminder$continent)
ui <- fluidPage(
selectInput("continent", "Continent", choices = c("", as.character(continents))),
selectInput("country", "Country", choices = NULL),
tableOutput("data")
)
server <- function(input, output, session) {
selected_data <- reactive({
if(input$continent %in% continents) {
gapminder %>%
filter(continent == input$continent)
} else {
gapminder
}
})
observeEvent( input$continent, {
updateSelectInput(session, "country", "Country",
choices = selected_data() %>%
select(country) %>%
distinct())
})
output$data <- renderTable({
selected_data() %>%
filter(country == input$country)
})
}
shinyApp(ui = ui, server = server)Exercise 10.1.5.4
Extend the previous app so that you can also choose to select no continent, and hence see all countries. You’ll need to add “” to the list of choices, and then handle that specially when filtering.
Solution.
Solution
Initially setting the choices to c("", as.character(continents)) allows the user to see all the Country options prior to a continent being selected. That said, once a continent is selected this "" option is no longer available.
library(shiny)
library(gapminder)
continents <- unique(gapminder$continent)
ui <- fluidPage(
selectInput("continent", "Continent", choices = c("", as.character(continents))),
# @tanho63:
# selectInput("continent", "Continent", choices = c("All", as.character(continents))),
selectInput("country", "Country", choices = NULL),
tableOutput("data")
)
server <- function(input, output, session) {
selected_data <- reactive({
if(input$continent %in% continents) {
gapminder %>%
filter(continent == input$continent)
} else {
gapminder
}
})
observeEvent( input$continent, {
# @tanho63:
updateSelectInput(session, "country",
choices = unique(selected_data()$country))
})
output$data <- renderTable({
selected_data() %>%
filter(country == input$country)
})
}
shinyApp(ui = ui, server = server)Exercise 10.1.5.5
What is at the heart of the problem described at https://community.rstudio.com/t/29307?
Exercise 10.2.3.1
Use a hidden tabset to show additional controls only if the user checks an “advanced” check box.
Solution.
Solution
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxInput("moreControls",
label = "Show advanced controls?",
value = FALSE
)
),
mainPanel(
tabsetPanel(
id = "basic",
type = "hidden",
tabPanelBody("panel1",
numericInput("basicControl", label = "Basic:", 0),
)
),
tabsetPanel(
id = "advanced",
type = "hidden",
tabPanelBody("emptyPanel", style = "display: none"),
tabPanelBody("panel2",
numericInput("advancedCotrol", label = "Advanced:", 1)
)
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$moreControls, {
if (input$moreControls) {
updateTabsetPanel(session, "advanced", selected = "panel2")
} else {
updateTabsetPanel(session, "advanced", selected = "emptyPanel")
}
})
}
shinyApp(ui, server)Exercise 10.2.3.2
Create an app that plots ggplot(diamonds, aes(carat)) but allows the user to choose which geom to use: geom_histogram(), geom_freqpoly(), or geom_density(). Use a hidden tabset to allow the user to select different arguments depending on the geom: geom_histogram() and geom_freqpoly() have a binwidth argument; geom_density() has a bw argument.
Solution.
Solution
library(shiny)
library(ggplot2)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("geom", "Geom function to use",
choices = c("histogram", "freqpoly", "density")
),
tabsetPanel(
id = "params",
type = "hidden",
tabPanel("histogram",
numericInput("hist_bw",
label = "Binwidth", value = 0.1,
min = 0.1, max = 5, step = 0.1
)
),
tabPanel("freqpoly",
numericInput("freqpoly_bw",
label = "Binwidth", value = 0.1,
min = 0.1, max = 5, step = 0.1
)
),
tabPanel("density",
numericInput("density_bw",
label = "Standard deviation of smoothing kernel",
value = 0.01, min = 0.01, max = 1, step = 0.01
)
)
)
),
mainPanel(
plotOutput("gg")
)
)
)
server <- function(input, output, session) {
observeEvent(input$geom, {
updateTabsetPanel(inputId = "params", selected = input$geom)
})
gg_args <- reactive({
switch(input$geom,
histogram = geom_histogram(binwidth = input$hist_bw),
freqpoly = geom_freqpoly(binwidth = input$freqpoly_bw),
density = geom_density(bw = input$density_bw)
)
})
output$gg <- renderPlot({
ggplot(diamonds, aes(carat)) +
gg_args()
})
}
shinyApp(ui, server)Exercise 10.2.3.3
Modify the app you created in the previous exercise to allow the user to choose whether each geom is shown or not (i.e. instead of always using one geom, they can picked 0, 1, 2, or 3). Make sure that you can control the binwidth of the histogram and frequency polygon independently.
Solution.
Solution
library(shiny)
library(ggplot2)
geom_choices <- c("histogram", "freqpoly", "density")
# ----------------------------------------------- #
# Generate the necessary code (as a string) #
# for ggplot, after having chosen one of #
# the available geom functions in the ui #
# ----------------------------------------------- #
# A list could be used, working only with the three
# provided geom choices, but a fuction will be used,
# to provide a template for a possible generalization
# when working with more geom choices and parameters.
geom_choice_code <- function(geom_choice) {
# Using %in% could be a more general case,
# considering more possible geom options.
if (geom_choice == "density") {
return(paste0(
# Simple density
# "geom_", geom_choice, "(bw = input$", geom_choice, "_bw)"
# Match density to the histogram's y-scale
"geom_density(
color = 'blue',
bw = input$density_bw,
aes(y = ..density.. * (nrow(diamonds) * input$histogram_bw))
)"
))
}
return(paste0(
"geom_", geom_choice, "(",
# Improve histograms' visibility
ifelse(geom_choice == "histogram", "fill = 'transparent', color = 'red', ", ""),
"binwidth = input$", geom_choice, "_bw)"
))
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("geom",
label = "Geom function to use", multiple = TRUE,
choices = geom_choices, selected = "histogram"
),
tabsetPanel(
id = "histogram",
type = "hidden",
tabPanelBody("histogram_empty", style = "display: none"),
tabPanelBody("histogram_params",
# This parameter will also be used to scale the y-axis
# when plotting density, so that all graphics
# have a similar y-axis of "count"
numericInput("histogram_bw",
label = "Histogram's binwidth", value = 0.15,
min = 0.1, max = 5, step = 0.1
)
)
),
tabsetPanel(
id = "freqpoly",
type = "hidden",
tabPanelBody("freqpoly_empty", style = "display: none"),
tabPanelBody("freqpoly_params",
numericInput("freqpoly_bw",
label = "freqpoly's binwidth", value = 0.15,
min = 0.1, max = 5, step = 0.1
)
)
),
tabsetPanel(
id = "density",
type = "hidden",
tabPanelBody("density_empty", style = "display: none"),
tabPanelBody("density_params",
numericInput("density_bw",
label = "Standard deviation of smoothing kernel",
value = 0.15, min = 0.01, max = 1, step = 0.01
)
)
)
),
mainPanel(
plotOutput("gg")
)
)
)
server <- function(input, output, session) {
# ------------------------------------------ #
# Update inputs' visibility in sidebar panel #
# ------------------------------------------ #
observeEvent(input$geom, {
# Get non selected geom functions, in order
# to hide their respective parameters
non_selected <- setdiff(geom_choices, input$geom)
purrr::map(
geom_choices,
~ updateTabsetPanel(
inputId = .x,
selected = paste0(
.x,
ifelse(.x %in% non_selected, "_empty", "_params")
)
)
)
# Run this code also when the select input is cleared
}, ignoreNULL = FALSE)
# ------------------------ #
# Retrieve code for ggplot #
# ------------------------ #
gg_args <- reactive({
req(input$geom)
purrr::map_chr(input$geom, geom_choice_code) |>
paste(collapse = " + ")
})
output$gg <- renderPlot({
eval(parse(text = paste0(
"ggplot(diamonds, aes(carat)) + ",
gg_args(), " + ",
"labs(y = 'Count')"
)))
})
}
shinyApp(ui, server)Exercise 10.3.4.1
Take this very simple app based on the initial example in the chapter:
ui <- fluidPage(
selectInput("type", "type", c("slider", "numeric")),
uiOutput("numeric")
)
server <- function(input, output, session) {
output$numeric <- renderUI({
if (input$type == "slider") {
sliderInput("n", "n", value = 0, min = 0, max = 100)
} else {
numericInput("n", "n", value = 0, min = 0, max = 100)
}
})
}How could you instead implement it using dynamic visibility? If you implement dynamic visibility, how could you keep the values in sync when you change the controls?
Solution.
Solution
library(shiny)
parameter_tabs <- tagList(
tags$style("#params { display:none; }"),
tabsetPanel(id = "params",
tabPanel("slider",
sliderInput("my_slider", "n", value = 0, min = 0, max = 100)
),
tabPanel("numeric",
numericInput("my_numeric", "n", value = 0, min = 0, max = 100)
)
)
)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("my_selector", "Input Type",
choices = c("slider", "numeric")
),
parameter_tabs,
),
mainPanel()
)
)
server <- function(input, output, session) {
# if slider changes, update numeric
observeEvent( input$my_slider, {
updateNumericInput(session, "my_numeric", value = isolate(input$my_slider))
})
# if numeric changes update slider
observeEvent( input$my_numeric, {
updateSliderInput(session, "my_slider", value = isolate(input$my_numeric))
})
observeEvent(input$my_selector, {
updateTabsetPanel(session, "params", selected = input$my_selector)
})
}
shinyApp(ui = ui, server = server)Exercise 10.3.4.2
Explain how this app works. Why does the password disappear when you click the enter password button for the second time?
ui <- fluidPage(
actionButton("go", "Enter password"),
textOutput("text")
)
server <- function(input, output, session) {
observeEvent(input$go, {
showModal(modalDialog(
passwordInput("password", NULL),
title = "Please enter your password"
))
})
output$text <- renderText({
if (!isTruthy(input$password)) {
"No password"
} else {
"Password entered"
}
})
}Exercise 10.3.4.3
Add support for date and date-time columns make_ui() and filter_var().
Solution.
Solution
In order to complete this, I had to
- make a new dummy dataframe I called
xin order to test for dates - include checking for
is.Datein themake_uiandfilter_varfunctions - Change
tableOutputandrenderTabletoDT::renderTableOutputandDT::renderTableOutputbecauserenderTablewas rendering the dates as numbers and I think this could be because it usesxtable()for HTML table rendering?
# 8.4.3.2
library(shiny)
library(purrr)
library(tidyverse)
make_ui <- function(x, var) {
if (is.numeric(x)) {
rng <- range(x, na.rm = TRUE)
sliderInput(var, var, min = rng[1], max = rng[2], value = rng)
} else if (is.factor(x)) {
levs <- levels(x)
selectInput(var, var, choices = levs, selected = levs, multiple = TRUE)
} else if (lubridate::is.Date(x)) {
rng <- range(x, na.rm = TRUE)
dateInput(var, var, min = rng[1], max = rng[2], value = rng[1])
} else {
# No control, so don't filter
NULL
}
}
filter_var <- function(x, val) {
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.factor(x)) {
x %in% val
} else if (lubridate::is.Date(x)) {
x %in% val
} else {
TRUE
}
}
library(shiny)
dfs <- keep(ls("package:datasets"), ~ is.data.frame(get(.x, "package:datasets")))
# add a dataframe with dates in it since I cant find one in the datasets above
# rep 5 dates five times, each include 1 factor a-e
x <- data.frame(date = c(rep(as.Date("2020/1/1"), 5),
rep(as.Date("2020/2/2"), 5),
rep(as.Date("2020/3/3"), 5),
rep(as.Date("2020/4/4"), 5),
rep(as.Date("2020/5/5"), 5)),
fac = as.factor(c("a", "b", "c", "d", "e")))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
#selectInput("dataset", label = "Dataset", choices = c(dfs, "x")),
uiOutput("filter")
),
mainPanel(
DT::dataTableOutput("data")
)
)
)
server <- function(input, output, session) {
# data is either my dummy dataset or from datasets
data <- reactive(x)
vars <- reactive(names(data()))
output$filter <- renderUI(
# take eahc column name and make ui
# data()[[.x]] is each column
# and .x is each column name (vars())
map(vars(), ~ make_ui(data()[[.x]], .x))
)
selected <- reactive({
# take each column name and filer var
# with the first argument the column in the data
# and the second argument the input$vars()
# so for date check that input[[date]] in data[[1]]
each_var <- map(vars(), ~ filter_var(data()[[.x]], input[[.x]]))
# notes from @mapaulacaldas
# collapse list of TRUE and FALSE using `&`
# conditions <- list(TRUE, TRUE, TRUE, FALSE)
# purrr::reduce(conditions, `&`) ==
# ((conditions[[1]] & conditions[[2]]) & conditions[[3]]) & conditions[[4]]
reduce(each_var, `&`)
})
# subset the data by the vars that are true
output$data <- DT::renderDataTable(data()[selected(), ])
}
# Run the application
shinyApp(ui = ui, server = server)Exercise 10.3.4.4
(Advanced) If you know the S3 OOP system, consider how you could replace the if blocks in make_ui() and filter_var() with generic functions.
Solution.
Solution
library(shiny)
library(purrr)
make_ui <- function(obj, var) { UseMethod("make_ui") }
make_ui.numeric <- function(x, var) {
rng <- range(x, na.rm = TRUE)
sliderInput(var, var, min = rng[1], max = rng[2], value = rng)
}
make_ui.factor <- function(x, var) {
levs <- levels(x)
selectInput(var, var, choices = levs, selected = levs, multiple = TRUE)
}
make_ui.default <- function(x, var) { NULL }
filter_var <- function(x, val) { UseMethod("filter_var") }
filter_var.numeric <- function(x, val) { !is.na(x) & x >= val[1] & x <= val[2] }
filter_var.factor <- function(x, val) { x %in% val }
filter_var.default <- function(x, val) { TRUE }
dfs <- keep(ls("package:datasets"), ~ is.data.frame(get(.x, "package:datasets")))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("dataset", label = "Dataset", choices = dfs),
uiOutput("filter")
),
mainPanel(
tableOutput("data")
)
)
)
server <- function(input, output, session) {
data <- reactive({
get(input$dataset, "package:datasets")
})
vars <- reactive(names(data()))
output$filter <- renderUI(
map(vars(), ~ make_ui(data()[[.x]], .x))
)
selected <- reactive({
each_var <- map(vars(), ~ filter_var(data()[[.x]], input[[.x]]))
reduce(each_var, `&`)
})
output$data <- renderTable(head(data()[selected(), ], 12))
}
shinyApp(ui = ui, server = server)Exercise 10.3.4.5
(Hard) Make a wizard that allows the user to upload their own dataset. The first page should handle the upload. The second should handle reading it, providing one drop down for each variable that lets the user select the column type. The third page should provide some way to get a summary of the dataset.
Solution.
Solution
I wasn’t really sure what was meant by “some way to get a summary of the dataset” So I’m just using the summary function.
library(shiny)
library(readr)
make_dropdown <- function(name_of_vector) {
selectInput(inputId = name_of_vector, label = name_of_vector, choices =
c("numeric", "character", "logical"))
}
ui <- fluidPage(
tags$style("#wizard { display:none; }"),
tabsetPanel(id = "wizard",
tabPanel("page1",
fileInput("data_input", "input"),
actionButton("page12", "next")
),
tabPanel("page2",
sidebarLayout(
sidebarPanel(
uiOutput("type_of")
),
mainPanel(
tableOutput('type_table')
)),
actionButton("page21", "prev"),
actionButton("page23", "next")
),
tabPanel("page3",
tableOutput("summary_table"),
actionButton("page32", "prev")
)
)
)
server <- function(input, output, session) {
################ WIZARD ###############################
switch_tab <- function(page) {
updateTabsetPanel(session, "wizard", selected = page)
}
observeEvent(input$page12, switch_tab("page2"))
observeEvent(input$page21, switch_tab("page1"))
observeEvent(input$page23, switch_tab("page3"))
observeEvent(input$page32, switch_tab("page2"))
##################### FILE INPUT #######################
dat <- reactive({
req(input$data_input)
read.csv(input$data_input$datapath)
})
##################### TABLE TYPE #######################
# make a dropdown using the names of each column
output$type_of <- renderUI({ map(names(dat()), ~ make_dropdown(.x)) })
# switch the type of column based on the input
# name of vector == "Sepal.Length"
# vector == Sepal.Length
change_type <- function(vector, name_of_vector) {
switch(input[[name_of_vector]],
"numeric" = vector <- as.numeric(vector),
"character" = vector <- as.character(vector),
"logical" = vector <- as.complex(vector)
)
}
# convert the supplied data to a list
# use imap because it is a condensed version o map
# with two arguments == x & name_of_x
# so we don't need to supply it arguments beyond the list!
df<- reactive({
dat() %>%
as.list() %>%
imap(change_type) %>%
as_tibble()
})
# create an output of the data's names
# and their types
output$type_table <- renderTable(data.frame(
names = names(df()),
type = map_chr(df(), function(x) typeof(x)))
)
##################### TABLE OUTPUT #####################
output$summary_table <- renderTable( summary(df()) )
}
shinyApp(ui = ui, server = server)