update resize_colors + bug fix

R/compare-colors.R

@@ -115,6 +115,7 @@ subset_colors <- function(colors, ..., method = "CIE2000", filter = NULL) {
 #' - "b", from LAB colorspace
 #' - "hue", from HSL colorspace
 #' - "saturation", from HSL colorspace
+#' - "lightness-2", from HSL colorspace
 #' - "red", from RGB colorspace
 #' - "green", from RGB colorspace
 #' - "blue", from RGB colorspace

R/resize-colors.R

@@ -1,25 +1,71 @@
 #' Resize color palette
 #'
-#' Reduce or expand the number of colors in palette, colors are removed with
+#' Remove or add colors to the palette, colors are removed with
 #' `collapse_colors()` and added with `interp_colors()`.
 #'
 #' @param colors Vector of colors
 #' @param n Number of colors to include in final color palette
+#' @param difference Color difference threshold to use for
+#' selecting distinct `colors`.
+#' @param method Method to use for comparing colors, can be one of:
+#' - "euclidian"
+#' - "CIE1976"
+#' - "CIE94"
+#' - "CIE2000"
+#' - "CMC"
+#' @param filter Filter to apply to color palette when
+#' calculating pairwise differences.
+#' A vector can be passed to adjust based on multiple color filters.
+#' Possible values include,
+#' - "colorblind", use deutan, protan, and tritan color blindness simulation
+#'   filters
+#' - "deutan"
+#' - "protan"
+#' - "tritan"
 #' @param order If `TRUE` colors are ordered with new colors interspersed,
 #' if `FALSE` new colors are added to the end.
-#' @param ... Additional arguments to pass to `collapse_colors()`.
+#' @param maxit Maximum number of iterations to use when optimizing the color
+#' palette.
+#' Higher values will result in more optimal adjustments and a reduction in
+#' speed.
+#' @param ... Additional arguments to pass to `collapse_colors()` or
+#' `spruce_colors()`.
 #' @export
-resize_colors <- function(colors, n, order = TRUE, ...) {
+resize_colors <- function(colors, n, difference = 15, method = "CIE2000",
+                          filter = NULL, order = TRUE, maxit = 500, ...) {
 
   n_clrs <- length(colors)
 
   if (n_clrs == n) return(colors)
 
   if (n > n_clrs) {
-    res <- interp_colors(colors, n)
+    res <- interp_colors(colors, n, order = TRUE)
+
+    ex_idx <- match(colors, res)
+
+    res <- spruce_colors(
+      res,
+      difference     = difference,
+      property       = "interp",
+      method         = method,
+      filter         = filter,
+      exclude_colors = ex_idx,
+      order          = TRUE,
+      maxit          = maxit,
+      ...
+    )
+
+    if (!order) res <- c(colors, res[!res %in% colors])
 
   } else {
-    res <- collapse_colors(colors, n, ...)
+    res <- collapse_colors(
+      colors, n,
+      difference = difference,
+      method     = method,
+      filter     = filter,
+      maxit      = maxit,
+      ...
+    )
   }
 
   res
@@ -114,6 +160,14 @@ interp_colors <- function(colors, n, keep_original = TRUE, order = TRUE,
 #'
 #' @param colors Vector of colors
 #' @param n Number of colors to include in final color palette
+#' @param difference Color difference threshold to use for
+#' selecting distinct `colors`.
+#' @param method Method to use for comparing colors, can be one of:
+#' - "euclidian"
+#' - "CIE1976"
+#' - "CIE94"
+#' - "CIE2000"
+#' - "CMC"
 #' @param filter Filter to apply to color palette when
 #' calculating pairwise differences.
 #' Colors will be compared before and after applying the filter(s).
@@ -133,10 +187,15 @@ interp_colors <- function(colors, n, keep_original = TRUE, order = TRUE,
 #' solutions.
 #' If `NULL` the approximate approach will be used except when the number of
 #' possible solutions is relatively small.
+#' @param maxit Maximum number of iterations to use when optimizing the color
+#' palette.
+#' Higher values will result in more optimal adjustments and a reduction in
+#' speed.
 #' @param ... Additional parameters to control the simulated annealing
 #' algorithm implemented with `GenSA::GenSA()`.
 #' @export
-collapse_colors <- function(colors, n, filter = NULL, exact = NULL, ...) {
+collapse_colors <- function(colors, n, difference = 15, method = "CIE2000",
+                            filter = NULL, exact = NULL, maxit = 500, ...) {
 
   .chk_spruce_args(colors = colors, n = n, exact = exact)
 
@@ -145,7 +204,7 @@ collapse_colors <- function(colors, n, filter = NULL, exact = NULL, ...) {
   filter <- .chk_filt_args(filter, multi = TRUE)
 
   # Calculate pairwise differences
-  dst <- .compare_clrs(colors, filt = filter)
+  dst <- .compare_clrs(colors, filt = filter, method = method)
 
   # Use exhaustive approach for smaller number of possible combinations
   max_combns <- 1e5
@@ -194,9 +253,10 @@ collapse_colors <- function(colors, n, filter = NULL, exact = NULL, ...) {
   lower     <- as.numeric(rep(1, n))
   upper     <- as.numeric(rep(length(colors), n))
 
-  gensa_params       <- list(...)
-  gensa_params$maxit <- gensa_params$maxit %||% 1000
-  gensa_params$seed  <- gensa_params$seed %||% 42
+  gensa_params                <- list(...)
+  gensa_params$maxit          <- maxit
+  gensa_params$threshold.stop <- -difference
+  gensa_params$seed           <- gensa_params$seed  %||% 42
 
   gensa_res <- GenSA::GenSA(
     par      = as.numeric(init_vals),

R/scale-spruce.R

@@ -370,7 +370,7 @@ ggplot_add.ScaleDiscreteSpruce <- function(object, plot, object_name) {
     # * only merge palettes if prev_scale is discrete
     # * first apply pal function from prev scale to generate color palette
     if (any(prev_aes) && is_spruce) {
-      prev_scale <- self$scales[[prev_aes]]
+      prev_scale <- self$scales[prev_aes][[1]]
 
       if (inherits(prev_scale, "ScaleDiscrete")) {
         prev_pal   <- prev_scale$palette

R/spruce-colors.R

@@ -1,7 +1,7 @@
 #' Adjust colors based on similarity
 #'
 #' @param colors Character vector of colors to adjust
-#' @param difference Color difference threshold (CIE200 score) to use for
+#' @param difference Color difference threshold to use for
 #' adjusting `colors`.
 #' Colors will be adjusted so the minimum pairwise difference
 #' is greater than this threshold.
@@ -15,6 +15,7 @@
 #' - "b", from LAB colorspace
 #' - "hue", from HSL colorspace
 #' - "saturation", from HSL colorspace
+#' - "lightness-2", from HSL colorspace
 #' - "red", from RGB colorspace
 #' - "green", from RGB colorspace
 #' - "blue", from RGB colorspace
@@ -271,6 +272,12 @@ spruce_colors <- function(colors, difference = 10,
 
   init_vals <- clrs_x[clr_idx]
 
+  # Set saturation limits
+  sat_lims <- get_property(clrs, property = "saturation")
+  sat_lims <- range(sat_lims$saturation)
+  sat_lims <- c(min(sat_lims[1], 15), 100)
+
+  # Run optimization
   optim <- GenSA::GenSA(
     par     = init_vals,
     fn      = .sa_obj_interp,
@@ -283,15 +290,16 @@ spruce_colors <- function(colors, difference = 10,
     method   = method,
     clr_filt = filts,
     clrs_x   = clrs_x,
-    scale    = scale
+    scale    = scale,
+    sat_lims = sat_lims
   )
 
   # Color ramp function
   # * color ramp is set using original colors
   ramp <- .get_ramp_fn(clrs, clrs_x)
 
   # Get colors using adjusted x values
-  clrs_x[clr_idx] <- optim$par
+  clrs_x[clr_idx] <- sort(optim$par)
 
   if (scale) clrs_x <- (clrs_x - min(clrs_x)) / diff(range(clrs_x))
 
@@ -381,7 +389,7 @@ spruce_colors <- function(colors, difference = 10,
 #' color matrix containing the values to modify, e.g. 1 for lightness
 #' @noRd
 .sa_obj_interp <- function(values, clrs, clr_idx, method, clr_filt = "none",
-                           clrs_x, scale = FALSE) {
+                           clrs_x, scale = FALSE, sat_lims = c(0, 100)) {
 
   if (any(duplicated(values))) return(0)
 
@@ -395,6 +403,14 @@ spruce_colors <- function(colors, difference = 10,
 
   clrs <- ramp(clrs_x)
 
+  # Check saturation
+  # * prevent colors from being returned that have saturation values outside the
+  #   starting palette
+  sat <- get_property(clrs, "saturation")
+  sat <- range(sat$saturation)
+
+  if (sat[1] < sat_lims[1] || sat[2] > sat_lims[2]) return(0)
+
   # Calculate pairwise CIEDE2000 differences
   dist_lst <- .compare_clrs(clrs, method = method, filt = clr_filt)
   min_diff <- .get_min_dist(dist_lst, clr_idx, comparison = "idx_vs_all")
@@ -506,14 +522,15 @@ spruce_colors <- function(colors, difference = 10,
 #' matrix, and default range.
 #' @noRd
 PROP_PARAMS <- list(
-  lightness  = list("lab", 1, c(20, 80)),
-  a          = list("lab", 2, c(-128, 127)),
-  b          = list("lab", 3, c(-128, 127)),
-  hue        = list("hsl", 1, c(0, 360)),
-  saturation = list("hsl", 2, c(0, 100)),
-  red        = list("rgb", 1, c(0, 255)),
-  green      = list("rgb", 2, c(0, 255)),
-  blue       = list("rgb", 3, c(0, 255))
+  lightness     = list("lab", 1, c(20, 80)),
+  a             = list("lab", 2, c(-128, 127)),
+  b             = list("lab", 3, c(-128, 127)),
+  hue           = list("hsl", 1, c(0, 360)),
+  saturation    = list("hsl", 2, c(0, 100)),
+  `lightness-2` = list("hsl", 3, c(20, 80)),
+  red           = list("rgb", 1, c(0, 255)),
+  green         = list("rgb", 2, c(0, 255)),
+  blue          = list("rgb", 3, c(0, 255))
 )
 
 .properties <- names(PROP_PARAMS)