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