This blog is inspired from Create a dynamic number of UI elements in Shiny with purrr.
For this exercise, I use the Orange dataset, see:
library(help = "datasets")
My purpose is to create small shiny app in which I dynamically draw the age and circumference of the orange trees depending on the tree ids.
I usually use lists when I need some kind of mapping, for example:
orange_dt <- data.table::as.data.table(Orange)
old_to_new_names <- list(
Tree = "tree_id",
age = "age_days",
circumference = "circumference_mm"
)
data.table::setnames(
x = orange_dt,
old = names(old_to_new_names),
new = unlist(old_to_new_names, use.names = FALSE)
)
str(orange_dt)
# Classes ‘data.table’ and 'data.frame': 35 obs. of 3 variables:
# $ tree_id : Ord.factor w/ 5 levels "3"<"1"<"5"<"2"<..: 2 2 2 2 2 2 2 4 4 4 ...
# $ age_days : num 118 484 664 1004 1231 ...
# $ circumference_mm: num 30 58 87 115 120 142 145 33 69 111 ...
# - attr(*, "formula")=Class 'formula' language circumference ~ age | Tree
# .. ..- attr(*, ".Environment")=<environment: R_EmptyEnv>
# - attr(*, "labels")=List of 2
# ..$ x: chr "Time since December 31, 1968"
# ..$ y: chr "Trunk circumference"
# - attr(*, "units")=List of 2
# ..$ x: chr "(days)"
# ..$ y: chr "(mm)"
# - attr(*, ".internal.selfref")=<externalptr>
As a side note, another possibility is to use named vectors:
orange_dt <- data.table::as.data.table(Orange)
old_to_new_names <- c(
"Tree" = "tree_id",
"age" = "age_days",
"circumference" = "circumference_mm"
)
data.table::setnames(
x = orange_dt,
old = names(old_to_new_names),
new = unname(old_to_new_names)
)
As a matter of fact, apart from data.table, which is a list, I mostly considered lists useful only as named lists. When I came to dynamically create UI elements
in shiny, I realized that unnamed lists can also be very useful.
For example, with this list defined:
plots_info <- list(
list(
plot_id = "age_plot",
header_id = "age_header",
header_prefix = "Age in days | Tree id: ",
variable = "age_days"
),
list(
plot_id = "circumference_plot",
header_id = "circumference_header",
header_prefix = "Circumference in mm | Tree id:",
variable = "circumference_mm"
)
)
I can do the following:
fn <- function(x)
{
print(str(x))
}
lapply(X = plots_info, FUN = fn)
# List of 4
# $ plot_id : chr "age_plot"
# $ header_id : chr "age_header"
# $ header_prefix: chr "Age in days | Tree id: "
# $ variable : chr "age_days"
# NULL
# List of 4
# $ plot_id : chr "circumference_plot"
# $ header_id : chr "circumference_header"
# $ header_prefix: chr "Circumference in mm | Tree id:"
# $ variable : chr "circumference_mm"
# NULL
# [[1]]
# NULL
#
# [[2]]
# NULL
Map(f = fn, plots_info)
# List of 4
# $ plot_id : chr "age_plot"
# $ header_id : chr "age_header"
# $ header_prefix: chr "Age in days | Tree id: "
# $ variable : chr "age_days"
# NULL
# List of 4
# $ plot_id : chr "circumference_plot"
# $ header_id : chr "circumference_header"
# $ header_prefix: chr "Circumference in mm | Tree id:"
# $ variable : chr "circumference_mm"
# NULL
# [[1]]
# NULL
#
# [[2]]
# NULL
Both lappy() and Map() return a list of 2 elements containing NULL.
Meanwhile I learned about purrr::iwalk and purrr::map. They have the advantage that they accept a formula instead of a function. purrr::iwalk is used only for side effects and it just return its input:
out <- purrr::iwalk(
.x = plots_info,
~ {
print(str(.x))
return(42)
}
)
# List of 4
# $ plot_id : chr "age_plot"
# $ header_id : chr "age_header"
# $ header_prefix: chr "Age in days | Tree id: "
# $ variable : chr "age_days"
# NULL
# List of 4
# $ plot_id : chr "circumference_plot"
# $ header_id : chr "circumference_header"
# $ header_prefix: chr "Circumference in mm | Tree id:"
# $ variable : chr "circumference_mm"
# NULL
str(out)
# List of 4
# $ plot_id : chr "age_plot"
# $ header_id : chr "age_header"
# $ header_prefix: chr "Age in days | Tree id: "
# $ variable : chr "age_days"
# NULL
# List of 4
# $ plot_id : chr "circumference_plot"
# $ header_id : chr "circumference_header"
# $ header_prefix: chr "Circumference in mm | Tree id:"
# $ variable : chr "circumference_mm"
# NULL
Use purrr::imap if you need the return value:
out <- purrr::imap(
.x = plots_info,
~ {
print(str(.x))
return(42)
}
)
# List of 4
# $ plot_id : chr "age_plot"
# $ header_id : chr "age_header"
# $ header_prefix: chr "Age in days | Tree id: "
# $ variable : chr "age_days"
# NULL
# List of 4
# $ plot_id : chr "circumference_plot"
# $ header_id : chr "circumference_header"
# $ header_prefix: chr "Circumference in mm | Tree id:"
# $ variable : chr "circumference_mm"
# NULL
str(out)
# List of 2
# $ : num 42
# $ : num 42
For more examples see r-critique.com/functional-programming-in-r-applications-with-data-table.
Here the steps for the little shiny app to exemplify the dynamic building of UI element using purrr:
- define a shiny::uiOutput - this will the container for all our dynamic elements
- define a list containing the information necessary to build the UI elements
- on the server side, call shiny::renderUI using purrr::map to return a shiny::tagList and shiny::splitLayout() for dynamic placing of the element
- also on the server side call render the UI elements using purrr::walk
And here is the complete code:
library(data.table)
# library(help = "datasets")
orange_dt <- data.table::as.data.table(Orange)
data.table::setnames(
x = orange_dt,
old = c("Tree", "age", "circumference"),
new = c("tree_id", "age_days", "circumference_mm")
)
ui_helper <- function()
{
tree_choices <- orange_dt$tree_id
tree_id_ui <- shiny::selectInput(
inputId = "tree_id",
label = "Tree id",
choices = tree_choices,
selected = tree_choices[1],
multiple = TRUE
)
plots_ui <- shiny::uiOutput(outputId = "plots_ui")
shiny::tagList(
shiny::fluidRow(
shiny::column(width = 2, tree_id_ui)),
shiny::fluidRow(plots_ui)
)
}
get_plots_info <- function()
{
list(
list(
plot_id = "age_plot",
header_id = "age_header",
header_prefix = "Age in days | Tree id: ",
variable = "age_days"
),
list(
plot_id = "circumference_plot",
header_id = "circumference_header",
header_prefix = "Circumference in mm | Tree id:",
variable = "circumference_mm"
)
)
}
render_header_and_plots <- function(input, output, filtered_dt_rv)
{
plots_info <- get_plots_info()
purrr::walk(
.x = plots_info,
~ {
output[[.x$header_id]] <- shiny::renderText({
paste(.x$header_prefix, toString(input$tree_id))
})
output[[.x$plot_id]] <- highcharter::renderHighchart({
dt <- filtered_dt_rv()
highcharter::hchart(
dt[[.x$variable]],
color = "#B71C1C",
name = .x$variable
)
})
}
)
}
build_plots_ui <- function()
{
plots_info <- get_plots_info()
plots_ui <- purrr::map(
.x = plots_info,
~ {
shinydashboard::box(
title = shiny::textOutput(outputId = .x$header_id),
solidHeader = TRUE,
collapsible = TRUE,
width = 6,
height = 500,
status = "info",
highcharter::highchartOutput(outputId = .x$plot_id)
)
}
)
shiny::tagList(plots_ui)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ui <- shiny::fluidPage(
ui_helper()
)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
server <- function(input, output, session)
{
filtered_dt_rv <- shiny::reactiveVal(orange_dt)
shiny::observeEvent(
eventExpr = input$tree_id,
handlerExpr = {
tmp <- orange_dt[tree_id %in% input$tree_id]
filtered_dt_rv(tmp)
}
)
output$plots_ui <- shiny::renderUI({
shiny::splitLayout(
build_plots_ui()
)
})
render_header_and_plots(
input = input,
output = output,
filtered_dt_rv = filtered_dt_rv
)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
shiny::shinyApp(ui, server)
The result looks like this:
Hope this gave you some ideas of how to improve your programming of R shiny apps.
Make a promise. Show up. Do the work. Repeat.