#' CubeHelix color scale and palette
#'
#' The CubeHelix color palette, by Dave Green (Unlicense license).
#'
#' @template param_hue
#' @param rot number of rotations of the helix in RGB space, in \code{[-2,2]} (1 = 360°, -1.5 = -540°)
#' @template param_chromacity
#' @template param_lightness
#' @param gamma gamma contrast factor, in \code{[0,+Inf]} (sane values are in \code{[0.5,3]}). \code{gamma} < 1 emphasises the low end of the scale by whitening the high colors. \code{gamma} > 1 emphasises the high end of the scale by darkening the low colors. Use with caution and restraint.
#' @inheritParams interp_scale
#'
#' @template return_scales
#'
#' @family color scales and palettes
#'
#' @references \url{https://www.mrao.cam.ac.uk/~dag/CUBEHELIX/}
#' @examples
#' # Basic color palettes
#' show_col(
#' cubehelix_colors(20),
#' cubehelix_colors(20, reverse=TRUE)
#' )
#'
#' # Rotating less gives more sensible scales
#' show_col(
#' cubehelix_colors(20, h=300, rot=-0.75),
#' cubehelix_colors(20, h=300, rot=0.5)
#' )
#'
#' # No rotation gives single hue palettes
#' show_col(
#' cubehelix_colors(20, h=0 , rot=0, c=0.8),
#' cubehelix_colors(20, h=120, rot=0, c=0.8),
#' cubehelix_colors(20, h=200, rot=0, c=0.8)
#' )
#'
#' # Examine the effect of the other arguments
#' show_col(
#' cubehelix_colors(20, h=300, rot=0.5),
#' # smaller range of lightness change
#' cubehelix_colors(20, h=300, rot=0.5, l=c(0.2, 0.7)),
#' # change chromacity
#' cubehelix_colors(20, h=300, rot=0.5, c=0.9),
#' cubehelix_colors(20, h=300, rot=0.5, c=0.3),
#' # change gamma contrast factor
#' cubehelix_colors(20, h=300, rot=0.5, gamma=0.5),
#' cubehelix_colors(20, h=300, rot=0.5, gamma=1.5)
#' )
#'
#' # Plot the Maunga Whau volcano elevation map: a continuous variable
#' image(maunga, col=cubehelix_colors(100, rot=-0.75))
#' contour(maunga, col=alpha("black", 0.4), add=TRUE)
#'
#' persp(maunga, theta=50, phi=25, scale=FALSE, expand=2,
#' border=alpha("black", 0.4),
#' col=cubehelix_map(persp_facets(maunga$z), rot=-0.75))
#'
#' \dontrun{
#' # in spinning 3D
#' library("rgl")
#' persp3d(maunga, aspect=c(1,0.7,0.2), axes=FALSE, box=FALSE,
#' col=cubehelix_map(maunga$z, rot=-0.75))
#' play3d(spin3d(axis=c(0, 0, 1), rpm=10), duration=6)
#'
#' # or with ggplot2
#' library(ggplot2)
#' ggplot(maungaxyz) + coord_fixed() +
#' geom_raster(aes(x, y, fill=z)) +
#' scale_fill_cubehelix_c(rot=-0.75)
#' }
#'
#' # For discrete variables, using saturated colors along a scale of
#' # constant lightness gives a good hue-only scale
#' attach(iris)
#' plot(Petal.Length, Sepal.Length, pch=19,
#' col=cubehelix_map(
#' Species,
#' h=0, rot=0.75, # Start from red-ish and do not rotate
#' # full circle to avoid falling back on red
#' c=1, # Use saturated colors
#' l=c(0.6, 0.6) # Do not vary lightness
#' )
#' )
#' legend(1, 8, legend=levels(Species), pch=19,
#' col=cubehelix_map(1:3, h=0, rot=0.75, c=1, l=c(0.6, 0.6)))
#' detach(iris)
#' \dontrun{ggplot(iris) +
#' geom_point(aes(Petal.Length, Sepal.Length, color=Species)) +
#' scale_color_cubehelix_d(h=0, rot=0.75, c=1, l=c(0.6, 0.6))
#' }
#' # But see ?hue_scale for a simpler solution
#'
#' @export
cubehelix_scale <- function(h=300, rot=-1.5, c=0.5, l=c(0.1, 0.9), gamma=1, domain=c(0,1), reverse=FALSE, na.value=NULL, extrapolate=FALSE) {
# check arguments
if (length(h) != 1) { stop("h should be just one value.") }
if (length(rot) != 1) { stop("rot should be just one value.") }
if (length(c) != 1) { stop("c should be just one value.") }
if (length(l) != 2) { stop("l should be a vector of length 2.") }
if (length(gamma) != 1) { stop("gamma should be just one value.") }
is_in(rot, -2, 2)
is_in(c, 0, 1.5)
is_in(l, 0, 1)
is_in(gamma, 0, 2)
# if lightness bounds are identical, make them slightly different
if (l[1] == l[2]) {
l[1] <- max(0, l[1]-10^-6)
l[2] <- min(1, l[2]+10^-6)
}
# parse hue (in case it is provided as a color)
h <- hue(h)
# scale chromacity up to make the colors bright enough (but keep c in [0,1.5], as the documentation says)
c <- c * 2
# prepare chroma.js command
if ( reverse ) {
domain <- rev(domain)
}
domaint <- stringr::str_c("[",stringr::str_c(domain, collapse=","),"]")
lt <- stringr::str_c("[",stringr::str_c(l,collapse=","),"]")
# define function
eval(f <- function(x) {
cmds <- stringr::str_c("chroma.cubehelix().start(", h, ").rotations(", rot, ").hue(", c, ").lightness(", lt, ").gamma(", gamma, ").scale().domain(", domaint, ").mode('rgb')(", x, ").hex()")
colors <- v8_eval(cmds)
return(post_process_scale(colors, cubehelix_na(na.value, l), extrapolate, x, range(domain)))
})
}
# Pick a good missing value color for this scale
cubehelix_na <- function(na.value, l) {
if (is.null(na.value)) {
# return a grey of average lightness given the current lightness choice
na.value <- grDevices::grey(mean(l))
}
return(na.value)
}
#' @param ... passed to \code{\link{cubehelix_scale}}. Note that argument \code{domain} is meaningless in functions other than \code{cubehelix_scale} and passing it through \code{...} is an error.
#' @rdname cubehelix_scale
#' @export
cubehelix_map <- function(x, ...) {
# convert to numbers
x <- as.num(x)
# define the domain of the scale
cubehelix_scale(domain=range(x, na.rm=T), ...)(x)
}
#' @rdname cubehelix_scale
#' @export
cubehelix_palette <- function(...) {
f <- function(n) {
cubehelix_scale(domain=c(0,1), ...)(seq(0, 1, length.out=n))
}
return(f)
}
#' @rdname cubehelix_scale
#' @export
cubehelix_colors <- function(n, ...) {
cubehelix_palette(...)(n)
}
## ggplot2 ----
#' @rdname cubehelix_scale
#' @export
scale_color_cubehelix_c <- function(..., h=300, rot=-1.5, c=0.5, l=c(0.1, 0.9), gamma=1, reverse=FALSE, na.value=NULL, guide="colorbar") {
ggplot2::continuous_scale("colour", "cubehelix",
chroma::cubehelix_scale(h=h, rot=rot, c=c, l=l, gamma=gamma, reverse=reverse),
na.value=cubehelix_na(na.value, l), guide=guide, ...
)
}
#' @rdname cubehelix_scale
#' @export
#' @usage NULL
scale_colour_cubehelix_c <- scale_color_cubehelix_c
#' @rdname cubehelix_scale
#' @export
scale_fill_cubehelix_c <- function(..., h=300, rot=-1.5, c=0.5, l=c(0.1, 0.9), gamma=1, reverse=FALSE, na.value=NULL, guide="colorbar") {
ggplot2::continuous_scale("fill", "cubehelix",
chroma::cubehelix_scale(h=h, rot=rot, c=c, l=l, gamma=gamma, reverse=reverse),
na.value=cubehelix_na(na.value, l), guide=guide, ...
)
}
#' @rdname cubehelix_scale
#' @export
scale_color_cubehelix_d <- function(..., h=300, rot=-1.5, c=0.5, l=c(0.1, 0.9), gamma=1, reverse=FALSE, na.value="#grey50", guide="legend") {
ggplot2::discrete_scale("colour", "cubehelix",
cubehelix_palette(h=h, rot=rot, c=c, l=l, gamma=gamma, reverse=reverse),
na.value=cubehelix_na(na.value, l), ...
)
}
#' @rdname cubehelix_scale
#' @export
#' @usage NULL
scale_colour_cubehelix_d <- scale_color_cubehelix_d
#' @rdname cubehelix_scale
#' @export
scale_fill_cubehelix_d <- function(..., h=300, rot=-1.5, c=0.5, l=c(0.1, 0.9), gamma=1, reverse=FALSE, na.value="#grey50", guide="legend") {
ggplot2::discrete_scale("fill", "cubehelix",
cubehelix_palette(h=h, rot=rot, c=c, l=l, gamma=gamma, reverse=reverse),
na.value=cubehelix_na(na.value, l), ...
)
}
# Make the continuous version default, because it is the most commong use case
#' @rdname cubehelix_scale
#' @export
#' @usage NULL
scale_color_cubehelix <- scale_color_cubehelix_c
#' @rdname cubehelix_scale
#' @export
#' @usage NULL
scale_colour_cubehelix <- scale_color_cubehelix_c
#' @rdname cubehelix_scale
#' @export
#' @usage NULL
scale_fill_cubehelix <- scale_fill_cubehelix_c
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.