mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
feat: added option to choose color palettes for all available plots. this includes a custom function to generate colors from several palettes as well as a select function to include color previews.
This commit is contained in:
parent
2d062e0ac5
commit
6c850847b7
21 changed files with 1110 additions and 251 deletions
|
|
@ -20,30 +20,36 @@
|
|||
#' @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)
|
||||
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('
|
||||
IDEAFilter:::strip_leading_ws(
|
||||
'
|
||||
{
|
||||
"name": "%s",
|
||||
"label": "%s",
|
||||
"dataclass": "%s",
|
||||
"datatype": "%s"
|
||||
}'),
|
||||
}'
|
||||
),
|
||||
col,
|
||||
attr(datar()[[col]], "label") %||% "",
|
||||
IDEAFilter:::get_dataFilter_class(datar()[[col]]),
|
||||
|
|
@ -52,12 +58,25 @@ columnSelectInput <- function(
|
|||
}, 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)
|
||||
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)]
|
||||
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)]
|
||||
choices <- choices[match(if (length(col_subsetr()) == 0 ||
|
||||
isTRUE(col_subsetr() == ""))
|
||||
choices
|
||||
else
|
||||
col_subsetr(), choices)]
|
||||
}
|
||||
|
||||
shiny::selectizeInput(
|
||||
|
|
@ -66,8 +85,9 @@ columnSelectInput <- function(
|
|||
choices = choices,
|
||||
selected = selected,
|
||||
...,
|
||||
options = c(
|
||||
list(render = I("{
|
||||
options = c(list(
|
||||
render = I(
|
||||
"{
|
||||
// format the way that options are rendered
|
||||
option: function(item, escape) {
|
||||
item.data = JSON.parse(item.label);
|
||||
|
|
@ -95,9 +115,10 @@ columnSelectInput <- function(
|
|||
escape(item.data.name) +
|
||||
'</div>';
|
||||
}
|
||||
}")),
|
||||
if (!is.null(maxItems)) list(maxItems = maxItems)
|
||||
)
|
||||
}"
|
||||
)
|
||||
), if (!is.null(maxItems))
|
||||
list(maxItems = maxItems))
|
||||
)
|
||||
}
|
||||
|
||||
|
|
@ -150,7 +171,10 @@ vectorSelectInput <- function(inputId,
|
|||
...,
|
||||
placeholder = "",
|
||||
onInitialize) {
|
||||
datar <- if (shiny::is.reactive(choices)) data else shiny::reactive(choices)
|
||||
datar <- if (shiny::is.reactive(choices))
|
||||
data
|
||||
else
|
||||
shiny::reactive(choices)
|
||||
|
||||
labels <- sprintf(
|
||||
IDEAFilter:::strip_leading_ws('
|
||||
|
|
@ -170,8 +194,9 @@ vectorSelectInput <- function(inputId,
|
|||
choices = choices_new,
|
||||
selected = selected,
|
||||
...,
|
||||
options = c(
|
||||
list(render = I("{
|
||||
options = c(list(
|
||||
render = I(
|
||||
"{
|
||||
// format the way that options are rendered
|
||||
option: function(item, escape) {
|
||||
item.data = JSON.parse(item.label);
|
||||
|
|
@ -190,7 +215,123 @@ vectorSelectInput <- function(inputId,
|
|||
escape(item.data.name) +
|
||||
'</div>';
|
||||
}
|
||||
}"))
|
||||
}"
|
||||
)
|
||||
))
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' 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(
|
||||
"<span style='display:inline-block;width:12px;height:12px;background:%s;border-radius:2px;margin-right:1px;'></span>",
|
||||
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 '<div style=\"padding:3px 12px\">' +
|
||||
'<div><strong>' + escape(item.data.name) + '</strong></div>' +
|
||||
(item.data.label != '' ? '<div><small>' + escape(item.data.label) + '</small></div>' : '') +
|
||||
'<div style=\"margin-top:4px\">' + item.data.swatch + '</div>' +
|
||||
'</div>';
|
||||
},
|
||||
item: function(item, escape) {
|
||||
item.data = JSON.parse(item.label);
|
||||
return '<div style=\"display:flex;align-items:center;gap:6px\">' +
|
||||
'<span>' + escape(item.data.name) + '</span>' +
|
||||
item.data.swatch +
|
||||
'</div>';
|
||||
}
|
||||
}"
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue