Shiny dropdown input with groups decorated with icons

Question

In a comment to this answer, @Vlad asked for a way to get, in a Shiny app, a dropdown input with groups decorated with icons. No answer has been given, so I ask the question.

Answer 1

Here is a solution with selectizeInput:

library(shiny)
library(fontawesome)
library(htmltools)

selectInputWithIcons <- function(
    inputId, inputLabel, 
    groupsizes, labels, values, icons, iconStyle = NULL,
    glabels, gvalues, gicons, giconStyle = NULL,
    selected = NULL, multiple = FALSE, width = NULL
){
  options <- mapply(function(label, value, icon){
    list(
      "label" = label,
      "value" = value,
      "icon"  = as.character(fa_i(icon, style = iconStyle))
    )
  }, labels, values, icons, SIMPLIFY = FALSE, USE.NAMES = FALSE)
  groups <- rep(gvalues, groupsizes)
  for(i in seq_along(options)) {
    options[[i]][["group"]] <- groups[i]
  }
  optgroups <- mapply(function(label, value, icon){
    list(
      "label" = label,
      "value" = value,
      "icon"  = as.character(fa_i(icon, style = giconStyle))
    )
  }, glabels, gvalues, gicons, SIMPLIFY = FALSE, USE.NAMES = FALSE)
  
  render <- paste0(
    "{",
    "  item: function(item, escape) {", 
    "    return '<div class=\"item\">' + item.icon + ",
    "           '&nbsp;' + escape(item.label) + '</div>';",
    "  },",
    "  optgroup_header: function(item, escape) {", 
    "    return '<div class=\"optgroup-header\">' + item.icon + ", 
    "           '&nbsp;' + escape(item.label) + '</div>';",
    "  }",
    "}"
  )
  widget <- selectizeInput(
    inputId  = inputId, 
    label    = inputLabel,
    choices  = NULL, 
    selected = selected,
    multiple = multiple,
    width    = width,
    options  = list( 
      "options"    = options,
      "optgroups"  = optgroups,
      "valueField" = "value", 
      "labelField" = "label",
      "optgroupField" = "group",
      "render"     = I(render),
      "items"     = as.list(selected)
    )
  )
  attachDependencies(widget, fa_html_dependency(), append = TRUE)
}


ui <- fluidPage(
  tags$head(
    tags$style(HTML(".optgroup-header {font-size: 21px !important;}"))
  ),
  br(),
  selectInputWithIcons(
    "slctz",
    "Select something:",
    groupsizes = c(2, 2, 2),
    labels    = c("Drum", "Guitar", "Mouse", "Keyboard", "Hammer", "Screwdriver"),
    values    = c("drum", "guitar", "mouse", "keyboard", "hammer", "screwdriver"),
    icons     = c("drum", "guitar", "computer-mouse", "keyboard", "hammer", "screwdriver"),
    iconStyle = "font-size: 2rem; vertical-align: middle;",
    glabels   = c("Music", "Computer", "Tools"),
    gvalues   = c("music", "computer", "tools"),
    gicons    = c("music", "computer", "toolbox"),
    giconStyle = "font-size: 3rem; vertical-align: middle;",
    selected  = "drum"
  )
)

server <- function(input, output, session){
  
  observe({
    print(input[["slctz"]])
  })
  
}

shinyApp(ui, server)