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:
r_shiny_dynamic_ui  


  

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.