From 68aed0ea6a158de49e1e70b1bc4106ffac740126 Mon Sep 17 00:00:00 2001
From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com>
Date: Fri, 13 Sep 2024 08:54:01 +0200
Subject: [PATCH] Additional colour manipulation functions (#424)

---
 NAMESPACE                          |   5 ++
 R/colour-manip.R                   | 110 ++++++++++++++++++++++++++---
 R/utils.R                          |  39 ++++++++++
 man/alpha.Rd                       |   8 +++
 man/col2hcl.Rd                     |   8 +++
 man/col_mix.Rd                     |  39 ++++++++++
 man/colour_manip.Rd                |  57 +++++++++++++++
 man/muted.Rd                       |   8 +++
 tests/testthat/test-colour-manip.R |  32 +++++++++
 tests/testthat/test-utils.R        |  17 +++++
 10 files changed, 312 insertions(+), 11 deletions(-)
 create mode 100644 man/col_mix.Rd
 create mode 100644 man/colour_manip.Rd
 create mode 100644 tests/testthat/test-utils.R

diff --git a/NAMESPACE b/NAMESPACE
index 115ded97..c3b5919e 100644
--- a/NAMESPACE
+++ b/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)
diff --git a/R/colour-manip.R b/R/colour-manip.R
index cb99c7cf..5de30897 100644
--- a/R/colour-manip.R
+++ b/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")
+}
diff --git a/R/utils.R b/R/utils.R
index 27ae7021..fc80a5a4 100644
--- a/R/utils.R
+++ b/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
+}
diff --git a/man/alpha.Rd b/man/alpha.Rd
index 81b5b019..8b2d40c8 100644
--- a/man/alpha.Rd
+++ b/man/alpha.Rd
@@ -21,3 +21,11 @@ alpha(colours(), 0.5)
 alpha("red", seq(0, 1, length.out = 10))
 alpha(c("first" = "gold", "second" = "lightgray", "third" = "#cd7f32"), .5)
 }
+\seealso{
+Other colour manipulation: 
+\code{\link{col2hcl}()},
+\code{\link{col_mix}()},
+\code{\link{colour_manip}},
+\code{\link{muted}()}
+}
+\concept{colour manipulation}
diff --git a/man/col2hcl.Rd b/man/col2hcl.Rd
index bce3f580..6e339cd3 100644
--- a/man/col2hcl.Rd
+++ b/man/col2hcl.Rd
@@ -28,3 +28,11 @@ show_col(col2hcl(reds, c = seq(0, 80, length = 6)))
 show_col(col2hcl(reds, l = seq(0, 100, length = 6)))
 show_col(col2hcl(reds, alpha = seq(0, 1, length = 6)))
 }
+\seealso{
+Other colour manipulation: 
+\code{\link{alpha}()},
+\code{\link{col_mix}()},
+\code{\link{colour_manip}},
+\code{\link{muted}()}
+}
+\concept{colour manipulation}
diff --git a/man/col_mix.Rd b/man/col_mix.Rd
new file mode 100644
index 00000000..ae40f3ac
--- /dev/null
+++ b/man/col_mix.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/colour-manip.R
+\name{col_mix}
+\alias{col_mix}
+\title{Mix colours}
+\usage{
+col_mix(a, b, amount = 0.5, space = "rgb")
+}
+\arguments{
+\item{a, b}{A character vector of colours.}
+
+\item{amount}{A numeric fraction between 0 and 1 giving the contribution of
+the \code{b} colour.}
+
+\item{space}{A string giving a colour space to perform mixing operation in.
+Polar spaces are not recommended.}
+}
+\value{
+A character vector of colours.
+}
+\description{
+Produces an interpolation of two colours.
+}
+\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!
+}
+\seealso{
+Other colour manipulation: 
+\code{\link{alpha}()},
+\code{\link{col2hcl}()},
+\code{\link{colour_manip}},
+\code{\link{muted}()}
+}
+\concept{colour manipulation}
diff --git a/man/colour_manip.Rd b/man/colour_manip.Rd
new file mode 100644
index 00000000..2dae5274
--- /dev/null
+++ b/man/colour_manip.Rd
@@ -0,0 +1,57 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/colour-manip.R
+\name{colour_manip}
+\alias{colour_manip}
+\alias{col_shift}
+\alias{col_lighter}
+\alias{col_darker}
+\alias{col_saturate}
+\title{Colour manipulation}
+\usage{
+col_shift(col, amount = 10)
+
+col_lighter(col, amount = 10)
+
+col_darker(col, amount = 10)
+
+col_saturate(col, amount = 10)
+}
+\arguments{
+\item{col}{A character vector of colours.}
+
+\item{amount}{A numeric vector giving the change. The interpretation depends
+on the function:
+\itemize{
+\item \code{col_shift()} takes a number between -360 and 360 for shifting hues in
+HCL space.
+\item \code{col_lighter()} and \code{col_darker()} take a number between -100 and 100 for
+adding (or subtracting) to the lightness channel in HSL space.
+\item \code{col_saturate()} takes a number between -100 and 100 for adding to the
+saturation channel in HSL space. Negative numbers desaturate the colour.
+}}
+}
+\value{
+A vector of colours.
+}
+\description{
+These are a set of convenience functions for standard colour manipulation
+operations.
+}
+\details{
+\code{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.
+}
+\examples{
+col_shift("red", 180) # teal
+col_lighter("red", 50) # light red
+col_darker("red", 50) # dark red
+col_saturate("red", -50) # brick-red
+}
+\seealso{
+Other colour manipulation: 
+\code{\link{alpha}()},
+\code{\link{col2hcl}()},
+\code{\link{col_mix}()},
+\code{\link{muted}()}
+}
+\concept{colour manipulation}
diff --git a/man/muted.Rd b/man/muted.Rd
index f38e09c7..ffaa5def 100644
--- a/man/muted.Rd
+++ b/man/muted.Rd
@@ -21,3 +21,11 @@ muted("red")
 muted("blue")
 show_col(c("red", "blue", muted("red"), muted("blue")))
 }
+\seealso{
+Other colour manipulation: 
+\code{\link{alpha}()},
+\code{\link{col2hcl}()},
+\code{\link{col_mix}()},
+\code{\link{colour_manip}}
+}
+\concept{colour manipulation}
diff --git a/tests/testthat/test-colour-manip.R b/tests/testthat/test-colour-manip.R
index 5d1bbcea..a2f93225 100644
--- a/tests/testthat/test-colour-manip.R
+++ b/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"))
+})
+
diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
new file mode 100644
index 00000000..d4626554
--- /dev/null
+++ b/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`"
+  )
+
+})