#' Fast colour interpolation
#'
#' Returns a function that maps the interval \[0,1] to a set of colours.
#' Interpolation is performed in the CIELAB colour space. Similar to
#' \code{\link[grDevices]{colorRamp}(space = 'Lab')}, but hundreds of
#' times faster, and provides results in `"#RRGGBB"` (or
#' `"#RRGGBBAA"`) character form instead of RGB colour matrices.
#'
#' @param colors Colours to interpolate; must be a valid argument to
#' [grDevices::col2rgb()]. This can be a character vector of
#' `"#RRGGBB"` or `"#RRGGBBAA"`, colour names from
#' [grDevices::colors()], or a positive integer that indexes into
#' [grDevices::palette()].
#' @param na.color The colour to map to `NA` values (for example,
#' `"#606060"` for dark grey, or `"#00000000"` for transparent) and
#' values outside of \[0,1]. Can itself by `NA`, which will simply cause
#' an `NA` to be inserted into the output.
#' @param alpha Whether to include alpha transparency channels in interpolation.
#' If `TRUE` then the alpha information is included in the interpolation.
#' The returned colours will be provided in `"#RRGGBBAA"` format when needed,
#' i.e., in cases where the colour is not fully opaque, so that the `"AA"`
#' part is not equal to `"FF"`. Fully opaque colours will be returned in
#' `"#RRGGBB"` format. If `FALSE`, the alpha information is discarded
#' before interpolation and colours are always returned as `"#RRGGBB"`.
#'
#' @return A function that takes a numeric vector and returns a character vector
#' of the same length with RGB or RGBA hex colours.
#'
#' @seealso \code{\link[grDevices]{colorRamp}}
#'
#' @export
#' @examples
#' ramp <- colour_ramp(c("red", "green", "blue"))
#' show_col(ramp(seq(0, 1, length = 12)))
colour_ramp <- function(colors, na.color = NA, alpha = TRUE) {
if (length(colors) == 0) {
cli::cli_abort("Must provide at least one colour to create a colour ramp")
}
if (length(colors) == 1) {
return(structure(
function(x) {
ifelse(is.na(x), na.color, colors)
},
safe_palette_func = TRUE
))
}
# farver is not currently case insensitive, but col2rgb() is
colors <- tolower(colors)
lab_in <- farver::decode_colour(
colour = colors,
alpha = TRUE,
to = "lab",
na_value = "transparent"
)
x_in <- seq(0, 1, length.out = length(colors))
l_interp <- stats::approxfun(x_in, lab_in[, 1])
u_interp <- stats::approxfun(x_in, lab_in[, 2])
v_interp <- stats::approxfun(x_in, lab_in[, 3])
if (!alpha || all(lab_in[, 4] == 1)) {
alpha_interp <- function(x) NULL
} else {
alpha_interp <- stats::approxfun(x_in, lab_in[, 4])
}
fun <- function(x) {
lab_out <- cbind(l_interp(x), u_interp(x), v_interp(x))
out <- farver::encode_colour(lab_out, alpha = alpha_interp(x), from = "lab")
out[is.na(out)] <- na.color
out
}
new_continuous_palette(fun, type = "colour", na_safe = !is.na(na.color))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.