1#' Fast colour interpolation
2#'
3#' Returns a function that maps the interval \[0,1] to a set of colours.
4#' Interpolation is performed in the CIELAB colour space. Similar to
5#' \code{\link[grDevices]{colorRamp}(space = 'Lab')}, but hundreds of
6#' times faster, and provides results in `"#RRGGBB"` (or
7#' `"#RRGGBBAA"`) character form instead of RGB colour matrices.
8#'
9#' @param colors Colours to interpolate; must be a valid argument to
10#'   [grDevices::col2rgb()]. This can be a character vector of
11#'   `"#RRGGBB"` or  `"#RRGGBBAA"`, colour names from
12#'   [grDevices::colors()], or a positive integer that indexes into
13#'   [grDevices::palette()].
14#' @param na.color The colour to map to `NA` values (for example,
15#'   `"#606060"` for dark grey, or `"#00000000"` for transparent) and
16#'   values outside of \[0,1]. Can itself by `NA`, which will simply cause
17#'   an `NA` to be inserted into the output.
18#' @param alpha Whether to include alpha transparency channels in interpolation.
19#'   If `TRUE` then the alpha information is included in the interpolation.
20#'   The returned colours will be provided in `"#RRGGBBAA"` format when needed,
21#'   i.e., in cases where the colour is not fully opaque, so that the `"AA"`
22#'   part is not equal to `"FF"`. Fully opaque colours will be returned in
23#'   `"#RRGGBB"` format. If `FALSE`, the alpha information is discarded
24#'   before interpolation and colours are always returned as `"#RRGGBB"`.
25#'
26#' @return A function that takes a numeric vector and returns a character vector
27#'   of the same length with RGB or RGBA hex colours.
28#'
29#' @seealso \code{\link[grDevices]{colorRamp}}
30#'
31#' @export
32#' @examples
33#' ramp <- colour_ramp(c("red", "green", "blue"))
34#' show_col(ramp(seq(0, 1, length = 12)))
35colour_ramp <- function(colors, na.color = NA, alpha = TRUE) {
36  if (length(colors) == 0) {
37    stop("Must provide at least one colour to create a colour ramp")
38  }
39
40  if (length(colors) == 1) {
41    return(structure(
42      function(x) {
43        ifelse(is.na(x), na.color, colors)
44      },
45      safe_palette_func = TRUE
46    ))
47  }
48
49  # farver is not currently case insensitive, but col2rgb() is
50  colors <- tolower(colors)
51  lab_in <- farver::decode_colour(colors, alpha = TRUE, to = "lab",
52                                  na_value = "transparent")
53
54  x_in <- seq(0, 1, length.out = length(colors))
55  l_interp <- stats::approxfun(x_in, lab_in[, 1])
56  u_interp <- stats::approxfun(x_in, lab_in[, 2])
57  v_interp <- stats::approxfun(x_in, lab_in[, 3])
58
59  if (!alpha || all(lab_in[, 4] == 1)) {
60    alpha_interp <- function(x) NULL
61  } else {
62    alpha_interp <- stats::approxfun(x_in, lab_in[, 4])
63  }
64
65  structure(
66    function(x) {
67      lab_out <- cbind(l_interp(x), u_interp(x), v_interp(x))
68      out <- farver::encode_colour(lab_out, alpha = alpha_interp(x), from = "lab")
69      out[is.na(out)] <- na.color
70      out
71    },
72    safe_palette_func = TRUE
73  )
74}
75