#' A selectizeInput customized for data frames with column labels #' #' @description #' Copied and modified from the IDEAFilter package #' Adds the option to select "none" which is handled later #' #' @param inputId passed to \code{\link[shiny]{selectizeInput}} #' @param label passed to \code{\link[shiny]{selectizeInput}} #' @param data \code{data.frame} object from which fields should be populated #' @param selected default selection #' @param ... passed to \code{\link[shiny]{selectizeInput}} #' @param col_subset a \code{vector} containing the list of allowable columns to select #' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options #' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options #' @param none_label label for "none" item #' @param maxItems max number of items #' #' @return a \code{\link[shiny]{selectizeInput}} dropdown element #' #' @importFrom shiny selectizeInput #' @export #' columnSelectInput <- function(inputId, label, data, selected = "", ..., col_subset = NULL, placeholder = "", onInitialize, none_label = "No variable selected", maxItems = NULL) { datar <- if (is.reactive(data)) data else reactive(data) col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset) labels <- Map(function(col) { json <- sprintf( IDEAFilter:::strip_leading_ws( ' { "name": "%s", "label": "%s", "dataclass": "%s", "datatype": "%s" }' ), col, attr(datar()[[col]], "label") %||% "", IDEAFilter:::get_dataFilter_class(datar()[[col]]), data_type(datar()[[col]]) ) }, col = names(datar())) if (!"none" %in% names(datar())) { labels <- c("none" = list( sprintf( '\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', none_label ) ), labels) choices <- setNames(names(labels), labels) choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)] } else { choices <- setNames(names(datar()), labels) choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)] } shiny::selectizeInput( inputId = inputId, label = label, choices = choices, selected = selected, ..., options = c(list( render = I( "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); return '
' + '
' + escape(item.data.name) + ' ' + '' + (item.data.dataclass != '' ? ' ' + item.data.dataclass + '' : '' ) + ' ' + (item.data.datatype != '' ? ' ' + item.data.datatype + '' : '' ) + '
' + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + '
'; }, // avoid data vomit splashing on screen when an option is selected item: function(item, escape) { item.data = JSON.parse(item.label); return '
' + escape(item.data.name) + '
'; } }" ) ), if (!is.null(maxItems)) list(maxItems = maxItems)) ) } #' A selectizeInput customized for named vectors #' #' @param inputId passed to \code{\link[shiny]{selectizeInput}} #' @param label passed to \code{\link[shiny]{selectizeInput}} #' @param choices A named \code{vector} from which fields should be populated #' @param selected default selection #' @param ... passed to \code{\link[shiny]{selectizeInput}} #' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options #' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options #' #' @returns a \code{\link[shiny]{selectizeInput}} dropdown element #' @export #' #' @examples #' if (shiny::interactive()) { #' shinyApp( #' ui = fluidPage( #' shiny::uiOutput("select"), #' tableOutput("data") #' ), #' server = function(input, output) { #' output$select <- shiny::renderUI({ #' vectorSelectInput( #' inputId = "variable", label = "Variable:", #' data = c( #' "Cylinders" = "cyl", #' "Transmission" = "am", #' "Gears" = "gear" #' ) #' ) #' }) #' #' output$data <- renderTable( #' { #' mtcars[, c("mpg", input$variable), drop = FALSE] #' }, #' rownames = TRUE #' ) #' } #' ) #' } vectorSelectInput <- function(inputId, label, choices, selected = "", ..., placeholder = "", onInitialize) { datar <- if (shiny::is.reactive(choices)) data else shiny::reactive(choices) labels <- sprintf( IDEAFilter:::strip_leading_ws(' { "name": "%s", "label": "%s" }'), datar(), names(datar()) %||% "" ) choices_new <- stats::setNames(datar(), labels) shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., options = c(list( render = I( "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); return '
' + '
' + escape(item.data.name) + ' ' + '
' + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + '
'; }, // avoid data vomit splashing on screen when an option is selected item: function(item, escape) { item.data = JSON.parse(item.label); return '
' + escape(item.data.name) + '
'; } }" ) )) ) } #' A selectizeInput customized for named vectors of color names supported by #' \code{\link{generate_colors}} #' #' @param inputId passed to \code{\link[shiny]{selectizeInput}} #' @param label passed to \code{\link[shiny]{selectizeInput}} #' @param choices A named \code{vector} from which fields should be populated #' @param selected default selection #' @param previews number of preview colors. Default is 4. #' @param ... passed to \code{\link[shiny]{selectizeInput}} #' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options #' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options #' #' @returns a \code{\link[shiny]{selectizeInput}} dropdown element #' @export #' #' @examples #' if (shiny::interactive()) { #'top_palettes <- c( #'"Perceptual (blue-yellow)" = "viridis", #'"Perceptual (fire)" = "plasma", #'"Colour-blind friendly" = "Okabe-Ito", #'"Qualitative (bold)" = "Dark 2", #'"Qualitative (paired)" = "Paired", #'"Sequential (blues)" = "Blues", #'"Diverging (red-blue)" = "RdBu", #'"Tableau style" = "Tableau 10", #'"Pastel" = "Pastel 1", #'"Rainbow" = "rainbow" #') #' shinyApp( #' ui = fluidPage( #' titlePanel("Color Palette Select Test"), #' colorSelectInput( #' inputId = "palette", #' label = "Color palette", #' choices = top_palettes, #' selected = "viridis" #' ), #' verbatimTextOutput("selected") #' ), #' server = function(input, output, session) { #' output$selected <- renderPrint(input$palette) #' } #' ) #' } colorSelectInput <- function(inputId, label, choices, selected = "", previews = 4, ..., placeholder = "") { vals <- if (shiny::is.reactive(choices)) { choices() } else{ choices } swatch_html <- function(palette_name) { colors <- tryCatch( suppressMessages(generate_colors(previews, palette_name)), error = function(e) rep("#cccccc", 3) ) # Strip alpha channel to ensure valid 6-digit CSS hex colors <- substr(colors, 1, 7) paste0( sprintf( "", colors ), collapse = "" ) } labels <- sprintf( '{"name": "%s", "label": "%s", "swatch": "%s"}', vals, names(vals) %||% "", vapply(vals, swatch_html, character(1)) ) choices_new <- stats::setNames(vals, labels) shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., options = list( render = I( "{ option: function(item, escape) { item.data = JSON.parse(item.label); return '
' + '
' + escape(item.data.name) + '
' + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + '
' + item.data.swatch + '
' + '
'; }, item: function(item, escape) { item.data = JSON.parse(item.label); return '
' + '' + escape(item.data.name) + '' + item.data.swatch + '
'; } }" ) ) ) }