From 5921c9281dc72ec637ba104f9906ace44f122b64 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 11 Jan 2026 09:38:32 -0500 Subject: [PATCH 1/4] refactor by_aesthetics.R --- R/by_aesthetics.R | 581 ++++++++++++++++++++++------------------------ 1 file changed, 276 insertions(+), 305 deletions(-) diff --git a/R/by_aesthetics.R b/R/by_aesthetics.R index 9216bd26..e1f2debc 100755 --- a/R/by_aesthetics.R +++ b/R/by_aesthetics.R @@ -12,6 +12,7 @@ by_aesthetics = function(settings) { ) ) + # Detect grouping characteristics by_ordered = FALSE by_continuous = !null_by && inherits(datapoints$by, c("numeric", "integer")) if (isTRUE(by_continuous) && type %in% c("l", "b", "o", "ribbon", "polygon", "polypath", "boxplot")) { @@ -21,14 +22,14 @@ by_aesthetics = function(settings) { by_ordered = is.ordered(by) } - if (null_by) { - ngrps = 1L + ngrps = if (null_by) { + 1L } else if (is.factor(by)) { - ngrps = nlevels(by) + nlevels(by) } else if (by_continuous) { - ngrps = 100L + 100L } else { - ngrps = length(unique(by)) + length(unique(by)) } pch = by_pch(ngrps = ngrps, type = type, pch = pch) @@ -71,282 +72,281 @@ by_aesthetics = function(settings) { # -## subsidiary functions ----- +## helper functions ----- # -by_col = function(col, palette, alpha, by_ordered, by_continuous, ngrps, adjustcolor) { - ordered = by_ordered - gradient = by_continuous - if (is.null(alpha)) alpha = 1 - if (is.null(ordered)) ordered = FALSE - if (is.null(gradient)) gradient = FALSE - assert_logical(ordered) - assert_logical(gradient) - if (gradient) { - ngrps = 100L +apply_alpha = function(cols, alpha, adjustcolor) { + if (is.null(cols) || is.null(alpha) || identical(alpha, 0)) { + return(cols) } - - # pal_qual = get_tpar("palette.qualitative", default = NULL) - pal_theme = get_tpar("palette.qualitative", default = NULL) - theme_flag = !is.null(pal_theme) + adjustcolor(cols, alpha.f = alpha) +} - # palette = substitute(palette, env = parent.env(environment())) +is_by_keyword = function(x) { + is.character(x) && length(x) == 1 && !is.na(x) && identical(x, "by") +} + +resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcolor) { + # Not manual colors - defer to palette handling + + if (is.null(col) || !is.atomic(col) || !is.vector(col)) { + return(list(handled = FALSE, cols = NULL)) + } - # special "by" convenience keyword (will treat as NULL & handle grouping below) - if (!anyNA(col) && !is.null(col) && length(col) == 1 && col == "by") col = NULL + cols = col + if (length(cols) == 1) { + cols = rep(cols, ngrps) + } else if (length(cols) < ngrps) { + cols = expand_colors(cols, ngrps, gradient) + } - # - ## Base case: If no color or palette provided, pass colors as a sequence of - ## numbers (will inherit from / cycle over the user's default palette) - - if (is.null(col) && (is.null(palette) && !theme_flag)) { - if (ngrps <= length(palette()) && !ordered) { - col = palette()[seq_len(ngrps)] - if (alpha) col = adjustcolor(col, alpha.f = alpha) + # Map numeric indices to palette colors (unless ordered) + if (!ordered && is.numeric(cols)) { + base_pal = grDevices::palette() + cols = if (ngrps <= length(base_pal)) { + base_pal[cols] } else { - # fallback to restricted viridis palette - col = colorRampPalette( - hcl.colors(n = 100, palette = "Viridis", alpha = alpha)[(100 * 0.1 + 1):(100 * 0.9)], - alpha = TRUE - )(ngrps) + grDevices::hcl.colors(max(cols), alpha = alpha)[cols] } - if (gradient || ordered) col = rev(col) - return(col) } - # - ## Next simplest case: No palette, but color(s) provided directly. We do - ## some simple sanity checks, apply alpha transparency and return as-is. - - if (is.atomic(col) && is.vector(col)) { - if (length(col) == 1) { - col = rep(col, ngrps) - if (alpha) col = adjustcolor(col, alpha.f = alpha) - return(col) - } else if (length(col) < ngrps) { - # if (!gradient) { - # stop(sprintf("`col` must be of length 1, or greater than or equal to %s.", ngrps), call. = FALSE) - # } else { - # # interpolate gradient colors - # col = colorRampPalette(colors = col, alpha = TRUE)(ngrps) - # } - # if manual colours < ngrps, either (1) interpolate for gradient - # colors, or (2) recycle for discrete colours - if (gradient) { - col = colorRampPalette(colors = col, alpha = TRUE)(ngrps) - } else { - ncolsstr = paste0("(", length(col), ")") - ngrpsstr = paste0("(", ngrps, ")") - warning( - "\nFewer colours ", ncolsstr, " provided than than there are groups ", - ngrpsstr, ". Recycling to make up the shortfall." - ) - col = rep_len(col, ngrps) - } - - } - if (gradient) { - col = rev(col) - } else if (!ordered && is.numeric(col)) { - # col = palette()[col] - if (ngrps <= length(palette())) { - col = palette()[col] - # if (alpha) col = adjustcolor(col, alpha.f = alpha) + if (gradient) { + cols = rev(cols) + } + + cols = apply_alpha(cols, alpha, adjustcolor) + list(handled = TRUE, cols = cols) +} + +resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradient, alpha, adjustcolor) { + palette_choice = palette + + # Pick theme palette if no explicit palette provided + if (is.null(palette_choice) && !is.null(theme_palette)) { + palette_choice = theme_palette + if (length(theme_palette) == 1) { + # Check if theme palette needs to switch to sequential + use_sequential = FALSE + idx = match_pal(theme_palette, palette.pals()) + if (!is.na(idx) && idx >= 1L) { + max_colors = length(palette.colors(palette = palette.pals()[idx])) + use_sequential = ngrps >= max_colors || ordered } else { - col = hcl.colors(max(col), alpha = alpha)[col] + idx = match_pal(theme_palette, hcl.pals()) + use_sequential = !is.na(idx) && idx >= 1L && gradient } - } - if (anyNA(col) || is.character(col)) { - if (alpha) col = adjustcolor(col, alpha.f = alpha) - return(col) - } - } - - - # - ## Theme case: No palette provided, but fallback to tinytheme palette - - # we need to fix palette string, determine if in palette.pals() and then - # determine no. of groups, before kicking over to sequential - if (is.null(palette) && theme_flag) { - if (length(pal_theme) == 1) { - qual_match = match_pal(pal_theme, palette.pals()) - if (!is.na(qual_match)) { - if (ngrps >= get_pal_lens(pal_theme) || ordered) { - pal_theme = get_tpar("palette.sequential", default = NULL) - } - # mostly a catch for x-gradient fills, e.g. type_ridge - } else if (gradient && !is.na(match_pal(pal_theme, hcl.pals()))) { - pal_theme = get_tpar("palette.sequential", default = NULL) + if (use_sequential) { + palette_choice = get_tpar("palette.sequential", default = NULL) } } - if (length(pal_theme) == 1) { - palette_fun = gen_pal_fun(pal = pal_theme, gradient = gradient, alpha = alpha) - args = list(n = ngrps, palette = pal_theme, alpha = alpha) - } - palette = pal_theme } - - if (is.null(palette)) { - if (ngrps <= length(palette()) && !ordered && !gradient) { - palette_fun = function(alpha) adjustcolor(palette(), alpha) # must be function to avoid arg ambiguity - args = list(alpha = alpha) + + if (is.null(palette_choice)) { + # Default palette selection (alpha applied at end) + base_pal = grDevices::palette() + if (ngrps <= length(base_pal) && !ordered && !gradient) { + cols = base_pal[seq_len(ngrps)] + } else if (ngrps <= 8 && !ordered) { + cols = grDevices::palette.colors(n = ngrps, palette = "R4") + } else if (!gradient && !ordered) { + cols = grDevices::hcl.colors(n = ngrps, palette = "Viridis") } else { - if (ngrps <= 8 && !ordered) { # ngrps < 100 so we know gradient is FALSE too - palette = "R4" - palette_fun = palette.colors - } else { - palette = "Viridis" - if (!gradient && !ordered) { - palette_fun = hcl.colors - } else { - palette_fun_gradient = function(n, palette, from = 0.1, to = 0.9, alpha = 1) { - colorRampPalette( - hcl.colors(n = 100, palette = palette, alpha = alpha)[(100 * from + 1):(100 * to)], - alpha = TRUE - )(n) - } - palette_fun = palette_fun_gradient - } - } - args = list(n = ngrps, palette = palette, alpha = alpha) + # Restricted viridis for gradient/ordered (excludes extreme ends) + cols = colorRampPalette( + grDevices::hcl.colors(n = 100, palette = "Viridis")[11:90], + alpha = TRUE + )(ngrps) } + cols = apply_alpha(cols, alpha, adjustcolor) } else { - if (is.character(palette)) { - # special case: if vector of character strings, we assume that the user - # must have passed a vector of colours (e.g., c("red", "blue")) rather - # than a known/named colour palette (e.g. "Harmonic") - if (length(palette) > 1) { - palette_fun = "c" - if (!is.null(alpha)) palette = adjustcolor(palette, alpha.f = alpha) - args = as.list(palette) - if (length(args) < ngrps && length(args) != 1) { - # if manual colours < ngrps, either (1) interpolate for gradient - # colors, or (2) recycle for discrete colours - if (gradient) { - args = list(colorRampPalette(args, alpha = TRUE)(ngrps)) - } else { - ncolsstr = paste0("(", length(args), ")") - ngrpsstr = paste0("(", ngrps, ")") - warning( - "\nFewer colours ", ncolsstr, " provided than than there are groups ", - ngrpsstr, ". Recycling to make up the shortfall." - ) - args = rep_len(args, ngrps) - } - } - } else { - palette_fun = gen_pal_fun(palette, gradient = gradient, alpha = alpha, n = ngrps) - args = list(n = ngrps, palette = palette, alpha = alpha) - } - } else if (inherits(palette, c("call", "name"))) { - # catch for when using passes palette as named object (e.g, - # pal26 = palette.colors("Alphabet")) - if (inherits(palette, "name") && is.character(eval(palette))) { - args = as.list(eval(palette)) - palette_fun = "c" - } else { - args = as.list(palette) - palette_fun = paste(args[[1]]) - args[[1]] = NULL + cols = palette_from_spec( + palette = palette_choice, + ngrps = ngrps, + gradient = gradient, + ordered = ordered, + alpha = alpha, + adjustcolor = adjustcolor + ) + } + + if (gradient || ordered) cols = rev(cols) + cols +} + +palette_from_spec = function(palette, ngrps, gradient, ordered, alpha, adjustcolor) { + cols = NULL + palette_fun = NULL + args = NULL + + # Determine colors or palette function based on spec type + # Note: alpha is NOT passed to palette functions; it's applied uniformly at the end + if (is.character(palette) && length(palette) > 1) { + # Direct color vector + cols = palette + } else if (is.character(palette)) { + # Named palette string + palette_fun = gen_pal_fun(palette, gradient = gradient, alpha = NULL, n = ngrps) + args = list(n = ngrps, palette = palette, alpha = NULL) + } else if (inherits(palette, c("call", "name"))) { + # Expression or symbol + if (inherits(palette, "name")) { + eval_palette = tryCatch(eval(palette), error = function(e) NULL) + if (is.character(eval_palette)) { + cols = eval_palette } - # catch for direct vector or list + } + if (is.null(cols)) { + args = as.list(palette) + palette_fun = paste(args[[1]]) + args[[1]] = NULL if (palette_fun %in% c("c", "list")) { - if (palette_fun == "list") palette_fun = "c" - if (!is.null(alpha)) args = lapply(args, function(a) adjustcolor(a, alpha.f = alpha)) - if (length(args) < ngrps && length(args) != 1) { - # if manual colours < ngrps, either (1) interpolate for gradient - # colors, or (2) recycle for discrete colours - if (gradient) { - args = list(colorRampPalette(args, alpha = TRUE)(ngrps)) - } else { - ncolsstr = paste0("(", length(args), ")") - ngrpsstr = paste0("(", ngrps, ")") - warning( - "\nFewer colours ", ncolsstr, " provided than than there are groups ", - ngrpsstr, ". Recycling to make up the shortfall." - ) - args = rep_len(args, ngrps) - } - } + cols = unlist(args, recursive = TRUE, use.names = FALSE) } else { args[["n"]] = ngrps - # remove unnamed arguments to prevent unintentional argument sliding - if (any(names(args) == "")) args[[which(names(args) == "")]] = NULL + if (any(names(args) == "")) args[which(names(args) == "")] = NULL } - } else if (inherits(palette, "function")) { - args = list() - palette_fun = palette - } else { - stop( - "\nInvalid palette argument. Must be a recognized keyword, or a ", - "palette-generating function with named arguments.\n" - ) } + } else if (inherits(palette, "function")) { + palette_fun = palette + args = list() + } else { + stop( + "\nInvalid palette argument. Must be a recognized keyword, or a ", + "palette-generating function with named arguments.\n" + ) } - cols = tryCatch( - do.call(palette_fun, args), - error = function(e) do.call(eval(palette), args) # catch for bespoke palette generating funcs - ) - - if (length(cols) > ngrps) cols = cols[1:ngrps] + # Generate colors from palette function if needed + if (is.null(cols) && !is.null(palette_fun)) { + cols = tryCatch( + do.call(palette_fun, args), + error = function(e) do.call(eval(palette), args) + ) + } - # For gradient and ordered colors, we'll run high to low - if (gradient || ordered) cols = rev(cols) + # Uniform post-processing + cols = expand_colors(cols, ngrps, gradient) + apply_alpha(cols, alpha, adjustcolor) +} - return(cols) +warn_recycle_colors = function(ncols, ngrps) { + warning( + "\nFewer colours (", ncols, ") provided than there are groups (", + ngrps, "). Recycling to make up the shortfall." + ) } -# Some utility functions for palette matching, etc. +expand_colors = function(values, ngrps, gradient) { + if (length(values) == 1) { + return(rep(values, ngrps)) + } + if (length(values) >= ngrps) { + return(values[seq_len(ngrps)]) + } + if (gradient) { + return(colorRampPalette(colors = values, alpha = TRUE)(ngrps)) + } + warn_recycle_colors(length(values), ngrps) + rep_len(values, ngrps) +} -match_pal = function(pal, pals) { - fx = function(x) tolower(gsub("[-, _, \\,, (, ), \\ , \\.]", "", x)) - charmatch(fx(pal), fx(pals)) +validate_len_1_or_ngrps = function(x, ngrps, name, allow_character = FALSE) { + types = if (allow_character) "numeric or character" else "numeric" + valid_type = is.numeric(x) || (allow_character && is.character(x)) + valid = is.atomic(x) && is.vector(x) && valid_type && (length(x) == 1 || length(x) == ngrps) + if (!valid) { + stop(sprintf("`%s` must be `NULL`, or a %s vector of length 1 or %s.", name, types, ngrps), call. = FALSE) + } } -get_pal_lens = function(pal) { - pal_lens = c( - R3 = 8L, R4 = 8L, ggplot2 = 8L, `Okabe-Ito` = 9L, Accent = 8L, - `Dark 2` = 8L, Paired = 12L, `Pastel 1` = 9L, `Pastel 2` = 8L, - `Set 1` = 9L, `Set 2` = 8L, `Set 3` = 12L, `Tableau 10` = 10L, - `Classic Tableau` = 10L, `Polychrome 36` = 36L, Alphabet = 26L - ) - pal_lens[pal] +# Fuzzy match palette name against candidate list +match_pal = function(name, candidates) { + normalize = function(x) tolower(gsub("[-, _, \\,, (, ), \\ , \\.]", "", x)) + charmatch(normalize(name), normalize(candidates)) } -# take a character string, match to either palette.pals() pr hcl.pals(), and -# generate the corresponding function factor with alpha transparency +# Resolve a palette string to its function, handling fuzzy matching and recycling gen_pal_fun = function(pal, gradient = FALSE, alpha = NULL, n = NULL) { - pal_match = match_pal(pal, palette.pals()) - if (!is.na(pal_match)) { - if (pal_match < 1L) stop("'palette' is ambiguous") - pal_fun = palette.colors - if (!is.null(n) && n >= get_pal_lens(pal_match)) { - warning( - "\nFewer colours ", get_pal_lens(pal_match), " provided than than there are groups ", - n, ". Recycling to make up the shortfall." - ) - pal_fun = function(n, palette, alpha) palette.colors(n = n, palette = pal, alpha = alpha, recycle = TRUE) - } + # Try palette.pals() first (discrete palettes) + discrete_pals = palette.pals() + idx = match_pal(pal, discrete_pals) + + if (!is.na(idx)) { + if (idx < 1L) stop("'palette' is ambiguous") + matched_name = discrete_pals[idx] + max_colors = length(palette.colors(palette = matched_name)) + if (gradient) { - pal_fun = function(n, palette, alpha) colorRampPalette(palette.colors(palette = pal, alpha = alpha))(n) + return(function(n, palette, alpha) { + colorRampPalette(palette.colors(palette = matched_name, alpha = alpha))(n) + }) } - } else { - pal_match = match_pal(pal, hcl.pals()) - if (!is.na(pal_match)) { - if (pal_match < 1L) stop("'palette' is ambiguous") - pal_fun = hcl.colors - } else { - stop( - "\nPalette string not recogized. Must be a value produced by either", - "`palette.pals()` or `hcl.pals()`.\n", - call. = FALSE - ) + if (!is.null(n) && n >= max_colors) { + warn_recycle_colors(max_colors, n) + return(function(n, palette, alpha) { + palette.colors(n = n, palette = matched_name, alpha = alpha, recycle = TRUE) + }) } + return(palette.colors) + } + + # Try hcl.pals() (continuous palettes) + hcl_pals = hcl.pals() + idx = match_pal(pal, hcl_pals) + + if (!is.na(idx)) { + if (idx < 1L) stop("'palette' is ambiguous") + return(hcl.colors) + } + + stop( + "\nPalette string not recognized. Must be a value produced by either ", + "`palette.pals()` or `hcl.pals()`.\n", + call. = FALSE + ) +} + + +# +## subsidiary functions ----- +# + +by_col = function(col, palette, alpha, by_ordered, by_continuous, ngrps, adjustcolor) { + ordered = if (is.null(by_ordered)) FALSE else by_ordered + gradient = if (is.null(by_continuous)) FALSE else by_continuous + assert_logical(ordered) + assert_logical(gradient) + + if (is.null(alpha)) alpha = 1 + if (gradient) ngrps = 100L + + if (is_by_keyword(col)) col = NULL + + manual = resolve_manual_colors( + col = col, + ngrps = ngrps, + gradient = gradient, + ordered = ordered, + alpha = alpha, + adjustcolor = adjustcolor + ) + if (manual$handled) { + return(manual$cols) } - return(pal_fun) + + pal_theme = get_tpar("palette.qualitative", default = NULL) + cols = resolve_palette_colors( + palette = palette, + theme_palette = pal_theme, + ngrps = ngrps, + ordered = ordered, + gradient = gradient, + alpha = alpha, + adjustcolor = adjustcolor + ) + + cols } @@ -356,15 +356,14 @@ by_bg = function(bg, fill, col, palette, alpha, by_ordered, by_continuous, ngrps alpha = bg bg = "by" } - if (!is.null(bg) && length(bg) == 1 && bg == "by") { - # use by_col processing, but with the bg-specific colors - bg = by_col( - col = NULL, + if (!is.null(bg) && length(bg) == 1 && is_by_keyword(bg)) { + bg = resolve_palette_colors( palette = palette, - alpha = alpha, - by_ordered = by_ordered, - by_continuous = by_continuous, + theme_palette = get_tpar("palette.qualitative", default = NULL), ngrps = ngrps, + ordered = if (is.null(by_ordered)) FALSE else by_ordered, + gradient = if (is.null(by_continuous)) FALSE else by_continuous, + alpha = if (is.null(alpha)) 1 else alpha, adjustcolor = adjustcolor ) } else if (length(bg) != ngrps) { @@ -391,15 +390,14 @@ by_pch = function(ngrps, type, pch = NULL) { pch = NULL # special "by" convenience keyword - } else if (!is.null(pch) && length(pch) == 1 && pch == "by") { + } else if (is_by_keyword(pch)) { no_pch = TRUE # skip checks below pch = 1:ngrps + par("pch") - 1 # correctly recycle if over max pch type - pch_ceiling = 25 # see ?pch - if (max(pch) > pch_ceiling) { - pch_below = pch[pch <= pch_ceiling] - pch_above = pch[pch > pch_ceiling] - pch_above = rep_len(0:pch_ceiling, length(pch_above)) + if (max(pch) > 25L) { + pch_below = pch[pch <= 25L] + pch_above = pch[pch > 25L] + pch_above = rep_len(0:25, length(pch_above)) pch = c(pch_below, pch_above) } @@ -409,14 +407,8 @@ by_pch = function(ngrps, type, pch = NULL) { } if (!no_pch) { - if (!is.atomic(pch) || !is.vector(pch) || !(is.numeric(pch) || is.character(pch)) || (length(pch) != 1 && length(pch) != ngrps)) { - # if (!is.atomic(pch) || !is.vector(pch) || !is.numeric(pch) || (length(pch) != 1 && length(pch) != ngrps)) { - stop(sprintf("`pch` must be `NULL`, or a numeric or character vector of length 1 or %s.", ngrps), call. = FALSE) - } - - if (length(pch) == 1) { - pch = rep(pch, ngrps) - } + validate_len_1_or_ngrps(pch, ngrps, "pch", allow_character = TRUE) + if (length(pch) == 1) pch = rep(pch, ngrps) } return(pch) @@ -426,54 +418,45 @@ by_pch = function(ngrps, type, pch = NULL) { by_lty = function(ngrps, type, lty = NULL) { # We only care about line types, otherwise return NULL if (!type %in% c("l", "b", "o", "c", "h", "s", "S", "ribbon", "barplot", "boxplot", "rect", "segments", "qq", "abline", "hline", "vline")) { - out = NULL + lty = NULL # special "by" convenience keyword - } else if (!is.null(lty) && length(lty) == 1 && lty == "by") { + } else if (is_by_keyword(lty)) { lty_dict = c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash") par_lty = par("lty") if (!par_lty %in% lty_dict) { warning( - "\nBesoke lty specifications (i.e., using string combinations) are not", - "currently supported alongside the lty='by' keyword argument.", + "\nBespoke lty specifications (i.e., using string combinations) are not ", + "currently supported alongside the lty='by' keyword argument. ", "Defaulting to 1 and looping from there.\n" ) par_lty = 1 } else { par_lty = which(par_lty == lty_dict) } - out = 1:ngrps + par_lty - 1 - # correctly recycle if over max pch type - lty_ceiling = 6 # see ?pch - if (max(out) > lty_ceiling) { - lty_below = out[out <= lty_ceiling] - lty_above = out[out > lty_ceiling] - lty_above = rep_len(1:lty_ceiling, length(lty_above)) - out = c(lty_below, lty_above) + lty = 1:ngrps + par_lty - 1 + # correctly recycle if over max lty type + if (max(lty) > 6L) { + lty_below = lty[lty <= 6L] + lty_above = lty[lty > 6L] + lty_above = rep_len(1:6, length(lty_above)) + lty = c(lty_below, lty_above) } # NULL -> solid (or default) line } else if (is.null(lty)) { - if (identical(type, "boxplot")) { - out = NULL - } else { - out = rep(par("lty"), ngrps) + if (!identical(type, "boxplot")) { + lty = rep(par("lty"), ngrps) } # atomic vector: sanity check length } else if (is.atomic(lty) && is.vector(lty)) { - if (length(lty) == 1) { - out = rep(lty, ngrps) - } else { - if (length(lty) != ngrps) { - stop(sprintf("`lty` must be `NULL` or a numeric vector of length 1 or %s.", ngrps), call. = FALSE) - } - out = lty - } + validate_len_1_or_ngrps(lty, ngrps, "lty") + if (length(lty) == 1) lty = rep(lty, ngrps) } - return(out) + lty } @@ -484,7 +467,7 @@ by_lwd = function(ngrps, type, lwd = NULL) { no_lwd = FALSE # special "by" convenience keyword - if (!is.null(lwd) && length(lwd) == 1 && lwd == "by") { + if (is_by_keyword(lwd)) { no_lwd = TRUE # skip checks below lwd = seq(lwd_floor, lwd_ceiling, length.out = ngrps) } else if (is.null(lwd)) { @@ -493,12 +476,8 @@ by_lwd = function(ngrps, type, lwd = NULL) { } if (!no_lwd) { - if (!is.atomic(lwd) || !is.vector(lwd) || !is.numeric(lwd) || (length(lwd) != 1 && length(lwd) != ngrps)) { - stop(sprintf("`lwd` must be `NULL` or a numeric vector of length 1 or %s.", ngrps), call. = FALSE) - } - if (length(lwd) == 1) { - lwd = rep(lwd, ngrps) - } + validate_len_1_or_ngrps(lwd, ngrps, "lwd") + if (length(lwd) == 1) lwd = rep(lwd, ngrps) } return(lwd) @@ -506,17 +485,16 @@ by_lwd = function(ngrps, type, lwd = NULL) { by_cex = function(ngrps, type, bubble = FALSE, cex = NULL) { - no_cex = FALSE # special "by" convenience keyword - if (!is.null(cex) && length(cex) == 1 && cex == "by") { + if (is_by_keyword(cex)) { no_cex = TRUE # skip checks below cex = rescale_num(c(1:ngrps), to = c(1, 2.5)) } else if (is.null(cex)) { no_cex = TRUE # cex = NULL # can't leave cex as NULL otherwise JIT cex_fct_adj adjustment in - # draw_legend() won't work later + # draw_legend() won't work later cex = 1 cex = rep(cex, ngrps) } @@ -525,16 +503,9 @@ by_cex = function(ngrps, type, bubble = FALSE, cex = NULL) { if (bubble) no_cex = TRUE if (!no_cex) { - if (!is.atomic(cex) || !is.vector(cex) || !is.numeric(cex) || (length(cex) != 1 && length(cex) != ngrps)) { - stop(sprintf("`cex` must either be `NULL`, or a numeric vector of length 1 or %s (no. of groups).", ngrps), call. = FALSE) - } - if (length(cex) == 1) { - cex = rep(cex, ngrps) - } + validate_len_1_or_ngrps(cex, ngrps, "cex") + if (length(cex) == 1) cex = rep(cex, ngrps) } return(cex) } - - - From 572f46dbb79718580584852577e6ca350bfa7c77 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 11 Jan 2026 09:48:15 -0500 Subject: [PATCH 2/4] by_aesthetics clean-up and simplification --- R/by_aesthetics.R | 127 ++++++++++++++++++++-------------------------- 1 file changed, 56 insertions(+), 71 deletions(-) diff --git a/R/by_aesthetics.R b/R/by_aesthetics.R index e1f2debc..f32f4779 100755 --- a/R/by_aesthetics.R +++ b/R/by_aesthetics.R @@ -87,18 +87,52 @@ is_by_keyword = function(x) { is.character(x) && length(x) == 1 && !is.na(x) && identical(x, "by") } -resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcolor) { - # Not manual colors - defer to palette handling +warn_recycle_colors = function(ncols, ngrps) { + warning( + "\nFewer colours (", ncols, ") provided than there are groups (", + ngrps, "). Recycling to make up the shortfall." + ) +} + +expand_colors_to_ngrps = function(values, ngrps, gradient) { + if (length(values) == 1) { + return(rep(values, ngrps)) + } + if (length(values) >= ngrps) { + return(values[seq_len(ngrps)]) + } + if (gradient) { + return(colorRampPalette(colors = values, alpha = TRUE)(ngrps)) + } + warn_recycle_colors(length(values), ngrps) + rep_len(values, ngrps) +} +assert_len_1_or_ngrps = function(x, ngrps, name, allow_character = FALSE) { + types = if (allow_character) "numeric or character" else "numeric" + valid_type = is.numeric(x) || (allow_character && is.character(x)) + valid = is.atomic(x) && is.vector(x) && valid_type && (length(x) == 1 || length(x) == ngrps) + if (!valid) { + stop(sprintf("`%s` must be `NULL`, or a %s vector of length 1 or %s.", name, types, ngrps), call. = FALSE) + } +} + +match_palette_name = function(name, candidates) { + normalize = function(x) tolower(gsub("[-, _, \\,, (, ), \\ , \\.]", "", x)) + charmatch(normalize(name), normalize(candidates)) +} + +resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcolor) { + # Returns NULL if not manual colors, otherwise returns the resolved colors if (is.null(col) || !is.atomic(col) || !is.vector(col)) { - return(list(handled = FALSE, cols = NULL)) + return(NULL) } cols = col if (length(cols) == 1) { cols = rep(cols, ngrps) } else if (length(cols) < ngrps) { - cols = expand_colors(cols, ngrps, gradient) + cols = expand_colors_to_ngrps(cols, ngrps, gradient) } # Map numeric indices to palette colors (unless ordered) @@ -107,16 +141,12 @@ resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcol cols = if (ngrps <= length(base_pal)) { base_pal[cols] } else { - grDevices::hcl.colors(max(cols), alpha = alpha)[cols] + grDevices::hcl.colors(max(cols))[cols] } } - if (gradient) { - cols = rev(cols) - } - - cols = apply_alpha(cols, alpha, adjustcolor) - list(handled = TRUE, cols = cols) + if (gradient) cols = rev(cols) + apply_alpha(cols, alpha, adjustcolor) } resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradient, alpha, adjustcolor) { @@ -128,12 +158,12 @@ resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradie if (length(theme_palette) == 1) { # Check if theme palette needs to switch to sequential use_sequential = FALSE - idx = match_pal(theme_palette, palette.pals()) + idx = match_palette_name(theme_palette, palette.pals()) if (!is.na(idx) && idx >= 1L) { max_colors = length(palette.colors(palette = palette.pals()[idx])) use_sequential = ngrps >= max_colors || ordered } else { - idx = match_pal(theme_palette, hcl.pals()) + idx = match_palette_name(theme_palette, hcl.pals()) use_sequential = !is.na(idx) && idx >= 1L && gradient } if (use_sequential) { @@ -160,7 +190,7 @@ resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradie } cols = apply_alpha(cols, alpha, adjustcolor) } else { - cols = palette_from_spec( + cols = resolve_palette_spec( palette = palette_choice, ngrps = ngrps, gradient = gradient, @@ -174,7 +204,7 @@ resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradie cols } -palette_from_spec = function(palette, ngrps, gradient, ordered, alpha, adjustcolor) { +resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjustcolor) { cols = NULL palette_fun = NULL args = NULL @@ -186,7 +216,7 @@ palette_from_spec = function(palette, ngrps, gradient, ordered, alpha, adjustcol cols = palette } else if (is.character(palette)) { # Named palette string - palette_fun = gen_pal_fun(palette, gradient = gradient, alpha = NULL, n = ngrps) + palette_fun = resolve_palette_function(palette, gradient = gradient, alpha = NULL, n = ngrps) args = list(n = ngrps, palette = palette, alpha = NULL) } else if (inherits(palette, c("call", "name"))) { # Expression or symbol @@ -226,51 +256,15 @@ palette_from_spec = function(palette, ngrps, gradient, ordered, alpha, adjustcol } # Uniform post-processing - cols = expand_colors(cols, ngrps, gradient) + cols = expand_colors_to_ngrps(cols, ngrps, gradient) apply_alpha(cols, alpha, adjustcolor) } -warn_recycle_colors = function(ncols, ngrps) { - warning( - "\nFewer colours (", ncols, ") provided than there are groups (", - ngrps, "). Recycling to make up the shortfall." - ) -} - -expand_colors = function(values, ngrps, gradient) { - if (length(values) == 1) { - return(rep(values, ngrps)) - } - if (length(values) >= ngrps) { - return(values[seq_len(ngrps)]) - } - if (gradient) { - return(colorRampPalette(colors = values, alpha = TRUE)(ngrps)) - } - warn_recycle_colors(length(values), ngrps) - rep_len(values, ngrps) -} - -validate_len_1_or_ngrps = function(x, ngrps, name, allow_character = FALSE) { - types = if (allow_character) "numeric or character" else "numeric" - valid_type = is.numeric(x) || (allow_character && is.character(x)) - valid = is.atomic(x) && is.vector(x) && valid_type && (length(x) == 1 || length(x) == ngrps) - if (!valid) { - stop(sprintf("`%s` must be `NULL`, or a %s vector of length 1 or %s.", name, types, ngrps), call. = FALSE) - } -} - -# Fuzzy match palette name against candidate list -match_pal = function(name, candidates) { - normalize = function(x) tolower(gsub("[-, _, \\,, (, ), \\ , \\.]", "", x)) - charmatch(normalize(name), normalize(candidates)) -} - # Resolve a palette string to its function, handling fuzzy matching and recycling -gen_pal_fun = function(pal, gradient = FALSE, alpha = NULL, n = NULL) { +resolve_palette_function = function(pal, gradient = FALSE, alpha = NULL, n = NULL) { # Try palette.pals() first (discrete palettes) discrete_pals = palette.pals() - idx = match_pal(pal, discrete_pals) + idx = match_palette_name(pal, discrete_pals) if (!is.na(idx)) { if (idx < 1L) stop("'palette' is ambiguous") @@ -293,7 +287,7 @@ gen_pal_fun = function(pal, gradient = FALSE, alpha = NULL, n = NULL) { # Try hcl.pals() (continuous palettes) hcl_pals = hcl.pals() - idx = match_pal(pal, hcl_pals) + idx = match_palette_name(pal, hcl_pals) if (!is.na(idx)) { if (idx < 1L) stop("'palette' is ambiguous") @@ -323,17 +317,8 @@ by_col = function(col, palette, alpha, by_ordered, by_continuous, ngrps, adjustc if (is_by_keyword(col)) col = NULL - manual = resolve_manual_colors( - col = col, - ngrps = ngrps, - gradient = gradient, - ordered = ordered, - alpha = alpha, - adjustcolor = adjustcolor - ) - if (manual$handled) { - return(manual$cols) - } + cols = resolve_manual_colors(col, ngrps, gradient, ordered, alpha, adjustcolor) + if (!is.null(cols)) return(cols) pal_theme = get_tpar("palette.qualitative", default = NULL) cols = resolve_palette_colors( @@ -407,7 +392,7 @@ by_pch = function(ngrps, type, pch = NULL) { } if (!no_pch) { - validate_len_1_or_ngrps(pch, ngrps, "pch", allow_character = TRUE) + assert_len_1_or_ngrps(pch, ngrps, "pch", allow_character = TRUE) if (length(pch) == 1) pch = rep(pch, ngrps) } @@ -452,7 +437,7 @@ by_lty = function(ngrps, type, lty = NULL) { # atomic vector: sanity check length } else if (is.atomic(lty) && is.vector(lty)) { - validate_len_1_or_ngrps(lty, ngrps, "lty") + assert_len_1_or_ngrps(lty, ngrps, "lty") if (length(lty) == 1) lty = rep(lty, ngrps) } @@ -476,7 +461,7 @@ by_lwd = function(ngrps, type, lwd = NULL) { } if (!no_lwd) { - validate_len_1_or_ngrps(lwd, ngrps, "lwd") + assert_len_1_or_ngrps(lwd, ngrps, "lwd") if (length(lwd) == 1) lwd = rep(lwd, ngrps) } @@ -503,7 +488,7 @@ by_cex = function(ngrps, type, bubble = FALSE, cex = NULL) { if (bubble) no_cex = TRUE if (!no_cex) { - validate_len_1_or_ngrps(cex, ngrps, "cex") + assert_len_1_or_ngrps(cex, ngrps, "cex") if (length(cex) == 1) cex = rep(cex, ngrps) } From 5dfc6d86e72fe9df17da38e799686c4b156a6919 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 11 Jan 2026 09:59:51 -0500 Subject: [PATCH 3/4] by_aesthetics.R cleanup and comments --- R/by_aesthetics.R | 107 +++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 63 deletions(-) diff --git a/R/by_aesthetics.R b/R/by_aesthetics.R index f32f4779..6648314c 100755 --- a/R/by_aesthetics.R +++ b/R/by_aesthetics.R @@ -122,8 +122,8 @@ match_palette_name = function(name, candidates) { charmatch(normalize(name), normalize(candidates)) } +## Handle direct color input via `col` arg. Returns colors or NULL if not applicable. resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcolor) { - # Returns NULL if not manual colors, otherwise returns the resolved colors if (is.null(col) || !is.atomic(col) || !is.vector(col)) { return(NULL) } @@ -149,6 +149,7 @@ resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcol apply_alpha(cols, alpha, adjustcolor) } +## High-level palette resolution: theme fallback, defaults, then delegate to resolve_palette_spec. resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradient, alpha, adjustcolor) { palette_choice = palette @@ -204,20 +205,44 @@ resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradie cols } +## Parse palette arg (vector, string, call, or function) into colors. resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjustcolor) { cols = NULL - palette_fun = NULL - args = NULL - - # Determine colors or palette function based on spec type - # Note: alpha is NOT passed to palette functions; it's applied uniformly at the end if (is.character(palette) && length(palette) > 1) { # Direct color vector cols = palette } else if (is.character(palette)) { - # Named palette string - palette_fun = resolve_palette_function(palette, gradient = gradient, alpha = NULL, n = ngrps) - args = list(n = ngrps, palette = palette, alpha = NULL) + # Named palette string - try palette.pals() then hcl.pals() + discrete_pals = palette.pals() + idx = match_palette_name(palette, discrete_pals) + + if (!is.na(idx)) { + if (idx < 1L) stop("'palette' is ambiguous") + matched_name = discrete_pals[idx] + max_colors = length(palette.colors(palette = matched_name)) + + if (gradient) { + cols = colorRampPalette(palette.colors(palette = matched_name))(ngrps) + } else if (ngrps >= max_colors) { + warn_recycle_colors(max_colors, ngrps) + cols = palette.colors(n = ngrps, palette = matched_name, recycle = TRUE) + } else { + cols = palette.colors(n = ngrps, palette = matched_name) + } + } else { + hcl_pals = hcl.pals() + idx = match_palette_name(palette, hcl_pals) + if (!is.na(idx)) { + if (idx < 1L) stop("'palette' is ambiguous") + cols = hcl.colors(n = ngrps, palette = palette) + } else { + stop( + "\nPalette string not recognized. Must be a value produced by either ", + "`palette.pals()` or `hcl.pals()`.\n", + call. = FALSE + ) + } + } } else if (inherits(palette, c("call", "name"))) { # Expression or symbol if (inherits(palette, "name")) { @@ -228,18 +253,21 @@ resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjust } if (is.null(cols)) { args = as.list(palette) - palette_fun = paste(args[[1]]) + fun_name = paste(args[[1]]) args[[1]] = NULL - if (palette_fun %in% c("c", "list")) { + if (fun_name %in% c("c", "list")) { cols = unlist(args, recursive = TRUE, use.names = FALSE) } else { args[["n"]] = ngrps if (any(names(args) == "")) args[which(names(args) == "")] = NULL + cols = tryCatch( + do.call(fun_name, args), + error = function(e) do.call(eval(palette), args) + ) } } } else if (inherits(palette, "function")) { - palette_fun = palette - args = list() + cols = palette(ngrps) } else { stop( "\nInvalid palette argument. Must be a recognized keyword, or a ", @@ -247,60 +275,11 @@ resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjust ) } - # Generate colors from palette function if needed - if (is.null(cols) && !is.null(palette_fun)) { - cols = tryCatch( - do.call(palette_fun, args), - error = function(e) do.call(eval(palette), args) - ) - } - # Uniform post-processing cols = expand_colors_to_ngrps(cols, ngrps, gradient) apply_alpha(cols, alpha, adjustcolor) } -# Resolve a palette string to its function, handling fuzzy matching and recycling -resolve_palette_function = function(pal, gradient = FALSE, alpha = NULL, n = NULL) { - # Try palette.pals() first (discrete palettes) - discrete_pals = palette.pals() - idx = match_palette_name(pal, discrete_pals) - - if (!is.na(idx)) { - if (idx < 1L) stop("'palette' is ambiguous") - matched_name = discrete_pals[idx] - max_colors = length(palette.colors(palette = matched_name)) - - if (gradient) { - return(function(n, palette, alpha) { - colorRampPalette(palette.colors(palette = matched_name, alpha = alpha))(n) - }) - } - if (!is.null(n) && n >= max_colors) { - warn_recycle_colors(max_colors, n) - return(function(n, palette, alpha) { - palette.colors(n = n, palette = matched_name, alpha = alpha, recycle = TRUE) - }) - } - return(palette.colors) - } - - # Try hcl.pals() (continuous palettes) - hcl_pals = hcl.pals() - idx = match_palette_name(pal, hcl_pals) - - if (!is.na(idx)) { - if (idx < 1L) stop("'palette' is ambiguous") - return(hcl.colors) - } - - stop( - "\nPalette string not recognized. Must be a value produced by either ", - "`palette.pals()` or `hcl.pals()`.\n", - call. = FALSE - ) -} - # ## subsidiary functions ----- @@ -318,7 +297,9 @@ by_col = function(col, palette, alpha, by_ordered, by_continuous, ngrps, adjustc if (is_by_keyword(col)) col = NULL cols = resolve_manual_colors(col, ngrps, gradient, ordered, alpha, adjustcolor) - if (!is.null(cols)) return(cols) + if (!is.null(cols)) { + return(cols) + } pal_theme = get_tpar("palette.qualitative", default = NULL) cols = resolve_palette_colors( From 6b35e3d386175b45f1374fd3d5170b9af4504dba Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 11 Jan 2026 15:06:13 -0500 Subject: [PATCH 4/4] namespace --- R/by_aesthetics.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/by_aesthetics.R b/R/by_aesthetics.R index 6648314c..39803346 100755 --- a/R/by_aesthetics.R +++ b/R/by_aesthetics.R @@ -137,11 +137,11 @@ resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcol # Map numeric indices to palette colors (unless ordered) if (!ordered && is.numeric(cols)) { - base_pal = grDevices::palette() + base_pal = palette() cols = if (ngrps <= length(base_pal)) { base_pal[cols] } else { - grDevices::hcl.colors(max(cols))[cols] + hcl.colors(max(cols))[cols] } } @@ -175,17 +175,17 @@ resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradie if (is.null(palette_choice)) { # Default palette selection (alpha applied at end) - base_pal = grDevices::palette() + base_pal = palette() if (ngrps <= length(base_pal) && !ordered && !gradient) { cols = base_pal[seq_len(ngrps)] } else if (ngrps <= 8 && !ordered) { - cols = grDevices::palette.colors(n = ngrps, palette = "R4") + cols = palette.colors(n = ngrps, palette = "R4") } else if (!gradient && !ordered) { - cols = grDevices::hcl.colors(n = ngrps, palette = "Viridis") + cols = hcl.colors(n = ngrps, palette = "Viridis") } else { # Restricted viridis for gradient/ordered (excludes extreme ends) cols = colorRampPalette( - grDevices::hcl.colors(n = 100, palette = "Viridis")[11:90], + hcl.colors(n = 100, palette = "Viridis")[11:90], alpha = TRUE )(ngrps) }