Additional colour manipulation functions

NAMESPACE

@@ -52,9 +52,14 @@ export(cbreaks)
 export(censor)
 export(col2hcl)
 export(col_bin)
+export(col_darker)
 export(col_factor)
+export(col_lighter)
+export(col_mix)
 export(col_numeric)
 export(col_quantile)
+export(col_saturate)
+export(col_shift)
 export(colour_ramp)
 export(comma)
 export(comma_format)

R/colour-manip.R

@@ -9,6 +9,7 @@
 #' @param c Chroma, `[0, 100]`
 #' @param alpha Alpha, `[0, 1]`.
 #' @export
+#' @family colour manipulation
 #' @examples
 #' reds <- rep("red", 6)
 #' show_col(col2hcl(reds, h = seq(0, 180, length = 6)))
@@ -31,6 +32,7 @@ col2hcl <- function(colour, h = NULL, c = NULL, l = NULL, alpha = NULL) {
 #' @param l new luminance
 #' @param c new chroma
 #' @export
+#' @family colour manipulation
 #' @examples
 #' muted("red")
 #' muted("blue")
@@ -45,23 +47,16 @@ muted <- function(colour, l = 30, c = 70) col2hcl(colour, l = l, c = c)
 #' @param alpha new alpha level in \[0,1].  If alpha is `NA`,
 #'   existing alpha values are preserved.
 #' @export
+#' @family colour manipulation
 #' @examples
 #' alpha("red", 0.1)
 #' alpha(colours(), 0.5)
 #' alpha("red", seq(0, 1, length.out = 10))
 #' alpha(c("first" = "gold", "second" = "lightgray", "third" = "#cd7f32"), .5)
 alpha <- function(colour, alpha = NA) {
-  if (length(colour) != length(alpha)) {
-    if (length(colour) > 1 && length(alpha) > 1) {
-      cli::cli_abort("Only one of {.arg colour} and {.arg alpha} can be vectorised")
-    }
-
-    if (length(colour) > 1) {
-      alpha <- rep(alpha, length.out = length(colour))
-    } else {
-      colour <- rep(colour, length.out = length(alpha))
-    }
-  }
+  input  <- recycle_common(colour = colour, alpha = alpha)
+  colour <- input[["colour"]]
+  alpha  <- input[["alpha"]]
 
   rgb <- farver::decode_colour(colour, alpha = TRUE)
   rgb[!is.na(alpha), 4] <- alpha[!is.na(alpha)]
@@ -113,3 +108,96 @@ show_col <- function(colours, labels = TRUE, borders = NULL, cex_label = 1,
     text(col(colours) - 0.5, -row(colours) + 0.5, colours, cex = cex_label, col = label_col)
   }
 }
+
+#' Mix colours
+#'
+#' Produces an interpolation of two colours.
+#'
+#' @param a,b A character vector of colours.
+#' @param amount A numeric fraction between 0 and 1 giving the contribution of
+#'   the `b` colour.
+#' @param space A string giving a colour space to perform mixing operation in.
+#'   Polar spaces are not recommended.
+#'
+#' @return A character vector of colours.
+#' @family colour manipulation
+#' @export
+#'
+#' @examples
+#' col_mix("blue", "red") # purple
+#' col_mix("blue", "red", amount = 1) # red
+#' col_mix("blue", "red", amount = 0) # blue
+#'
+#' # Not recommended:
+#' col_mix("blue", "red", space = "hcl") # green!
+col_mix <- function(a, b, amount = 0.5, space = "rgb") {
+  input <- recycle_common(a = a, b = b, amount = amount)
+  if (any(input$amount < 0 | input$amount > 1)) {
+    cli::cli_abort("{.arg amount} must be between (0, 1).")
+  }
+  a <- farver::decode_colour(input$a, alpha = TRUE, to = space)
+  b <- farver::decode_colour(input$b, alpha = TRUE, to = space)
+  new <- (a * (1 - amount) + b * amount)
+  alpha <- new[, "alpha"]
+  farver::encode_colour(new, alpha = alpha, from = space)
+}
+
+#' Colour manipulation
+#'
+#' These are a set of convenience functions for standard colour manipulation
+#' operations.
+#'
+#' @param col A character vector of colours.
+#' @param amount A numeric vector giving the change. The interpretation depends
+#'   on the function:
+#'   * `col_shift()` takes a number between -360 and 360 for shifting hues in
+#'     HCL space.
+#'   * `col_lighter()` and `col_darker()` take a number between -100 and 100 for
+#'     adding (or subtracting) to the lightness channel in HSL space.
+#'   * `col_saturate()` takes a number between -100 and 100 for adding to the
+#'     saturation channel in HSL space. Negative numbers desaturate the colour.
+#'
+#' @details
+#' `col_shift()` considers the hue channel to be periodic, so adding 180 to
+#' a colour with hue 270 will result in a colour with hue 90.
+#'
+#' @return A vector of colours.
+#' @name colour_manip
+#' @family colour manipulation
+#'
+#' @examples
+#' col_shift("red", 180) # teal
+#' col_lighter("red", 50) # light red
+#' col_darker("red", 50) # dark red
+#' col_saturate("red", -50) # brick-red
+NULL
+
+#' @export
+#' @rdname colour_manip
+col_shift <- function(col, amount = 10) {
+  input  <- recycle_common(col = col, amount = amount)
+  new <- farver::decode_colour(input$col, alpha = TRUE, to = "hcl")
+  new[, "h"] <- (new[, "h"] + input$amount) %% 360
+  farver::encode_colour(new, new[, "alpha"], from = "hcl")
+}
+
+#' @export
+#' @rdname colour_manip
+col_lighter <- function(col, amount = 10) {
+  input <- recycle_common(col = col, amount = amount)
+  farver::add_to_channel(input$col, "l", input$amount, space = "hsl")
+}
+
+#' @export
+#' @rdname colour_manip
+col_darker <- function(col, amount = 10) {
+  input <- recycle_common(col = col, amount = amount)
+  farver::add_to_channel(input$col, "l", -input$amount, space = "hsl")
+}
+
+#' @export
+#' @rdname colour_manip
+col_saturate <- function(col, amount = 10) {
+  input <- recycle_common(col = col, amount = amount)
+  farver::add_to_channel(input$col, "s", input$amount, space = "hsl")
+}

R/utils.R

@@ -61,3 +61,42 @@ demo_time <- function(x, ...) {
 demo_timespan <- function(x, ...) {
   demo_ggplot(x, "scale_x_continuous", ...)
 }
+
+# Based on rlang/R/standalone-vctrs.R shim
+recycle_common <- function(..., size = NULL, call = caller_env()) {
+  x <- list2(...)
+  sizes <- lengths(x)
+  n <- unique(sizes)
+  if (length(n) == 1 && is.null(size)) {
+    return(x)
+  }
+  n <- setdiff(n, 1L)
+  ns <- length(n)
+
+  if (ns == 0) { # All have length 1
+    if (is.null(size)) {
+      return(xs)
+    }
+  } else if (ns == 1) {
+    if (is.null(size)) {
+      size <- n
+    } else if (n != size) {
+      bad <- names(sizes)[sizes != size]
+      cli::cli_abort(
+        "Cannot recycle {.and {.arg {bad}}} to length {size}.",
+        call = call
+      )
+    }
+  } else {
+    bad <- names(sizes)[!(sizes %in% c(1, size))]
+    what <- if (is.null(size)) "a common size" else paste0("length ", size)
+    cli::cli_abort(
+      "Cannot recycle {.and {.arg {bad}}} to {what}.",
+      call = call
+    )
+  }
+
+  to_recycle <- sizes == 1L
+  x[to_recycle] <- lapply(x[to_recycle], rep_len, length.out = size)
+  x
+}

tests/testthat/test-colour-manip.R

@@ -40,3 +40,35 @@ test_that("preserves names", {
   names(x) <- x
   expect_named(alpha(x, 0.5), names(x))
 })
+
+# col_mix -----------------------------------------------------------------
+
+test_that("col_mix interpolates colours", {
+
+  x <- col_mix("red", c("blue", "green"))
+  y <- col_mix(c("blue", "green"), "red")
+  expect_equal(x, y)
+  expect_equal(x, c("#800080", "#808000"))
+  x <- col_mix("red", "blue", amount = 0.75)
+  expect_equal(x, "#4000BFFF")
+
+})
+
+test_that("col_shift shifts colours correctly", {
+  x <- c("#FF0000", "#00FF00", "#0000FF")
+  expect_equal(col_shift(x, 360), x)
+  expect_equal(col_shift(x, 180), c("#00B8B8", "#FF92FF", "#535300"))
+})
+
+test_that("col_lighter and col_darker adjust lightness correctly", {
+  x <- c("#FF0000", "#00FF00", "#0000FF")
+  expect_equal(col_lighter(x, 30), c("#FF9999", "#99FF99", "#9999FF"))
+  expect_equal(col_darker(x, 30), c("#660000", "#006600", "#000066"))
+})
+
+test_that("col_saturate can (de)saturate colours", {
+  x <- c("#BF4040", "#40BF40", "#4040BF")
+  expect_equal(col_saturate(x, 30), c("#E51A1A", "#1AE51A", "#1A1AE5"))
+  expect_equal(col_saturate(x, -30), c("#996666", "#669966", "#666699"))
+})
+

tests/testthat/test-utils.R

@@ -0,0 +1,17 @@
+test_that("recycle_common throws appropriate errors", {
+
+  expect_error(
+    recycle_common(a = 1:2, size = 3),
+    "length 3"
+  )
+  expect_error(
+    recycle_common(a = 1:2, b = 1:3),
+    "common size"
+  )
+
+  expect_error(
+    recycle_common(a = 1:2, b = 1:3, size = 3),
+    "Cannot recycle `a`"
+  )
+
+})