diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R index 6c7a55c9..8ac469be 100644 --- a/R/custom_SelectInput.R +++ b/R/custom_SelectInput.R @@ -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) + ''; } - }")), - 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) + ''; } - }")) + }" + ) + )) + ) +} + + +#' 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 + + '
'; + } + }" + ) ) ) } diff --git a/R/data_plots.R b/R/data_plots.R index 0d72e998..cd590cce 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -22,11 +22,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { title = "Create plot", icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), - shiny::helpText(i18n$t('Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.')), + shiny::helpText( + i18n$t( + 'Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.' + ) + ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), shiny::uiOutput(outputId = ns("secondary")), shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("color_palette")), shiny::br(), shiny::actionButton( inputId = ns("act_plot"), @@ -72,14 +77,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::selectInput( inputId = ns("plot_type"), label = i18n$t("File format"), - choices = list( - "png", - "tiff", - "eps", - "pdf", - "jpeg", - "svg" - ) + choices = list("png", "tiff", "eps", "pdf", "jpeg", "svg") ), shiny::br(), # Button @@ -90,12 +88,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ) ) ), - shiny::p("We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", - "View notes in new tab", - target = "_blank", - rel = "noopener noreferrer" - )) + shiny::p( + "We have collected a few notes on visualising data and details on the options included in FreesearchR:", + shiny::tags$a( + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + "View notes in new tab", + target = "_blank", + rel = "noopener noreferrer" + ) + ) ), shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), @@ -116,21 +117,37 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @export data_visuals_server <- function(id, data, + 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" + ), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { ns <- session$ns - rv <- shiny::reactiveValues( - plot.params = NULL, - plot = NULL, - code = NULL - ) + rv <- shiny::reactiveValues(plot.params = NULL, + plot = NULL, + code = NULL) shiny::observe({ - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_plot",title = i18n$t("Create plot")) - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_download",title = i18n$t("Download")) + bslib::accordion_panel_update( + id = "acc_plot", + target = "acc_pan_plot", + title = i18n$t("Create plot") + ) + bslib::accordion_panel_update(id = "acc_plot", + target = "acc_pan_download", + title = i18n$t("Download")) }) # ## --- New attempt @@ -259,12 +276,10 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots( - data = plot_data - ) + plots <- possible_plots(data = plot_data) plots_named <- get_plot_options(plots) |> - lapply(\(.x){ + lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) @@ -284,23 +299,19 @@ data_visuals_server <- function(id, output$secondary <- shiny::renderUI({ shiny::req(input$type) - cols <- c( - rv$plot.params()[["secondary.extra"]], - all_but( - colnames(subset_types( - data(), - rv$plot.params()[["secondary.type"]] - )), - input$primary - ) - ) + cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + subset_types(data(), rv$plot.params()[["secondary.type"]]) + ), input$primary)) columnSelectInput( inputId = ns("secondary"), data = data, selected = cols[1], placeholder = i18n$t("Please select"), - label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) i18n$t("Additional variables") else i18n$t("Secondary variable"), + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + i18n$t("Additional variables") + else + i18n$t("Secondary variable"), multiple = rv$plot.params()[["secondary.multi"]], maxItems = rv$plot.params()[["secondary.max"]], col_subset = cols, @@ -319,10 +330,7 @@ data_visuals_server <- function(id, col_subset = c( "none", all_but( - colnames(subset_types( - data(), - rv$plot.params()[["tertiary.type"]] - )), + colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])), input$primary, input$secondary ) @@ -331,64 +339,59 @@ data_visuals_server <- function(id, ) }) - shiny::observeEvent(input$act_plot, - { - if (NROW(data()) > 0) { - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary - ) + ### Color option + output$color_palette <- shiny::renderUI({ + # shiny::req(input$type) + colorSelectInput( + inputId = ns("color_palette"), + label = i18n$t("Choose color palette"), + choices = palettes + ) + }) - ## If the dictionary holds additional arguments to pass to the - ## plotting function, these are included - if (!is.null(rv$plot.params()[["fun.args"]])){ - parameters <- modifyList(parameters,rv$plot.params()[["fun.args"]]) - } - - shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), { - rv$plot <- rlang::exec( - create_plot, - !!!append_list( - data(), - parameters, - "data" - ) - ) - }) - - rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") - }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, - error = function(err) { - showNotification(paste0(err), type = "err") - } + shiny::observeEvent(input$act_plot, { + if (NROW(data()) > 0) { + tryCatch({ + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary, + color.palette = input$color_palette ) - } - }, - ignoreInit = TRUE - ) + + ## If the dictionary holds additional arguments to pass to the + ## plotting function, these are included + if (!is.null(rv$plot.params()[["fun.args"]])) { + parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) + } + + shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), + { + rv$plot <- rlang::exec(create_plot, + !!!append_list(data(), parameters, "data")) + }) + + rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") + }, # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + }) + } + }, ignoreInit = TRUE) output$code_plot <- shiny::renderUI({ shiny::req(rv$code) prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code)) }) - shiny::observeEvent( - list( - data() - ), - { - shiny::req(data()) + shiny::observeEvent(list(data()), { + shiny::req(data()) - rv$plot <- NULL - } - ) + rv$plot <- NULL + }) output$plot <- shiny::renderPlot({ # shiny::req(rv$plot) @@ -428,16 +431,15 @@ data_visuals_server <- function(id, width = input$width, height = input$height_slide, dpi = 300, - units = "mm", scale = 2 + units = "mm", + scale = 2 ) }) } ) - shiny::observe( - return(rv$plot) - ) + shiny::observe(return(rv$plot)) } ) } @@ -500,9 +502,11 @@ supported_plots <- function() { list( plot_bar_rel = list( fun = "plot_bar", - fun.args =list(style="fill"), + fun.args = list(style = "fill"), descr = i18n$t("Stacked relative barplot"), - note = i18n$t("Create relative stacked barplots to show the distribution of categorical levels"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -511,9 +515,11 @@ supported_plots <- function() { ), plot_bar_abs = list( fun = "plot_bar", - fun.args =list(style="dodge"), + fun.args = list(style = "dodge"), descr = i18n$t("Side-by-side barplot"), - note = i18n$t("Create side-by-side barplot to show the distribution of categorical levels"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -523,7 +529,9 @@ supported_plots <- function() { plot_hbars = list( fun = "plot_hbars", descr = i18n$t("Stacked horizontal bars"), - note = i18n$t("A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -533,7 +541,9 @@ supported_plots <- function() { plot_violin = list( fun = "plot_violin", descr = i18n$t("Violin plot"), - note = i18n$t("A modern alternative to the classic boxplot to visualise data distribution"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), primary.type = c("datatime", "continuous"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -581,7 +591,9 @@ supported_plots <- function() { plot_euler = list( fun = "plot_euler", descr = i18n$t("Euler diagram"), - note = i18n$t("Generate area-proportional Euler diagrams to display set relationships"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), primary.type = c("dichotomous"), secondary.type = c("dichotomous"), secondary.multi = TRUE, @@ -622,7 +634,7 @@ possible_plots <- function(data) { out <- type } else { out <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { if (type %in% .x$primary.type) { .x$descr } @@ -650,12 +662,12 @@ possible_plots <- function(data) { #' get_plot_options() get_plot_options <- function(data) { descrs <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { .x$descr }) |> unlist() supported_plots() |> - (\(.x){ + (\(.x) { .x[match(data, descrs)] })() } @@ -669,6 +681,7 @@ get_plot_options <- function(data) { #' @param sec secondary variable #' @param ter tertiary variable #' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. #' @param ... ignored for now #' #' @name data-plots @@ -678,7 +691,13 @@ get_plot_options <- function(data) { #' #' @examples #' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, type, pri, sec, ter = NULL, ...) { +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { if (!is.null(sec)) { if (!any(sec %in% names(data))) { sec <- NULL @@ -695,13 +714,11 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) { pri = pri, sec = sec, ter = ter, + color.palette = color.palette, ... ) - out <- do.call( - type, - modifyList(parameters, list(data = data)) - ) + out <- do.call(type, modifyList(parameters, list(data = data))) code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") @@ -758,10 +775,14 @@ get_label <- function(data, var = NULL) { #' @examples #' "Lorem ipsum... you know the routine" |> line_break() #' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, lineLength = 20, force = FALSE) { +line_break <- function(data, + lineLength = 20, + force = FALSE) { if (isTRUE(force)) { ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) } else { paste(strwrap(data, lineLength), collapse = "\n") } @@ -793,9 +814,9 @@ wrap_plot_list <- function(data, if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { out <- data |> - (\(.x){ + (\(.x) { if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i){ + purrr::imap(.x, \(.y, .i) { .y + ggplot2::ggtitle(.i) }) } else { @@ -803,12 +824,10 @@ wrap_plot_list <- function(data, } })() |> align_axes() |> - patchwork::wrap_plots( - guides = guides, - axes = axes, - axis_titles = axis_titles, - ... - ) + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) if (!is.null(tag_levels)) { out <- out + patchwork::plot_annotation(tag_levels = tag_levels) } @@ -847,7 +866,9 @@ wrap_plot_list <- function(data, #' @returns list of ggplot2 objects #' @export #' -align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE) { # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 if (ggplot2::is_ggplot(..1)) { @@ -865,7 +886,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x){ + purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -889,7 +910,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { clean_common_axis <- function(p, axis) { purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> unlist() |> - (\(.x){ + (\(.x) { if (is.numeric(.x)) { range(.x) } else { diff --git a/R/generate_colors.R b/R/generate_colors.R new file mode 100644 index 00000000..ae9fa869 --- /dev/null +++ b/R/generate_colors.R @@ -0,0 +1,237 @@ +#' Generate N Colors from a Specified Color Palette +#' +#' A flexible wrapper around multiple color palette libraries, returning N +#' colors as a character vector of hex codes. Supports palettes from +#' \pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}. +#' +#' @param n \code{integer}. Number of colors to generate. Must be a positive +#' integer. +#' @param palette \code{character(1)}. Name of the color palette to use. +#' Case-insensitive. Supported options: +#' \describe{ +#' \item{\strong{viridisLite}}{`"viridis"`, `"magma"`, `"plasma"`, +#' `"inferno"`, `"cividis"`, `"mako"`, `"rocket"`, `"turbo"`} +#' \item{\strong{grDevices}}{`"hcl"`, `"rainbow"`, `"heat"`, +#' `"terrain"`, `"topo"`} +#' \item{\strong{RColorBrewer}}{Any palette name from +#' \code{RColorBrewer::brewer.pal.info}, e.g. `"Set1"`, `"Blues"`, +#' `"Dark2"`. If \code{n} exceeds the palette maximum, colors are +#' interpolated via \code{\link[grDevices]{colorRampPalette}}.} +#' } +#' @param ... Additional arguments passed to the underlying palette function. +#' For example, \code{alpha}, \code{direction}, \code{begin}, \code{end} +#' are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is +#' forwarded to \code{\link[grDevices]{hcl.colors}}. +#' +#' @return A \code{character} vector of length \code{n} containing hex color +#' codes (e.g. \code{"#440154FF"}). +#' +#' @examples +#' # viridisLite palettes +#' generate_colors(5, "viridis") +#' generate_colors(5, "plasma") +#' generate_colors(5, "viridis", alpha = 0.8, direction = -1) +#' +#' # Base R grDevices +#' generate_colors(5, "rainbow") +#' generate_colors(8, "hcl", palette = "Dark 3") +#' +#' # RColorBrewer +#' generate_colors(5, "Set1") +#' generate_colors(5, "Blues") +#' generate_colors(12, "Set1") # interpolates beyond palette max of 9 +#' +#' # Drop-in replacement for viridisLite::viridis() +#' # generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis") +#' +#' @seealso +#' \code{\link[viridisLite]{viridis}}, +#' \code{\link[grDevices]{hcl.colors}}, +#' \code{\link[RColorBrewer]{brewer.pal}} +#' +#' @importFrom viridisLite viridis +#' @importFrom grDevices hcl.colors rainbow heat.colors terrain.colors +#' topo.colors colorRampPalette +#' @importFrom RColorBrewer brewer.pal brewer.pal.info +#' +#' @export +generate_colors <- function(n, palette = "viridis", ...) { + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + + # Function passthrough — call directly with n and ... + if (is.function(palette)) { + return(palette(n, ...)) + } + + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string or a function.") + } + + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string.") + } + + palette_lower <- tolower(palette) + + viridis_palettes <- c( + "viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo" + ) + + if (palette_lower %in% viridis_palettes) { + viridisLite::viridis(n = n, option = palette_lower, ...) + + } else if (palette_lower == "hcl") { + grDevices::hcl.colors(n = n, ...) + + } else if (palette_lower == "rainbow") { + grDevices::rainbow(n = n, ...) + + } else if (palette_lower == "heat") { + grDevices::heat.colors(n = n, ...) + + } else if (palette_lower == "terrain") { + grDevices::terrain.colors(n = n, ...) + + } else if (palette_lower == "topo") { + grDevices::topo.colors(n = n, ...) + + } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { + max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) + grDevices::colorRampPalette(base_colors)(n) + + } else if (palette %in% grDevices::palette.pals()) { + grDevices::colorRampPalette(palette.colors(palette = palette))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + grDevices::hcl.colors(n = n, palette = palette, ...) + + } else { + message(paste0( + "Unknown palette: '", palette, "'. ", + "Falling back to default R colors.\n", + "Available options:\n", + " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", + " grDevices : hcl, rainbow, heat, terrain, topo\n", + " grDevices HCL: use grDevices::hcl.pals() to see all options\n", + " grDevices : use grDevices::palette.pals() to see all options\n", + " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" + )) + viridisLite::viridis(n = n, option = "viridis") + # grDevices::hcl.colors(n = n) + } +} + + +#' Create a Continuous Color Function from a Palette +#' +#' Wraps \code{\link{generate_colors}} into a function that accepts a value +#' between 0 and 1 and returns the corresponding color. Useful for mapping +#' continuous variables to colors. +#' +#' @param palette Passed directly to [generate_colors()]. Either a palette +#' name string or a function. +#' @param n \code{integer}. Resolution of the underlying color ramp — higher +#' values give smoother gradients. Defaults to 256. +#' @param ... Additional arguments passed to [generate_colors()]. +#' +#' @return A function that takes a numeric vector of values in \code{[0, 1]} +#' and returns a character vector of hex colors. +#' +#' @examples +#' pal <- continuous_colors("viridis") +#' pal(0) # first color +#' pal(1) # last color +#' pal(0.5) # midpoint +#' +#' # Map a continuous variable to colors +#' values <- seq(0, 1, length.out = 10) +#' pal(values) +#' +#' # Works with any palette generate_colors() accepts +#' pal <- continuous_colors("plasma", direction = -1) +#' pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red")) +#' +#' @seealso [generate_colors()] +#' @export +continuous_colors <- function(palette = "viridis", n = 256, ...) { + colors <- generate_colors(n, palette, ...) + ramp <- grDevices::colorRamp(colors) + + function(x) { + if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") + rgb_vals <- ramp(x) + grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) + } +} + + +#' Discrete and Continuous Fill Scale Using generate_colors +#' +#' Drop-in replacement for [viridis::scale_fill_viridis()] that works with +#' any palette supported by [generate_colors()]. +#' +#' @param palette Passed to [generate_colors()]. Either a palette name string +#' or a function. +#' @param discrete \code{logical}. If \code{TRUE} (default), a discrete scale +#' is returned. If \code{FALSE}, a continuous scale is returned. +#' @param ... Additional arguments passed to [ggplot2::scale_fill_manual()] +#' (discrete) or [ggplot2::scale_fill_gradientn()] (continuous). +#' +#' @examples +#' library(ggplot2) +#' +#' # Discrete +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) + +#' geom_col() + +#' scale_fill_generate(palette = "Set1") +#' +#' # Continuous +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) + +#' geom_point(shape = 21, size = 3) + +#' scale_fill_generate(palette = "viridis", discrete = FALSE) +#' +#' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] +#' @export +scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "fill", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_fill_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} + +#' @rdname scale_fill_generate +#' @examples +#' ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) + +#' geom_point() + +#' scale_color_generate(palette = "Set1") +#' @export +scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "colour", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_color_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} diff --git a/R/plot_bar.R b/R/plot_bar.R index 4e76550d..909c9edd 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -1,4 +1,5 @@ -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), max_level = 30, ...) { +plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), + color.palette = "viridis", max_level = 30, ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -13,7 +14,8 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi pri = pri, sec = sec, style = style, - max_level = max_level + max_level = max_level, + color.palette = color.palette ) }) @@ -38,8 +40,9 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> -#' plot_bar_single(pri = "cyl", style = "stack") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30) { +#' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") +plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, + color.palette = "viridis") { style <- match.arg(style) if (identical(sec, "none")) { @@ -98,6 +101,7 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " ) + ggplot2::geom_bar(position = style, stat = "identity") + ggplot2::scale_y_continuous(labels = scales::percent) + + scale_fill_generate(palette=color.palette) + ggplot2::ylab("Percentage") + ggplot2::xlab(get_label(data,pri))+ ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) diff --git a/R/plot_box.R b/R/plot_box.R index 072a8095..01911aac 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -20,7 +20,7 @@ #' mtcars |> #' default_parsing() |> #' plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") -plot_box <- function(data, pri, sec, ter = NULL,...) { +plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -31,7 +31,8 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { plot_box_single( data = .ds, pri = pri, - sec = sec + sec = sec, + color.palette=color.palette ) }) @@ -48,9 +49,10 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { #' #' @examples #' mtcars |> plot_box_single("mpg") -#' mtcars |> plot_box_single("mpg","cyl") +#' mtcars |> plot_box_single("mpg","cyl",color.palette="Blues") +#' stRoke::trial |> plot_box_single("age","active",color.palette="Blues") #' gtsummary::trial |> plot_box_single("age","trt") -plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { +plot_box_single <- function(data, pri, sec=NULL, seed = 2103,color.palette="viridis") { set.seed(seed) if (is.null(sec)) { @@ -68,7 +70,7 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { ggplot2::xlab(get_label(data,pri))+ ggplot2::ylab(get_label(data,sec)) + ggplot2::coord_flip() + - viridis::scale_fill_viridis(discrete = discrete, option = "D") + + scale_fill_generate(discrete = discrete,palette = color.palette) + # ggplot2::theme_void() + ggplot2::theme_bw(base_size = 24) + ggplot2::theme( diff --git a/R/plot_euler.R b/R/plot_euler.R index 17345020..27cdf02f 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -102,7 +102,7 @@ ggeulerr <- function( #' plot_euler("mfi_cut", "mdi_cut") #' stRoke::trial |> #' plot_euler(pri="male", sec=c("hypertension")) -plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { +plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="viridis") { set.seed(seed = seed) if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -112,7 +112,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { out <- lapply(ds, \(.x){ .x[c(pri, sec)] |> na.omit() |> - plot_euler_single() + plot_euler_single(color.palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) @@ -130,16 +130,12 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { #' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() -#' mtcars[c("vs", "am")] |> plot_euler_single() -plot_euler_single <- function(data) { - # if (any("categorical" %in% data_type(data))){ - # shape <- "ellipse" - # } else { - # shape <- "circle" - # } +#' mtcars[c("vs", "am")] |> plot_euler_single("magma") +plot_euler_single <- function(data,color.palette="viridis") { data |> ggeulerr(shape = "circle") + + scale_fill_generate(palette=color.palette) + ggplot2::theme_void() + ggplot2::theme( legend.position = "none", diff --git a/R/plot_hbar.R b/R/plot_hbar.R index 5e71d745..0a0ec320 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -8,11 +8,21 @@ #' @examples #' mtcars |> plot_hbars(pri = "carb", sec = "cyl") #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") -#' mtcars |> plot_hbars(pri = "carb", sec = NULL) -plot_hbars <- function(data, pri, sec, ter = NULL) { - out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) - - out +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") +plot_hbars <- function(data, + pri, + sec, + ter = NULL, + color.palette = "viridis") { + vertical_stacked_bars( + data = data, + score = pri, + group = sec, + strata = ter, + color.palette = color.palette + ) } @@ -35,7 +45,9 @@ vertical_stacked_bars <- function(data, l.color = "black", l.size = .5, draw.lines = TRUE, - label.str="{n}\n{round(100 * p,0)}%") { + label.str = "{n}\n{round(100 * p,0)}%", + color.palette = "viridis", + reverse = TRUE) { if (is.null(group)) { df.table <- data[c(score, group, strata)] |> dplyr::mutate("All" = 1) |> @@ -60,15 +72,19 @@ vertical_stacked_bars <- function(data, returnData = TRUE ) - colors <- viridisLite::viridis(nrow(df.table)) + colors <- generate_colors(n = nrow(df.table), palette = color.palette) + ## Colors are reversed by default as that usually gives the best result + if (isTRUE(reverse)) { + colors <- rev(colors) + } contrast_cut <- - sum(contrast_text(colors, threshold = .3) == "white") + contrast_text(colors, threshold = .3) == "white" score_label <- data |> get_label(var = score) group_label <- data |> get_label(var = group) p |> - (\(.x){ + (\(.x) { .x$plot + ggplot2::geom_text( data = .x$rectData[which(.x$rectData$n > @@ -78,20 +94,18 @@ vertical_stacked_bars <- function(data, ggplot2::aes( x = group, y = p_prev + 0.49 * p, - color = as.numeric(score) > contrast_cut, + color = contrast_cut, # label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = sprintf("%2.0f", 100 * p) label = glue::glue(label.str) ) ) + ggplot2::labs(fill = score_label) + - ggplot2::scale_fill_manual(values = rev(colors)) + - ggplot2::theme( - legend.position = "bottom", - axis.title = ggplot2::element_text(), + ggplot2::scale_fill_manual(values = colors) + + ggplot2::theme(legend.position = "bottom", + axis.title = ggplot2::element_text(), ) + ggplot2::xlab(group_label) + ggplot2::ylab(NULL) - # viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D") })() } diff --git a/R/plot_ridge.R b/R/plot_ridge.R index cff6c29b..ba7a3da5 100644 --- a/R/plot_ridge.R +++ b/R/plot_ridge.R @@ -10,7 +10,7 @@ #' default_parsing() |> #' plot_ridge(x = "mpg", y = "cyl") #' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear") -plot_ridge <- function(data, x, y, z = NULL, ...) { +plot_ridge <- function(data, x, y, z = NULL, color.palette="viridis", ...) { if (!is.null(z)) { ds <- split(data, data[z]) } else { @@ -21,6 +21,7 @@ plot_ridge <- function(data, x, y, z = NULL, ...) { ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) + ggridges::geom_density_ridges() + ggridges::theme_ridges() + + scale_fill_generate(palette=color.palette) + ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa() }) diff --git a/R/plot_sankey.R b/R/plot_sankey.R index 4fd879b8..23c1a13a 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -19,7 +19,7 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(pri, sec)] <- data[c(pri, sec)] |> + data <- data[c(pri, sec)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE) @@ -84,16 +84,17 @@ str_remove_last <- function(data, pattern = "\n") { #' ## Dont know why... #' mtcars |> #' default_parsing() |> -#' plot_sankey("cyl", "gear", "vs", color.group = "pri") -#' -#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") -#' # stRoke::trial |> plot_sankey("active", "male") +#' plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno") plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL, + color.palette = "viridis", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -101,12 +102,14 @@ plot_sankey <- function(data, ds <- list(data) } + # browser() out <- lapply(ds, \(.ds) { plot_sankey_single( .ds, pri = pri, sec = sec, + color.palette = color.palette, color.group = color.group, colors = colors, missing.level = missing.level @@ -144,12 +147,22 @@ plot_sankey <- function(data, #' stRoke::trial |> #' default_parsing() |> #' plot_sankey_single("diabetes", "hypertension") +#' +#' +#' # stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma") +#' # stRoke::trial |> plot_sankey_single("active", "male") +#' # stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec") +#' # stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo") plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), - colors = NULL, + color.palette = "viridis", + colors=NULL, missing.level = "Missing", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", ...) { color.group <- match.arg(color.group) @@ -157,53 +170,35 @@ plot_sankey_single <- function(data, data[c(pri, sec)] <- with_labels(data,{ data[c(pri, sec)] |> - dplyr::mutate( - dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop), - dplyr::across(dplyr::where(is.factor), \(.x) { - if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.level) else .x - }) - ) + to_clean_levels() |> + missing_to_text_levels(missing.text=missing.level) }) - ## Aggregate data data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...) - na.color <- "#2986cc" - box.color <- "#1E4B66" + default.color = default.color + box.color = box.color + na.color = na.color if (is.null(colors)) { if (color.group == "sec") { - if (anyNA(data_orig[[sec]])){ - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]]))) - } else { - main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) - } - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[sec]]), levels(data[[sec]]))] + main.colors <- color_levels_gen(data_orig[[sec]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[pri]]))) + secondary.colors <- rep(default.color, length(levels(data[[pri]]))) label.colors <- Reduce(c, lapply(list( secondary.colors, rev(main.colors) ), contrast_text)) } else { - if (anyNA(data_orig[[sec]])){ - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) - } else { - main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) - } - # main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[pri]]), levels(data[[pri]]))] + main.colors <- color_levels_gen(data_orig[[pri]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[sec]]))) + secondary.colors <- rep(default.color, length(levels(data[[sec]]))) label.colors <- Reduce(c, lapply(list( rev(main.colors), secondary.colors ), contrast_text)) } - colors <- c(na.color, main.colors, secondary.colors) - colors[is.na(colors)] <- "grey80" + colors <- c(default.color, main.colors, secondary.colors) + colors[is.na(colors)] <- na.color } else { label.colors <- contrast_text(colors) } @@ -212,8 +207,6 @@ plot_sankey_single <- function(data, sapply(line_break) |> unname() - # browser() - p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) if (color.group == "sec") { @@ -275,3 +268,48 @@ plot_sankey_single <- function(data, panel.border = ggplot2::element_blank() ) } + + +# stRoke::trial["male"] |> to_clean_levels() +to_clean_levels <- function(data,missing.text="Missing"){ + if (is.data.frame(data)){ + data |> + lapply(all_levels_clean) |> + dplyr::bind_cols() + } else { + data |> + all_levels_clean() + } + + + +} + +# stRoke::trial["mrs_1"] |> missing_to_text_levels() +missing_to_text_levels <- function(data,missing.text="Missing"){ + data |> + dplyr::mutate( + dplyr::across(dplyr::where(is.factor), \(.x) { + if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.text) else .x + }) + ) +} + +all_levels_clean <- function(data){ + data |> + (\(.x){ + if (is.logical(.x)) as.factor(.x) else .x + })() |> + (\(.x){ + if (is.factor(.x)) forcats::fct_drop(.x) else .x + })() +} + +# stRoke::trial$mrs_1 |> color_levels_gen() +color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ + out <- generate_colors(n = length(levels(to_clean_levels(data))),palette = palette) + if (anyNA(data)){ + out <- c(out,na.color) + } + out +} diff --git a/R/plot_scatter.R b/R/plot_scatter.R index c2389b08..142c30fd 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -7,7 +7,8 @@ #' #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") -plot_scatter <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -24,6 +25,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { group = ter, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_color_generate(palette=color.palette) } } diff --git a/R/plot_violin.R b/R/plot_violin.R index 4695f4ab..83d11d2a 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -1,4 +1,4 @@ -#' Beatiful violin plot +#' Beautiful violin plot #' #' @returns ggplot2 object #' @export @@ -6,8 +6,9 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") -plot_violin <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl") +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -23,7 +24,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) { response = pri, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_fill_generate(palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) diff --git a/man/colorSelectInput.Rd b/man/colorSelectInput.Rd new file mode 100644 index 00000000..37561b0f --- /dev/null +++ b/man/colorSelectInput.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_SelectInput.R +\name{colorSelectInput} +\alias{colorSelectInput} +\title{A selectizeInput customized for named vectors of color names supported by +\code{\link{generate_colors}}} +\usage{ +colorSelectInput( + inputId, + label, + choices, + selected = "", + previews = 4, + ..., + placeholder = "" +) +} +\arguments{ +\item{inputId}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{label}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{choices}{A named \code{vector} from which fields should be populated} + +\item{selected}{default selection} + +\item{previews}{number of preview colors. Default is 4.} + +\item{...}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{placeholder}{passed to \code{\link[shiny]{selectizeInput}} options} + +\item{onInitialize}{passed to \code{\link[shiny]{selectizeInput}} options} +} +\value{ +a \code{\link[shiny]{selectizeInput}} dropdown element +} +\description{ +A selectizeInput customized for named vectors of color names supported by +\code{\link{generate_colors}} +} +\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) + } + ) +} +} diff --git a/man/continuous_colors.Rd b/man/continuous_colors.Rd new file mode 100644 index 00000000..a9568f11 --- /dev/null +++ b/man/continuous_colors.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate_colors.R +\name{continuous_colors} +\alias{continuous_colors} +\title{Create a Continuous Color Function from a Palette} +\usage{ +continuous_colors(palette = "viridis", n = 256, ...) +} +\arguments{ +\item{palette}{Passed directly to \code{\link[=generate_colors]{generate_colors()}}. Either a palette +name string or a function.} + +\item{n}{\code{integer}. Resolution of the underlying color ramp — higher +values give smoother gradients. Defaults to 256.} + +\item{...}{Additional arguments passed to \code{\link[=generate_colors]{generate_colors()}}.} +} +\value{ +A function that takes a numeric vector of values in \code{[0, 1]} +and returns a character vector of hex colors. +} +\description{ +Wraps \code{\link{generate_colors}} into a function that accepts a value +between 0 and 1 and returns the corresponding color. Useful for mapping +continuous variables to colors. +} +\examples{ +pal <- continuous_colors("viridis") +pal(0) # first color +pal(1) # last color +pal(0.5) # midpoint + +# Map a continuous variable to colors +values <- seq(0, 1, length.out = 10) +pal(values) + +# Works with any palette generate_colors() accepts +pal <- continuous_colors("plasma", direction = -1) +pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red")) + +} +\seealso{ +\code{\link[=generate_colors]{generate_colors()}} +} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index cd9efdfd..5229751a 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -20,25 +20,35 @@ \usage{ data_visuals_ui(id, tab_title = "Plots", ...) -data_visuals_server(id, data, ...) +data_visuals_server( + id, + data, + 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"), + ... +) -create_plot(data, type, pri, sec, ter = NULL, ...) +create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) plot_bar_single( data, pri, sec = NULL, style = c("stack", "dodge", "fill"), - max_level = 30 + max_level = 30, + color.palette = "viridis" ) -plot_box(data, pri, sec, ter = NULL, ...) +plot_box(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_box_single(data, pri, sec = NULL, seed = 2103) +plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis") -plot_hbars(data, pri, sec, ter = NULL) +plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis") -plot_ridge(data, x, y, z = NULL, ...) +plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...) sankey_ready(data, pri, sec, numbers = "count", ...) @@ -49,12 +59,16 @@ plot_sankey( ter = NULL, color.group = "pri", colors = NULL, + color.palette = "viridis", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", missing.level = "Missing" ) -plot_scatter(data, pri, sec, ter = NULL) +plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis") -plot_violin(data, pri, sec, ter = NULL) +plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis") } \arguments{ \item{id}{Module id. (Use 'ns("id")')} @@ -71,6 +85,8 @@ plot_violin(data, pri, sec, ter = NULL) \item{ter}{tertiary variable} +\item{color.palette}{choose color palette. See \code{\link{plot_colors}} for support.} + \item{style}{barplot style passed to geom_bar position argument. One of c("stack", "dodge", "fill")} } @@ -120,7 +136,7 @@ Beautiful sankey plot with option to split by a tertiary group Beautiful violin plot -Beatiful violin plot +Beautiful violin plot } \examples{ create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() @@ -130,7 +146,7 @@ mtcars |> mtcars |> dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> - plot_bar_single(pri = "cyl", style = "stack") + plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") mtcars |> plot_box(pri = "mpg", sec = "gear") mtcars |> plot_box(pri = "mpg", sec="cyl") mtcars |> @@ -140,11 +156,14 @@ mtcars |> default_parsing() |> plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") mtcars |> plot_box_single("mpg") -mtcars |> plot_box_single("mpg","cyl") +mtcars |> plot_box_single("mpg","cyl",color.palette="Blues") +stRoke::trial |> plot_box_single("age","active",color.palette="Blues") gtsummary::trial |> plot_box_single("age","trt") mtcars |> plot_hbars(pri = "carb", sec = "cyl") mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") -mtcars |> plot_hbars(pri = "carb", sec = NULL) +mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") +mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") +mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") mtcars |> default_parsing() |> plot_ridge(x = "mpg", y = "cyl") @@ -169,9 +188,9 @@ mtcars |> ## Dont know why... mtcars |> default_parsing() |> - plot_sankey("cyl", "gear", "vs", color.group = "pri") - - # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") + plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno") mtcars |> plot_scatter(pri = "mpg", sec = "wt") -mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") +mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") +mtcars |> plot_violin(pri = "mpg", sec = "cyl") +mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") } diff --git a/man/generate_colors.Rd b/man/generate_colors.Rd new file mode 100644 index 00000000..94e3bf27 --- /dev/null +++ b/man/generate_colors.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate_colors.R +\name{generate_colors} +\alias{generate_colors} +\title{Generate N Colors from a Specified Color Palette} +\usage{ +generate_colors(n, palette = "viridis", ...) +} +\arguments{ +\item{n}{\code{integer}. Number of colors to generate. Must be a positive +integer.} + +\item{palette}{\code{character(1)}. Name of the color palette to use. +Case-insensitive. Supported options: +\describe{ +\item{\strong{viridisLite}}{\code{"viridis"}, \code{"magma"}, \code{"plasma"}, +\code{"inferno"}, \code{"cividis"}, \code{"mako"}, \code{"rocket"}, \code{"turbo"}} +\item{\strong{grDevices}}{\code{"hcl"}, \code{"rainbow"}, \code{"heat"}, +\code{"terrain"}, \code{"topo"}} +\item{\strong{RColorBrewer}}{Any palette name from +\code{RColorBrewer::brewer.pal.info}, e.g. \code{"Set1"}, \code{"Blues"}, +\code{"Dark2"}. If \code{n} exceeds the palette maximum, colors are +interpolated via \code{\link[grDevices]{colorRampPalette}}.} +}} + +\item{...}{Additional arguments passed to the underlying palette function. +For example, \code{alpha}, \code{direction}, \code{begin}, \code{end} +are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is +forwarded to \code{\link[grDevices]{hcl.colors}}.} +} +\value{ +A \code{character} vector of length \code{n} containing hex color +codes (e.g. \code{"#440154FF"}). +} +\description{ +A flexible wrapper around multiple color palette libraries, returning N +colors as a character vector of hex codes. Supports palettes from +\pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}. +} +\examples{ +# viridisLite palettes +generate_colors(5, "viridis") +generate_colors(5, "plasma") +generate_colors(5, "viridis", alpha = 0.8, direction = -1) + +# Base R grDevices +generate_colors(5, "rainbow") +generate_colors(8, "hcl", palette = "Dark 3") + +# RColorBrewer +generate_colors(5, "Set1") +generate_colors(5, "Blues") +generate_colors(12, "Set1") # interpolates beyond palette max of 9 + +# Drop-in replacement for viridisLite::viridis() +# generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis") + +} +\seealso{ +\code{\link[viridisLite]{viridis}}, +\code{\link[grDevices]{hcl.colors}}, +\code{\link[RColorBrewer]{brewer.pal}} +} diff --git a/man/plot_euler.Rd b/man/plot_euler.Rd index 4f387162..1713585b 100644 --- a/man/plot_euler.Rd +++ b/man/plot_euler.Rd @@ -4,7 +4,7 @@ \alias{plot_euler} \title{Easily plot euler diagrams} \usage{ -plot_euler(data, pri, sec, ter = NULL, seed = 2103) +plot_euler(data, pri, sec, ter = NULL, seed = 2103, color.palette = "viridis") } \arguments{ \item{data}{data} diff --git a/man/plot_euler_single.Rd b/man/plot_euler_single.Rd index c41d1166..f481d5af 100644 --- a/man/plot_euler_single.Rd +++ b/man/plot_euler_single.Rd @@ -4,7 +4,7 @@ \alias{plot_euler_single} \title{Easily plot single euler diagrams} \usage{ -plot_euler_single(data) +plot_euler_single(data, color.palette = "viridis") } \value{ ggplot2 object @@ -19,5 +19,5 @@ data.frame( C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) ) |> plot_euler_single() -mtcars[c("vs", "am")] |> plot_euler_single() +mtcars[c("vs", "am")] |> plot_euler_single("magma") } diff --git a/man/plot_sankey_single.Rd b/man/plot_sankey_single.Rd index 3ff729ac..75ee1086 100644 --- a/man/plot_sankey_single.Rd +++ b/man/plot_sankey_single.Rd @@ -9,8 +9,12 @@ plot_sankey_single( pri, sec, color.group = c("pri", "sec"), + color.palette = "viridis", colors = NULL, missing.level = "Missing", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", ... ) } @@ -44,4 +48,10 @@ mtcars |> stRoke::trial |> default_parsing() |> plot_sankey_single("diabetes", "hypertension") + + + # stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma") + # stRoke::trial |> plot_sankey_single("active", "male") + # stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec") + # stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo") } diff --git a/man/scale_fill_generate.Rd b/man/scale_fill_generate.Rd new file mode 100644 index 00000000..c558722e --- /dev/null +++ b/man/scale_fill_generate.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate_colors.R +\name{scale_fill_generate} +\alias{scale_fill_generate} +\alias{scale_color_generate} +\title{Discrete and Continuous Fill Scale Using generate_colors} +\usage{ +scale_fill_generate(palette = "viridis", discrete = TRUE, ...) + +scale_color_generate(palette = "viridis", discrete = TRUE, ...) +} +\arguments{ +\item{palette}{Passed to \code{\link[=generate_colors]{generate_colors()}}. Either a palette name string +or a function.} + +\item{discrete}{\code{logical}. If \code{TRUE} (default), a discrete scale +is returned. If \code{FALSE}, a continuous scale is returned.} + +\item{...}{Additional arguments passed to \code{\link[ggplot2:scale_manual]{ggplot2::scale_fill_manual()}} +(discrete) or \code{\link[ggplot2:scale_gradient]{ggplot2::scale_fill_gradientn()}} (continuous).} +} +\description{ +Drop-in replacement for \code{\link[viridis:scale_viridis]{viridis::scale_fill_viridis()}} that works with +any palette supported by \code{\link[=generate_colors]{generate_colors()}}. +} +\examples{ +library(ggplot2) + +# Discrete +ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) + + geom_col() + + scale_fill_generate(palette = "Set1") + +# Continuous +ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) + + geom_point(shape = 21, size = 3) + + scale_fill_generate(palette = "viridis", discrete = FALSE) + +ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) + + geom_point() + + scale_color_generate(palette = "Set1") +} +\seealso{ +\code{\link[=scale_color_generate]{scale_color_generate()}}, \code{\link[=generate_colors]{generate_colors()}}, \code{\link[=continuous_colors]{continuous_colors()}} +} diff --git a/man/vertical_stacked_bars.Rd b/man/vertical_stacked_bars.Rd index 52f3c5c0..495588fe 100644 --- a/man/vertical_stacked_bars.Rd +++ b/man/vertical_stacked_bars.Rd @@ -13,7 +13,9 @@ vertical_stacked_bars( l.color = "black", l.size = 0.5, draw.lines = TRUE, - label.str = "{n}\\n{round(100 * p,0)}\%" + label.str = "{n}\\n{round(100 * p,0)}\%", + color.palette = "viridis", + reverse = TRUE ) } \arguments{ diff --git a/tests/testthat/test-plot_colors.R b/tests/testthat/test-plot_colors.R new file mode 100644 index 00000000..c37ea166 --- /dev/null +++ b/tests/testthat/test-plot_colors.R @@ -0,0 +1,146 @@ +library(testthat) + +# ── Helpers ─────────────────────────────────────────────────────────────────── + +is_hex_color <- function(x) { + all(grepl("^#[0-9A-Fa-f]{6}([0-9A-Fa-f]{2})?$", x)) +} + +# ── Input validation ────────────────────────────────────────────────────────── + +test_that("n must be a single positive integer", { + expect_error(generate_colors(0), "`n` must be a single positive integer") + expect_error(generate_colors(-1), "`n` must be a single positive integer") + expect_error(generate_colors(1.5), "`n` must be a single positive integer") + expect_error(generate_colors(c(2, 3)), "`n` must be a single positive integer") + expect_error(generate_colors("5"), "`n` must be a single positive integer") +}) + +test_that("palette must be a single character string or function", { + expect_error(generate_colors(5, 123), "`palette` must be a single character string") + expect_error(generate_colors(5, c("a", "b")), "`palette` must be a single character string") +}) + +test_that("unknown palette falls back to hcl.colors with a message", { + expect_message( + result <- generate_colors(5, "notapalette"), + "Unknown palette: 'notapalette'" + ) + expect_equal(length(result), 5) + expect_true(is_hex_color(result)) +}) + +# ── Return type and length ──────────────────────────────────────────────────── + +test_that("output is a character vector of correct length for each palette family", { + palettes <- c("viridis", "plasma", "rainbow", "heat", "terrain", "topo", "Set1", "Blues") + for (pal in palettes) { + result <- generate_colors(5, pal) + expect_true(is.character(result), label = paste0("is.character [", pal, "]")) + expect_equal(length(result), 5, label = paste0("length == 5 [", pal, "]")) + } +}) + +test_that("output colors are valid hex codes", { + palettes <- c("viridis", "magma", "rainbow", "hcl", "Set1", "Blues") + for (pal in palettes) { + result <- generate_colors(5, pal) + expect_true(is_hex_color(result), label = paste0("hex check [", pal, "]")) + } +}) + +test_that("n = 1 works for all palette families", { + expect_equal(length(generate_colors(1, "viridis")), 1) + expect_equal(length(generate_colors(1, "rainbow")), 1) + expect_equal(length(generate_colors(1, "Set1")), 1) +}) + +# ── viridisLite ─────────────────────────────────────────────────────────────── + +test_that("all viridisLite palettes return correct length", { + viridis_palettes <- c("viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo") + for (pal in viridis_palettes) { + expect_equal(length(generate_colors(6, pal)), 6, label = paste0("length [", pal, "]")) + } +}) + +test_that("viridisLite palette names are case-insensitive", { + expect_equal(generate_colors(5, "VIRIDIS"), generate_colors(5, "viridis")) + expect_equal(generate_colors(5, "Plasma"), generate_colors(5, "plasma")) +}) + +test_that("extra args are forwarded to viridisLite (direction)", { + fwd <- generate_colors(5, "viridis", direction = 1) + rev <- generate_colors(5, "viridis", direction = -1) + expect_false(identical(fwd, rev)) +}) + +# ── grDevices ───────────────────────────────────────────────────────────────── + +test_that("grDevices palettes return correct length", { + for (pal in c("hcl", "rainbow", "heat", "terrain", "topo")) { + expect_equal(length(generate_colors(7, pal)), 7, label = paste0("length [", pal, "]")) + } +}) + +test_that("grDevices palette names are case-insensitive", { + expect_equal(generate_colors(5, "Rainbow"), generate_colors(5, "rainbow")) + expect_equal(generate_colors(5, "HEAT"), generate_colors(5, "heat")) +}) + +# ── RColorBrewer ────────────────────────────────────────────────────────────── + +test_that("RColorBrewer returns exactly n colors for any n >= 1", { + expect_equal(length(generate_colors(1, "Set1")), 1) # below brewer min, slices + expect_equal(length(generate_colors(2, "Set1")), 2) # below brewer min, slices + expect_equal(length(generate_colors(3, "Set1")), 3) # at brewer min + expect_equal(length(generate_colors(9, "Set1")), 9) # at brewer max + expect_equal(length(generate_colors(15, "Set1")), 15) # above brewer max, interpolates +}) + +test_that("RColorBrewer n < 3 does not warn or error", { + expect_no_warning(generate_colors(1, "Set1")) + expect_no_warning(generate_colors(2, "Blues")) +}) + +test_that("RColorBrewer output is valid hex for all n", { + expect_true(is_hex_color(generate_colors(1, "Blues"))) + expect_true(is_hex_color(generate_colors(9, "Blues"))) + expect_true(is_hex_color(generate_colors(20, "Blues"))) +}) + +test_that("RColorBrewer sequential and diverging palettes work", { + expect_equal(length(generate_colors(5, "Blues")), 5) + expect_equal(length(generate_colors(5, "RdBu")), 5) +}) + +# ── Function passthrough ────────────────────────────────────────────────────── + +test_that("palette accepts a function directly", { + result <- generate_colors(5, viridisLite::viridis) + expect_equal(length(result), 5) + expect_true(is_hex_color(result)) +}) + +test_that("palette accepts an anonymous function", { + result <- generate_colors(5, \(n) rep("#FF0000FF", n)) + expect_equal(result, rep("#FF0000FF", 5)) +}) + +test_that("error message mentions function as valid input type", { + expect_error(generate_colors(5, 123), "single character string or a function") +}) + +# ── Fallback ────────────────────────────────────────────────────────────────── + +test_that("fallback message includes available options", { + expect_message(generate_colors(5, "notapalette"), "viridisLite") + expect_message(generate_colors(5, "notapalette"), "RColorBrewer") +}) + +test_that("fallback returns correct length and valid hex colors", { + result <- suppressMessages(generate_colors(8, "notapalette")) + expect_equal(length(result), 8) + expect_true(is_hex_color(result)) +})