#' Get Palette Colors
#'
#' Create a vector of \code{n} colors from qualitative, diverging, and sequential color schemes.
#'
#' @param n 'integer' count.
#' Number of colors to be in the palette.
#' The maximum number of colors in a generated palette is dependent on the specified color scheme,
#' see \sQuote{Details} section for maximum values.
#' @param scheme 'character' string.
#' Name of color scheme, see \sQuote{Details} section for scheme descriptions.
#' Argument choices may be abbreviated as long as there is no ambiguity.
#' @param alpha 'numeric' number.
#' Alpha transparency, values range from 0 (fully transparent) to 1 (fully opaque).
#' Specify as \code{NULL} to exclude the alpha channel value from colors.
#' @param stops 'numeric' vector of length 2.
#' Color stops defined by interval endpoints (between 0 and 1)
#' and used to select a subset of the color palette.
#' Only suitable for schemes that allow for color interpolations.
#' @param bias 'numeric' number.
#' Interpolation bias where larger values result in more widely spaced colors at the high end.
#' @param reverse 'logical' flag.
#' Whether to reverse the order of colors in the scheme.
#' @param blind 'character' string.
#' Type of color blindness to simulate: specify \code{"deutan"} for green-blind vision,
#' \code{"protan"} for red-blind vision, \code{"tritan"} for green-blue-blind vision, or
#' \code{"monochrome"} for total-color blindness.
#' A partial-color blindness simulation requires that the \pkg{dichromat} package is available,
#' see \code{\link[dichromat]{dichromat}} function for additional information.
#' Argument choices may be abbreviated as long as there is no ambiguity.
#' @param gray 'logical' flag.
#' Whether to subset/reorder the \code{"bright"}, \code{"high-contrast"}, \code{"vibrant"},
#' and \code{"muted"} schemes to work well after conversion to gray scale.
#' @param ...
#' Not used
#'
#' @details The suggested data type for color schemes and the
#' characteristics of generated palettes are given in the tables below.
#' [\bold{Type}: is the type of data being represented,
#' either qualitative, diverging, or sequential.
#' \bold{Max n}: is the maximum number of colors in a generated palette.
#' And the maximum \code{n} value when scheme colors are designed for
#' gray-scale conversion is enclosed in parentheses.
#' A value of infinity indicates that the scheme allows for color interpolations.
#' \bold{N}: is the not-a-number color.
#' \bold{B}: is the background color.
#' \bold{F}: is the foreground color.
#' \bold{Abbreviations}: --, not available]
#'
#' \if{html}{\figure{table01.svg}}
#' \if{latex}{\figure{table01.pdf}{options: width=5.36in}}
#'
#' \if{html}{\figure{table02.svg}}
#' \if{latex}{\figure{table02.pdf}{options: width=5.36in}}
#'
#' \if{html}{\figure{table03.svg}}
#' \if{latex}{\figure{table03.pdf}{options: width=5.36in}}
#'
#' \if{html}{\figure{table04.svg}}
#' \if{latex}{\figure{table04.pdf}{options: width=5.36in}}
#'
#' \if{html}{\figure{table05.svg}}
#' \if{latex}{\figure{table05.pdf}{options: width=5.36in}}
#'
#' Schemes \code{"pale"}, \code{"dark"}, and \code{"ground cover"} are
#' intended to be accessed in their entirety and subset using vector element names.
#'
#' @return When argument \code{n} is specified the function
#' returns an object of class 'inlpal' that inherits behavior from the 'character' class.
#' And when \code{n} is unspecified a variant of the \code{GetColors} function is
#' returned that has default argument values set equal to the values specified by the user.
#'
#' The inlpal-class object is comprised of a 'character'
#' vector of \code{n} colors in the RGB color system.
#' Colors are specified with a string of the form \code{"#RRGGBB"} or \code{"#RRGGBBAA"}
#' where \code{RR}, \code{GG}, \code{BB}, and \code{AA} are the
#' red, green, blue, and alpha hexadecimal values (00 to FF), respectively.
#' Attributes of the returned object include:
#' \code{"names"}, the informal names assigned to colors in the palette,
#' where \code{NULL} indicates no color names are specified;
#' \code{"NaN"}, a 'character' string giving the color meant for missing data,
#' in hexadecimal format, where \code{NA} indicates no color is specified; and
#' \code{"call"}, an object of class '\link{call}' giving the unevaluated function
#' call (expression) that can be used to reproduce the color palette.
#' Use the \code{\link{eval}} function to evaluate the \code{"call"} argument.
#' A simple \code{plot} method is provided for the 'inlpal' class that
#' shows a palette of colors using a sequence of shaded rectangles,
#' see \sQuote{Examples} section for usage.
#'
#' @note Sequential color schemes \code{"YlOrBr"} and \code{"iridescent"}
#' work well for conversion to gray scale.
#'
#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
#'
#' @references
#' Dewez, Thomas, 2004, Variations on a DEM palette, accessed October 15, 2018 at
#' \url{http://soliton.vm.bytemark.co.uk/pub/cpt-city/td/index.html}
#'
#' Mikhailov, Anton, 2019, Turbo, an improved rainbow colormap for visualization:
#' Google AI Blog, accessed August 21, 2019 at
#' \url{https://ai.googleblog.com/2019/08/turbo-improved-rainbow-colormap-for.html}.
#'
#' Tol, Paul, 2018, Colour Schemes:
#' SRON Technical Note, doc. no. SRON/EPS/TN/09-002, issue 3.1, 20 p.,
#' accessed September 24, 2018 at \url{https://personal.sron.nl/~pault/data/colourschemes.pdf}.
#'
#' Wessel, P., Smith, W.H.F., Scharroo, R., Luis, J.F., and Wobbe, R., 2013,
#' Generic Mapping Tools: Improved version released, AGU, v. 94, no. 45, p. 409--410
#' \url{https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2013EO450001}
#'
#' @seealso
#' \code{\link{SetHinge}} function to set the hinge location in
#' a color palette derived from one or two color schemes.
#'
#' \code{\link[grDevices]{col2rgb}} function to express palette
#' colors represented in the hexadecimal format as RGB triplets (R, G, B).
#'
#' @keywords color
#'
#' @export
#'
#' @examples
#' pal <- GetColors(n = 10)
#' print(pal)
#' plot(pal)
#'
#' Pal <- GetColors(scheme = "turbo")
#' formals(Pal)
#' filled.contour(datasets::volcano, color.palette = Pal,
#' plot.axes = FALSE)
#'
#' # Diverging color schemes (scheme)
#' op <- par(mfrow = c(6, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors( 9, scheme = "BuRd"))
#' plot(GetColors(255, scheme = "BuRd"))
#' plot(GetColors( 9, scheme = "PRGn"))
#' plot(GetColors(255, scheme = "PRGn"))
#' plot(GetColors( 11, scheme = "sunset"))
#' plot(GetColors(255, scheme = "sunset"))
#' par(op)
#'
#' # Qualitative color schemes (scheme)
#' op <- par(mfrow = c(7, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors(7, scheme = "bright"))
#' plot(GetColors(6, scheme = "dark"))
#' plot(GetColors(5, scheme = "high-contrast"))
#' plot(GetColors(9, scheme = "light"))
#' plot(GetColors(9, scheme = "muted"))
#' plot(GetColors(6, scheme = "pale"))
#' plot(GetColors(7, scheme = "vibrant"))
#' par(op)
#'
#' # Sequential color schemes (scheme)
#' op <- par(mfrow = c(7, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors( 23, scheme = "discrete rainbow"))
#' plot(GetColors( 34, scheme = "smooth rainbow"))
#' plot(GetColors(255, scheme = "smooth rainbow"))
#' plot(GetColors( 9, scheme = "YlOrBr"))
#' plot(GetColors(255, scheme = "YlOrBr"))
#' plot(GetColors( 23, scheme = "iridescent"))
#' plot(GetColors(255, scheme = "iridescent"))
#' par(op)
#'
#' # Alpha transparency (alpha)
#' op <- par(mfrow = c(5, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors(34, alpha = 1.0))
#' plot(GetColors(34, alpha = 0.8))
#' plot(GetColors(34, alpha = 0.6))
#' plot(GetColors(34, alpha = 0.4))
#' plot(GetColors(34, alpha = 0.2))
#' par(op)
#'
#' # Color stops (stops)
#' op <- par(mfrow = c(4, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors(255, stops = c(0.0, 1.0)))
#' plot(GetColors(255, stops = c(0.0, 0.5)))
#' plot(GetColors(255, stops = c(0.5, 1.0)))
#' plot(GetColors(255, stops = c(0.3, 0.9)))
#' par(op)
#'
#' # Interpolation bias (bias)
#' op <- par(mfrow = c(7, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors(255, bias = 0.4))
#' plot(GetColors(255, bias = 0.6))
#' plot(GetColors(255, bias = 0.8))
#' plot(GetColors(255, bias = 1.0))
#' plot(GetColors(255, bias = 1.2))
#' plot(GetColors(255, bias = 1.4))
#' plot(GetColors(255, bias = 1.6))
#' par(op)
#'
#' # Reverse colors (reverse)
#' op <- par(mfrow = c(2, 1), oma = c(0, 0, 0, 0),
#' cex = 0.7)
#' plot(GetColors(10, reverse = FALSE))
#' plot(GetColors(10, reverse = TRUE))
#' par(op)
#'
#' # Color blindness (blind)
#' op <- par(mfrow = c(5, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors(34, blind = NULL))
#' plot(GetColors(34, blind = "deutan"))
#' plot(GetColors(34, blind = "protan"))
#' plot(GetColors(34, blind = "tritan"))
#' plot(GetColors(34, blind = "monochrome"))
#' par(op)
#'
#' # Gray-scale preparation (gray)
#' op <- par(mfrow = c(8, 1), oma = c(0, 0, 0, 0))
#' plot(GetColors(3, "bright", gray = TRUE))
#' plot(GetColors(3, "bright", gray = TRUE,
#' blind = "monochrome"))
#' plot(GetColors(5, "high-contrast", gray = TRUE))
#' plot(GetColors(5, "high-contrast", gray = TRUE,
#' blind = "monochrome"))
#' plot(GetColors(4, "vibrant", gray = TRUE))
#' plot(GetColors(4, "vibrant", gray = TRUE,
#' blind = "monochrome"))
#' plot(GetColors(5, "muted", gray = TRUE))
#' plot(GetColors(5, "muted", gray = TRUE,
#' blind = "monochrome"))
#' par(op)
#'
GetColors <- function(n, scheme="smooth rainbow", alpha=NULL, stops=c(0, 1),
bias=1, reverse=FALSE, blind=NULL, gray=FALSE, ...) {
# if copy-pasting, run the following command:
# lazyLoad(file.path(system.file("R", package="inlmisc"), "sysdata"))
if (!missing(n)) {
checkmate::assertCount(n)
if (n == 0) return(NULL)
}
checkmate::assertFlag(gray)
scheme <- match.arg(scheme, names(schemes))
s <- schemes[[scheme]]
nmax <- if(gray) length(s$gray) else s$nmax
if (!missing(n) && n > nmax)
stop("n = ", n, " exceeds the maximum number of colors in palette: ",
nmax, " for '", scheme, "' scheme.")
if (gray && nmax == 0)
stop("gray component not available for '", scheme, "' scheme.")
checkmate::assertNumber(alpha, lower=0, upper=1, finite=TRUE, null.ok=TRUE)
# backward compatibility
if (methods::hasArg("start")) stops[1] <- list(...)$start
if (methods::hasArg("end")) stops[2] <- list(...)$end
checkmate::assertNumeric(stops, lower=0, upper=1, finite=TRUE, any.missing=FALSE,
len=2, unique=TRUE, sorted=TRUE)
checkmate::qassert(bias, "N1(0,)")
checkmate::assertFlag(reverse)
checkmate::assertString(blind, min.chars=1, null.ok=TRUE)
if (is.character(blind)) {
if (blind == "monochromacy") blind <- "monochrome" # backward compatibility
blind <- match.arg(blind, c("deutan", "protan", "tritan", "monochrome"))
if (blind != "monochrome" && !requireNamespace("dichromat", quietly=TRUE))
stop("simulating partial color blindness requires the dichromat package")
}
if (nmax < Inf && !identical(stops, c(0, 1)))
warning("'stops' only applies to interpolated color schemes")
if (missing(n)) {
Pal <- GetColors
formals(Pal) <- eval(substitute(
alist("n" =,
"scheme" = a1,
"alpha" = a2,
"stops" = a3,
"bias" = a4,
"reverse" = a5,
"blind" = a6,
"gray" = a7),
list("a1" = scheme,
"a2" = alpha,
"a3" = stops,
"a4" = bias,
"a5" = reverse,
"a6" = blind,
"a7" = gray)
))
return(Pal)
}
color <- s$data$color; names(color) <- s$data$name
if (gray) color <- color[s$gray]
if (scheme == "turbo") {
# code adapted from turbo colormap look-up table;
# changes include: add 'bias' variable, convert from Python to R,
# and store parsed 'turbo_colormap_data' in R/sysdata.rda,
# copyright 2019 Google LLC, Apache-2.0 license,
# authored by Anton Mikhailov and accessed August 21, 2019
# at https://gist.github.com/mikhailov-work/ee72ba4191942acecc03fe6da94fc73f
x <- seq.int(stops[1], stops[2], length.out=n)^bias
x <- vapply(x, function(y) max(0, min(1, y)), 0)
a <- floor(x * 255)
b <- vapply(a, function(y) min(255, y + 1), 0)
f <- x * 255 - a
a <- a + 1
b <- b + 1
pal <- grDevices::rgb(turbo_colormap_data[a, 1] + (turbo_colormap_data[b, 1] - turbo_colormap_data[a, 1]) * f,
turbo_colormap_data[a, 2] + (turbo_colormap_data[b, 2] - turbo_colormap_data[a, 2]) * f,
turbo_colormap_data[a, 3] + (turbo_colormap_data[b, 3] - turbo_colormap_data[a, 3]) * f)
if (reverse) pal <- rev(pal)
} else if (scheme == "discrete rainbow") {
pal <- color[discrete_rainbow_indexes[[n]]]
if (reverse) pal <- rev(pal)
} else if (scheme == "bpy") {
# code adapted from sp::bpy.colors function,
# authored by Edzer Pebesma and accessed June 4, 2019
# at https://CRAN.R-project.org/package=sp
x <- seq.int(stops[1], stops[2], length.out=n)^bias
r <- ifelse(x < 0.25, 0, ifelse(x < 0.57, x / 0.32 - 0.78125, 1))
g <- ifelse(x < 0.42, 0, ifelse(x < 0.92, 2 * x - 0.84, 1))
b <- ifelse(x < 0.25, 4 * x,
ifelse(x < 0.42, 1, ifelse(x < 0.92, -2 * x + 1.84, x / 0.08 - 11.5)))
pal <- grDevices::rgb(r, g, b)
if (reverse) pal <- rev(pal)
} else if (nmax < Inf) {
if (reverse) color <- rev(color)
pal <- color[1:n]
} else {
value <- if (is.null(s$data$value)) seq_along(s$data$color) else s$data$value
value <- scales::rescale(value)
if (reverse) {
color <- rev(color)
value <- rev(1 - value)
}
x <- seq.int(stops[1], stops[2], length.out=255)
color <- scales::gradient_n_pal(color, values=value)(x)
pal <- grDevices::colorRampPalette(color, bias=bias, space="Lab")(n)
}
nan <- ifelse(is.null(s$nan), as.character(NA), s$nan)
if (!is.null(blind) | !is.null(alpha)) {
pal_names <- names(pal)
if (!is.null(blind)) {
if (blind == "monochrome") {
pal <- .Col2Gray(pal)
if (!is.null(nan)) nan <- .Col2Gray(nan)
} else {
pal <- dichromat::dichromat(pal, type=blind)
if (!is.null(nan)) nan <- dichromat::dichromat(nan, type=blind)
}
}
if (!is.null(alpha)) {
pal <- grDevices::adjustcolor(pal, alpha.f=alpha)
if (!is.null(nan)) nan <- grDevices::adjustcolor(nan, alpha.f=alpha)
}
names(pal) <- pal_names
}
cl <- as.call(list(quote(GetColors),
"n" = n,
"scheme" = scheme,
"alpha" = alpha,
"stops" = stops,
"bias" = bias,
"reverse" = reverse,
"blind" = blind,
"gray" = gray))
.MakeInlpalClass(pal, nan, cl)
}
#' @export
# Plot function for 'inlpal' color palette
plot.inlpal <- function(x, ..., label=TRUE) {
checkmate::assertCharacter(x, any.missing=FALSE, min.len=1)
stopifnot(all(IsColor(x)))
checkmate::assertFlag(label)
n <- length(x)
if (label && inherits(x, "inlpal")) {
arg <- as.list(attr(x, "call"))
txt <- c(paste0("n = ", n),
paste0("scheme = '", arg$scheme, "'"),
paste0("alpha = ", arg$alpha),
paste0("stops = c(", arg$stops[1], ", ", arg$stops[2], ")"),
paste0("bias = ", arg$bias),
paste0("reverse = ", arg$reverse),
paste0("blind = '", arg$blind, "'"),
paste0("gray = ", arg$gray))
is <- c(TRUE, TRUE, !is.null(arg$alpha), !identical(arg$stops, c(0, 1)),
arg$bias != 1, arg$reverse, !is.null(arg$blind), arg$gray)
main <- paste(txt[is], collapse=", ")
reverse <- arg$reverse
} else {
main <- NULL
reverse <- FALSE
}
# code adapted from example in
# colorspace::rainbow_hcl function documentation,
# authored by Achim Zeileis and accessed August 8, 2018
# at https://CRAN.R-project.org/package=colorspace
mar <- if (label) c(3, 2, 2, 2) else c(0, 0, 0, 0)
op <- graphics::par(mar=mar); on.exit(graphics::par(op))
graphics::plot.default(NA, type="n", xlim=c(0, 1), ylim=c(0, 1), main=main,
xaxs="i", yaxs="i", bty="n", xaxt="n", yaxt="n",
xlab="", ylab="", col.main="#333333", ...)
xl <- 0:(n - 1) / n
xr <- 1:n / n
if (any(grepl("^#(\\d|[a-f]){8}$", x, ignore.case=TRUE))) {
graphics::rect(0, 0, 1, 1, col="#FFFFFF", border=NA)
} else if (n > 1) {
xr <- c(utils::head(xr, -1) + 1 / (2 * n), utils::tail(xr, 1))
}
graphics::rect(xl, 0, xr, 1, col=x, border=NA)
if (label && n < 35) {
at <- 0:(n - 1) / n + 1 / (2 * n)
lab <- gsub(" ", "\n", names(x))
if (length(lab) == 0) {
lab <- seq_along(x)
if (reverse) lab <- rev(lab)
}
graphics::axis(1, at=at, labels=lab, tick=FALSE, line=-0.5, padj=1,
mgp=c(3, 0, 0), col.lab="#333333")
v <- (0:(n - 1) / n)[-1]
graphics::abline(v=v, col="#D3D3D3", lwd=0.25)
}
graphics::box(lwd=0.25, col="#D3D3D3")
invisible()
}
# Convert colors to gray/grayscale,
# code from TeachingDemos::col2grey function,
# authored by Greg Snow and accessed August 29, 2018
# at https://CRAN.R-project.org/package=TeachingDemos
# and licensed under Artistic-2.0
# https://cran.r-project.org/web/licenses/Artistic-2.0
# Function integrated here without logical changes.
.Col2Gray <- function(cols) {
rgb <- grDevices::col2rgb(cols)
gry <- rbind(c(0.3, 0.59, 0.11)) %*% rgb
grDevices::rgb(gry, gry, gry, maxColorValue=255)
}
# Constructor function for 'inlpal' class
.MakeInlpalClass <- function(x, nan, call) {
pattern <- "^#(\\d|[a-f]){6,8}$"
checkmate::assertCharacter(x, pattern=pattern, ignore.case=TRUE,
any.missing=FALSE, min.len=1)
checkmate::assertString(nan, na.ok=TRUE, pattern=pattern, ignore.case=TRUE)
stopifnot(is.call(call))
stopifnot(all(names(formals(GetColors)) %in% c(names(as.list(call)), "...")))
structure(x, nan=nan, call=call, class=append("inlpal", class(x)))
}
# Check for valid color names
#'
#' Check whether a character string is a valid color specification.
#'
#' @param x 'character' vector.
#' color specification
#' @param null.ok 'logical' flag.
#' If set to \code{TRUE}, \code{x} may also be \code{NULL}.
#'
#' @return A 'logical' vector of the same length as argument \code{x}.
#'
#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
#'
#' @keywords internal
#'
#' @export
#'
#' @examples
#' IsColor(c("red", "zzz", "#FFFFFF", "#7FAF1B111"))
#'
IsColor <- function(x, null.ok=FALSE) {
if (is.null(x) && null.ok) return(TRUE)
vapply(x, function(i) tryCatch({
is.matrix(grDevices::col2rgb(i))
}, error=function(e) FALSE), TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.