[This article was first published on Saturn Elephant, 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.
The function below generates a Shiny dropdown list including some icons.
library(shiny)
library(awesome)
library(htmltools)
selectInputWithIcons <- function(
inputId, inputLabel, labels, values, icons, iconStyle = 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)
render <- paste0(
"{",
" item: function(item, escape) {",
" return '<span>' + item.icon + ' ' + escape(item.label) + '</span>';",
" },",
" option: function(item, escape) {",
" return '<span>' + escape(item.label) + '</span>';",
" }",
"}"
)
widget <- selectizeInput(
inputId = inputId,
label = inputLabel,
choices = NULL,
selected = selected,
multiple = multiple,
width = width,
options = list(
"options" = options,
"valueField" = "value",
"labelField" = "label",
"render" = I(render),
"items" = as.list(selected)
)
)
attachDependencies(widget, fa_html_dependency(), append = TRUE)
}
ui <- fluidPage(
br(),
selectInputWithIcons(
"slctz",
"Select an animal:",
labels = c("I want a dog", "I want a cat"),
values = c("dog", "cat"),
icons = c("dog", "cat"),
iconStyle = "-size: 3rem; vertical-align: middle;",
selected = "cat"
)
)
server <- function(input, output, session){
observe({
print(input[["slctz"]])
})
}
shinyApp(ui, server)
The other function below has the same purpose, but this one allows to include some icons in the group headers.
library(shiny)
library(awesome)
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 + ",
" ' ' + escape(item.label) + '</div>';",
" },",
" optgroup_header: function(item, escape) {",
" return '<div class=\"optgroup-header\">' + item.icon + ",
" ' ' + 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 {-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 = "-size: 2rem; vertical-align: middle;",
glabels = c("Music", "Computer", "Tools"),
gvalues = c("music", "computer", "tools"),
gicons = c("music", "computer", "toolbox"),
giconStyle = "-size: 3rem; vertical-align: middle;",
selected = "drum"
)
)
server <- function(input, output, session){
observe({
print(input[["slctz"]])
})
}
shinyApp(ui, server)
To leave a comment for the author, please follow the link and comment on their blog: Saturn Elephant.
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.