R/jam-color.R
In jmw86069/colorjam: Jam Color manipulation functions
#' rainbow categorical colors using varied luminance and chroma
#'
#' rainbow categorical colors using varied luminance and chroma
#'
#' This function customizes similar functions \code{grDevices::rainbow},
#' [colorspace::rainbow_hcl()], and [scales::hue_pal()] in two main
#' ways:
#'
#' 1. It uses the warped color wheel (see [h2hw()] which compresses the
#' green component of the standard HCL color hue wheel, extending the yellow.
#' 2. It uses a varying luminance and chroma vector which was selected to
#' optimize visual distinctiveness of adjacent colors. There is still a limit
#' to the maximum number of effectively different categorical colors, however
#' this function appears to improve other available methods.
#'
#' This function is also intended to enable use of a custom color wheel,
#' for example a set of color mappings could define color-blind friendly
#' ranges of colors when using the warped hue functions [h2hw()] and
#' [hw2h()]. When `warpHue=TRUE` the values for `h1` and
#' `h2` are used to define a mapping from warped hues to standard
#' hues recognized by [hcl()].
#'
#' @param n integer number of categorical colors to return
#' @param alpha numeric alpha transparency of colors, values ranging from
#' 0 to 1. If multiple values are supplied, they are applied in order to
#' the categorical colors returned.
#' @param nfloor the minimum number of effective color slices taken from the
#' hue color wheel, primarily used as an aesthetic choice so the first two
#' colors will be reasonably consistent when choosing 1, 2, 3, 4, or 5
#' categorical colors.
#' @param hues optional numeric vector of hues to use, only useful when the
#' exact hues should be used instead of taking slices along a hue color
#' wheel. Note that to use hue values with no modification, one should
#' also set \code{warpHue=FALSE}, otherwise the given hues are assumed to
#' warped hue values.
#' @param Cvals,Lvals vector of chroma (C) and luminance (L) values to be
#' cycled when creating colors along the vector of color hues. These
#' values are intended to maximize visual distinctiveness of adjacent and
#' nearly-adjacent colors. For example, varying from bright to dark may
#' provide additional distinction between two similar color hues.
#' @param Crange,Lrange vector of two numeric values which define the allowable
#' chroma (C) and luminance (L) ranges for \code{Cvals} and \code{Lvals}
#' parameter values. If supplied, the numeric vector Cvals will be scaled
#' so the lowest Cvals value maps to the first value in Crange, and the
#' highest Cvals value maps to the last value in Crange. Varying the
#' Crange and Lrange values can help produce categorical colors on a
#' dark or light background, by changing the range of values being used.
#' @param Hstart the hue to use for the first hue value in the color sequence.
#' Standard red has a hue 12.2, which is the default for this function.
#' @param doTest boolen indicating whether to perform a visual test for
#' the \code{n} number of colors produced, which helps judge the
#' visual distinctiveness of different combinations of dark and light
#' colors.
#' @param sFactor,darkFactor parameters sent to \code{jamba::makeColorDarker}
#' if either is not equal to 1. Setting \code{darkFactor=2} is a quick
#' way of generating categorical border colors, for example drawing a
#' colored border around categorical colors. Alternatively, setting
#' \code{sFactor=-2, darkFactor=-2} can be used to desaturate and lighten
#' colors used for the background area of a rectangle. The \code{alpha}
#' transparency parameter can also be helpful, however not all graphics
#' devices support transparency, in which case it is more robust to define
#' the exact color.
#' @param nameStyle character value indicating how to name the output
#' colors: "none" returns colors with no names; "hcl" assigns names with
#' the color number prefix, followed by H, C, L values; "colors" names the
#' vector by the hex color code.
#' @param h1,h2 numeric vectors as used by [h2hw()] and [hw2h()] to
#' convert from warped hues to standard hues. The default values define
#' red-yellow-blue (additive) color space, which is converted to
#' red-green-blue color space to produce the actual R color.
#' @param verbose logical whether to print verbose output
#'
#' @return vector of colors
#'
#' @family colorjam deprecated
#'
#' @examples
#' rainbowJam_v1(12);
#'
#' # show colors
#' jamba::showColors(rainbowJam_v1(12));
#'
#' # be fancy and label colors using the closest R named color
#' jamba::showColors(rainbowJam_v1(12, nameStyle="colors"));
#'
#' @export
rainbowJam_v1 <- function
(n=NULL,
alpha=1,
nfloor=4,
hues=NULL,
Cvals=c(75,95,80, 65,72,80),
Lvals=c(62,83,69,58,65,74),
# Scaling of the ranges above
#Crange=getOption("jam.Crange"),
#Lrange=getOption("jam.Lrange"),
#Cgrey=getOption("jam.Cgrey"),
Crange=NULL,
Lrange=NULL,
Cgrey=NULL,
Hstart=12.2,
warpHue=TRUE,
doTest=FALSE,
sFactor=1,
darkFactor=1,
nameStyle=c("none","hcl","colors"),
h1=h2hwOptions()$h1,
h2=h2hwOptions()$h2,
verbose=FALSE,
...)
{
## Purpose is to provide categorical colors, using the HCL
## smooth colorspace (which offers uniform changes in lightness,
## chromaticity(saturation). But for here, we deliberately
## fluctuate the lightness and saturation as we rotate around
## the rainbow of colors, to help visually separate each color.
##
##
nameStyle <- match.arg(nameStyle);
## Test with doTest=TRUE:
if (doTest) {
oPar <- par();
par(mfrow=c(5,1));
colSet <- jamba::nameVector(rainbowJam_v1(n), 1:n);
jamba::showColors(colSet,
main=paste("n =", n, " colors"),
xaxt="n");
title("The more colors, the more likely non-adjacent colors will look similar");
jamba::showColors(colSet[seq(from=1, to=n, by=3)],
main="offset by 3 (Dark colors)",
xaxt="n");
if (n > 1) {
fullHiSet <- seq(from=2, to=n, by=3);
whichHiSet <- fullHiSet[-seq(from=2, to=length(fullHiSet), by=2)];
jamba::showColors(colSet[whichHiSet],
main="Light colors",
xaxt="n");
jamba::showColors(colSet[-whichHiSet],
main="Non-light colors",
xaxt="n");
if (n > 2) {
jamba::showColors(colSet[seq(from=3, to=n, by=2)],
main="offset by 2 + 3 (Medium colors)",
xaxt="n");
}
}
par(oPar);
return(NULL);
}
if (length(n) == 0) {
n <- 1;
}
if (length(Cvals) == 0) {
stop("rainbowJam() requires Cvals and Lvals to be defined.");
}
if (length(Lvals) == 0) {
stop("rainbowJam() requires Cvals and Lvals to be defined.");
}
## Generate a color hue sequence
nHues <- max(c(nfloor, n));
if (length(hues) == 0) {
## hue starts from 0 to 360,
## add the Hstart to rotate the color hues,
## trim to values between 0 and 360
hues <- head(
(seq(from=0,
to=360,
length.out=(nHues+1)) + Hstart) %% 360,
n);
}
## adjust hues to warped hues
if (warpHue) {
if (verbose) {
jamba::printDebug("rainbowJam(): ",
"warping hues");
ch(data.frame(h1=h1, h2=h2), Inf);
}
hues <- hw2h(hues,
h1=h1,
h2=h2);
}
if (verbose) {
jamba::printDebug("rainbowJam(): ",
"hues:",
format(digits=2, hues));
}
## Scale the lVals and cVals ranges to given lRange and cRange if needed
## (note we have to do the scaling before taking a subset of values!)
if (length(Lrange) == 2 && !all(Lrange %in% range(Lvals))) {
#Lvals <- normScale(Lvals,
# from=Lrange[1],
# to=Lrange[2]);
## 19nov2018 changed to restrict the extremes, not stretch the
## interior values to the minimum/maximum
Lvals <- normScale(Lvals,
low=min(c(Lrange[1], min(Lvals))),
high=max(c(Lrange[2], max(Lvals))),
from=Lrange[1],
to=Lrange[2]);
}
if (length(Crange) == 2 && !all(Crange %in% range(Cvals))) {
#Cvals <- normScale(Cvals,
# from=Crange[1],
# to=Crange[2]);
Cvals <- normScale(Cvals,
low=min(c(Crange[1], min(Cvals))),
high=max(c(Crange[2], max(Cvals))),
from=Crange[1],
to=Crange[2]);
}
Cvals <- rep(Cvals, length.out=n);
Lvals <- rep(Lvals, length.out=n);
alpha <- rep(alpha, length.out=n);
if (verbose) {
hclDF <- data.frame(H=hues,
C=Cvals,
L=Lvals,
alpha=alpha);
jamba::printDebug("H: ", format(digits=2, hues));
jamba::printDebug("C:", format(digits=2, Cvals));
jamba::printDebug("L:", format(digits=2, Lvals));
jamba::printDebug("alpha:", alpha);
}
## Generate colors using HCL definitions
hclSet <- jamba::hcl2col(H=hues,
C=Cvals,
L=Lvals,
alpha=alpha);
if (any(abs(sFactor) != 1) || any(abs(darkFactor) != 1)) {
if (verbose) {
jamba::printDebug("rainbowJam(): ",
"applying darkFactor, sFactor with makeColorDarker().")
}
hclSet <- makeColorDarker(hclSet,
darkFactor=postDarkFactor,
sFactor=postSfactor,
...);
}
if (nameStyle %in% "hcl") {
hclNames <- jamba::makeNames(paste(seq_len(n),
paste0("H", signif(hues, digits=3)),
paste0("C", signif(Cvals, digits=3)),
paste0("L", signif(Lvals, digits=3)),
sep="_"));
names(hclSet) <- hclNames;
} else if (nameStyle %in% "colors") {
hclNames <- jamba::makeNames(closestRcolor(hclSet));
names(hclSet) <- hclNames;
} else {
hclSet <- unname(hclSet);
}
return(hclSet);
}
#' Find the closest R color
#'
#' Find the closest R color for a vector of colors
#'
#' This function is intended as a relatively efficient method to compare
#' a set of colors to the named R colors provided by `grDevices::colors()`.
#'
#' Color matching provides substantial improvements over similar functions
#' from other R packages. Notably, colors are matched using either
#' HCL or LUB color model by default, both of which provide vast
#' improvement over RGB color matching, due to better spacing of
#' colors, and increased resolution of color hue.
#'
#' For `colorModel="HCL"` the coordinates are weighted to prioritize
#' matching color Hue above Chroma and Luminance. The distance method
#' by default uses `method="maximum"` which also emphasizes the lowest
#' distance in any of the three dimensions.
#'
#' @returns `character` vector of colors, optionally customized
#' by argument `returnType`.
#'
#' @param x character vector of colors, either in hex format or any
#' valid color in R.
#' @param colorSet `character` vector of colors, by default includes
#' the R colors `grDevices::colors()`.
#' @param C_min,Cgrey `numeric` minimum color Chroma filter applied to
#' handle greyscale colors. In most practical cases `C_min` and `Cgrey`
#' should be the same value. Note `Cgrey` is used as an option in
#' `jamba::make_styles()`, `jamba::applyCLrange()` for similar
#' use cases, so it is used here as well: `getOption("jamba.Cgrey", 5)`.
#' * `C_min` is applied to `colorSet` to require the closest matching
#' color to have at least this color Chroma (saturation).
#' * `Cgrey` is applied to `x` to determine if the input color itself
#' is considered greyscale, in which case it should not be matched
#' with saturated colors since there is no reliable color hue.
#' Instead, the subset of `colorSet` with Chroma below `C_min` is used
#' for color-matching.
#'
#' Reworded in short:
#' * Colors in `x` with Chroma above `Cgrey` are matched with
#' colors in `colorSet` with Chroma above `C_min`.
#' * Colors in `x` with Chroma below `Cgrey` are matched with
#' colors in `colorSet` with Chroma below `C_min`.
#' * The end result should be that saturated input colors match
#' saturated reference colors, and unsaturated input colors match
#' unsaturated reference colors.
#' @param Cgrey `numeric` color Chroma at or below which the input color `x`
#' is considered to be "grey" (or "gray"), and therefore the color
#' hue is no longer matched.
#' @param showPalette `logical` indicating whether to display the input
#' colors and resulting closest matching colors by using
#' `jamba::showColors()`.
#' @param colorModel `character` color model to use:
#' * `"hcl"`: default, uses HCL provided by `jamba::col2hcl()` which
#' uses the equivalent of `colorspace::polarLUV()` and considers
#' color hues in terms of 360 degree angles along a color wheel.
#' * `"LUV"`: uses CIELUV color space, provided by `colorspace::LUV()`
#' which encodes the angular color hue in 3-D Cartesian space,
#' allowing comparisons using Euclidean distance.
#' @param Hwt,Cwt,Lwt `numeric` relative weights for each dimension of
#' HCL colors, for the H, C, and L channels, respectively.
#' @param warpHue `logical` indicating whether to perform the hue warp
#' operation using `h2hw()` which improves the ability to match
#' colors between orange and green.
#' @param preset `character` string to define the color wheel used
#' when matching input colors `x` to colors in `colorSet`.
#' This preset is used with `h2hw()` and `hw2h()`.
#' The default `preset="ryb"` allows greatest distinction in colors
#' without imposing additional restrictions such as by `preset="dichromat"`
#' which would only match color-safe colors. The purpose here is
#' to identify and label colors based upon a reference set of colors.
#' @param method `character` string passed to `stats::dist()`. The default
#' `method="maximum"` works well for `colorModel="hcl"`, and
#' assigns distance using the largest distance across
#' the three color coordinates H, C, and L. It requires the best
#' overall match across all three coordinates rather than any weighted
#' combination of coordinate distances. Other methods in testing allowed
#' matches of different color hues when luminance and chroma values
#' were very similar.
#' With `colorModel="LUV"` we recommend using `method="euclidean"`,
#' which seems to work well with projected color coordinates
#' L, U, and V. The U, and V coordinates are roughly the angular
#' color hue projected into a flat plane, the L describing Luminance.
#' @param returnType `character` type of data to return:
#' * `"color"` returns the color values in `colorSet`, which by default
#' are color names from `grDevices::colors()`
#' * `"name"` returns `names(colorSet)` if they exist, otherwise
#' values from `colorSet`
#' * `"match"` returns an integer vector as an index to `colorSet`
#' @param verbose `logical` whether to print verbose output.
#'
#' @family colorjam core
#'
#' @examples
#' closestRcolor(rainbowJam(12), showPalette=TRUE);
#'
#' @export
closestRcolor <- function
(x,
colorSet=colors(),
C_min=Cgrey,
Cgrey=getOption("jam.Cgrey", 5),
showPalette=FALSE,
colorModel=c("hcl","LUV"),
Hwt=2.5,
Cwt=1,
Lwt=4,
warpHue=TRUE,
preset="ryb",
method="maximum",
returnType=c("color",
"name",
"match"),
verbose=FALSE,
...)
{
## Purpose is simply to name a color by its nearest colors from R colors()
##
## returnType == "color" will return the closest color from colorSet
## returnType == "name" will return the name of the closest color from colorSet
## returnType == "which" will return to closest match as an index integer
colorModel <- match.arg(colorModel);
returnType <- match.arg(returnType);
classX <- class(x);
if (classX %in% "data.frame") {
origXdf <- x;
origX <- as.vector(as.matrix(origXdf));
} else if (classX %in% "matrix") {
origXdf <- x;
origX <- as.vector(origXdf);
} else {
origX <- x;
}
if (length(names(origX)) == 0) {
names(origX) <- jamba::makeNames(origX);
}
if (length(C_min) == 0) {
C_min <- 0;
} else {
C_min <- head(C_min, 1);
}
colorSet_lo <- NULL;
if (C_min > 0) {
colorSet_hcl <- jamba::col2hcl(colorSet);
colorSet_hcl["C",] <- round(colorSet_hcl["C",],
digits=3)
colorSet_lo <- colorSet[colorSet_hcl["C",] < C_min];
colorSet <- colorSet[colorSet_hcl["C",] >= C_min];
}
if (returnType %in% "name" && length(names(colorSet)) == 0) {
names(colorSet) <- jamba::makeNames(colorSet);
}
x <- jamba::nameVector(unique(origX));
xHCL <- NULL;
newX <- NULL;
if (Cgrey > 0 && C_min > 0 && length(colorSet_lo) > 0) {
if (verbose) {
jamba::printDebug("closestRcolor(): ",
"processing low chroma colors.")
}
# convert to HCL
xHCL <- jamba::col2hcl(x);
is_lo <- (xHCL["C",] < Cgrey);
if (any(is_lo)) {
# process unsaturated colors
newX_lo <- closestRcolor(x=x[is_lo],
colorSet=colorSet_lo,
C_min=0,
Cgrey=0,
colorModel=colorModel,
Hwt=Hwt,
Cwt=Cwt,
Lwt=Lwt,
warpHue=warpHue,
preset=preset,
method=method,
returnType="color",
verbose=verbose,
...)
newX <- rep("", length(x));
newX[is_lo] <- newX_lo;
# names(newX)[is_lo] <- x[is_lo];
# process saturated colors
if (any(!is_lo)) {
newX_hi <- closestRcolor(
x=x[!is_lo],
colorSet=colorSet,
C_min=0,
Cgrey=0,
colorModel=colorModel,
Hwt=Hwt,
Cwt=Cwt,
Lwt=Lwt,
warpHue=warpHue,
preset=preset,
method=method,
returnType="color",
verbose=verbose,
...)
newX[!is_lo] <- newX_hi;
# names(newX)[!is_lo] <- names(newX_hi);
# names(newX)[!is_lo] <- x[!is_lo];
} else {
newX_hi <- NULL;
}
names(newX) <- x;
}
}
if (length(newX) == 0) {
if ("hcl" %in% colorModel) {
# hcl
# Simple angular distance
angDist <- function(a, b, ...){
x1 <- rep(a, length(b));
y1 <- rep(b, each=length(a));
diff1 <- abs(x1-y1);
diff1[diff1 > 180] <- 360 - diff1[diff1 > 180];
diff1;
matrix(diff1, ncol=length(b), nrow=length(a),
dimnames=list(names(a), names(b)));
}
if (length(xHCL) == 0) {
xHCL <- jamba::col2hcl(x);
}
colorSetHCL <- jamba::col2hcl(jamba::nameVector(colorSet));
## Adjust H to RYB
if (warpHue) {
xHCL["H",] <- h2hw(xHCL["H",],
preset=preset);
colorSetHCL["H",] <- h2hw(colorSetHCL["H",],
preset=preset);
}
Hdist <- angDist(a=xHCL["H",],
b=colorSetHCL["H",])/180*100;
CLm <- rbind(t(xHCL), t(colorSetHCL))[,c("L","C"),drop=FALSE];
CLm[,"C"] <- CLm[,"C"] * Cwt;
CLm[,"L"] <- CLm[,"L"] * Lwt;
CLdist <- as.matrix(dist(CLm,
method=method))[colnames(xHCL), colnames(colorSetHCL), drop=FALSE];
if (verbose) {
jamba::printDebug("dim(Hdist):", dim(Hdist));
jamba::printDebug("dim(CLdist):", dim(CLdist));
}
HCLdist <- Hdist * Hwt + CLdist;
iClosestColorWhich <- apply(HCLdist, 1, which.min);
newX <- jamba::nameVector(colorSet[iClosestColorWhich],
colnames(xHCL));
} else if ("LUV" %in% colorModel) {
## Use LUV
col2LUV <- function(a) {
if (length(names(a)) == 0) {
names(a) <- jamba::makeNames(a);
}
# convert color
colorspace::coords(as(colorspace::hex2RGB(
jamba::rgb2col(grDevices::col2rgb(a))), "LUV"));
}
xLUV <- col2LUV(x);
colorSetLUV <- col2LUV(colorSet);
LUVdist <- as.matrix(dist(rbind(xLUV,
colorSetLUV),
method=method))[rownames(xLUV), rownames(colorSetLUV), drop=FALSE];
iClosestColorWhich <- apply(LUVdist, 1, which.min);
newX <- jamba::nameVector(colorSet[iClosestColorWhich],
rownames(xLUV));
}
}
# 0.0.25.900 - names are not assigned from input
# instead are assigned from `colorSet`
retX <- newX[origX];
if (length(colorSet_lo) > 0) {
colorSet <- c(colorSet, colorSet_lo);
}
imatch <- match(retX, colorSet);
# print("head(imatch, 20):");print(head(imatch, 20));# debug
if (length(names(colorSet)) > 0) {
names(retX) <- jamba::makeNames(names(colorSet)[imatch]);
} else {
names(retX) <- NULL;
}
if ("match" %in% returnType) {
retX[] <- imatch;
} else if ("name" %in% returnType && length(names(colorSet)) > 0) {
retX[] <- names(colorSet)[imatch];
}
# if (length(names(origX)) > 0) {
# names(retX) <- names(origX);
# }
## Optionally display the palette before and after
if (showPalette) {
use_origX <- origX;
if (length(names(use_origX)) == 0) {
names(use_origX) <- origX;
}
use_retX <- retX;
if (length(names(use_retX)) == 0) {
names(use_retX) <- retX;
}
jamba::showColors(list(
original=use_origX,
returned=use_retX),
...);
}
## Return to data.frame or matrix form if needed
if (classX %in% c("data.frame", "matrix")) {
retX <- matrix(ncol=ncol(origXdf), retX, dimnames=dimnames(origXdf));
if (classX %in% c("data.frame")) {
retX <- as.data.frame(retX);
}
}
return(retX);
}
#' Assign colors to vector of group labels
#'
#' Assign colors to vector of group labels
#'
#' This function takes a character or factor vector as input, then
#' assigns categorical colors to each label using `colorFunc`, by
#' default `rainbowJam()`.
#'
#' If a previous set of colors has already been defined, the parameter
#' `colorSub` is intended to maintain that same set of colors. However,
#' all input values in `x` must be present in the `names(colorSub)`
#' otherwise all colors are reassigned.
#'
#' In future, this function will maintain a partial set of colors,
#' while assigning colors with maximum visible differences from the
#' existing colors.
#'
#' @param x character or factor vector representing group membership.
#' @param alpha numerical value indicating the alpha transparency to
#' apply to the output colors, scaled from 0 (fully transparent) to
#' 1 (no transparency).
#' @param colorFunc function whose first parameter is the number of
#' colors to return, and where `...` is passed for additional
#' parameters as needed. By default it uses `colorjam::rainbowJam()`.
#' @param colorSub optional named vector of colors, whose names must
#' match all entries in `x`. This vector is used to re-apply
#' colors which have already been assigned to the labels in `x`.
#' @param useGradient logical indicating whether to apply a light-to-dark
#' gradient to repeated colors, for example to distinguish multiple
#' replicates of a group.
#' @param sortFunc function to use when sorting character or numeric
#' input in `x`, by default `jamba::mixedSort()`. When input `x` is
#' a factor, the factor levels are maintained in the same order.
#' @param verbose logical indicating whether to print verbose output.
#' @param ... additional parameters are passed to `colorFunc`
#'
#' @family colorjam core
#' @family colorjam assignment
#'
#' @examples
#' abcde <- group2colors(letters[1:5]);
#' aabbccddee <- group2colors(rep(letters[1:5], each=2));
#' aaabbcccccdeeee <- group2colors(rep(letters[1:5], c(3,2,5,1,4)));
#' aaabbcccccdeeee2 <- group2colors(rep(letters[1:5], c(3,2,5,1,4)), useGradient=TRUE);
#'
#' jamba::showColors(list(abcde=abcde,
#' aabbccddee=aabbccddee,
#' aaabbcccccdeeee=aaabbcccccdeeee,
#' aaabbcccccdeeee2=aaabbcccccdeeee2));
#'
#' @export
group2colors <- function
(x,
alpha=1,
colorFunc=rainbowJam,
colorSub=NULL,
sortFunc=jamba::mixedSort,
useGradient=FALSE,
verbose=FALSE,
...)
{
## Purpose is to take a character vector input, and assign colors
## to each unique value.
## By default, it uses colorjam::rainbowJam(), however any function
## which return n number of colors will suffice, for example
##
if (length(sortFunc) == 0 || !is.function(sortFunc)) {
sortFunc <- c;
}
if (jamba::igrepHas("factor", class(x))) {
xLabels <- levels(x);
} else {
xLabels <- sortFunc(unique(x));
}
if (all(xLabels %in% names(colorSub))) {
xColors <- colorSub;
} else {
xColors <- jamba::nameVector(
colorFunc(length(xLabels),
...),
xLabels);
}
## Apply colors to the input data
xColorsNew <- xColors[match(as.character(x), names(xColors))];
if (useGradient) {
xColorsNew <- jamba::color2gradient(xColorsNew,
...);
}
if (length(names(x)) > 0) {
names(xColorsNew) <- names(x);
}
xColorsNew;
}
#' Convert numeric matrix to heatmap colors
#'
#' Convert numeric matrix to heatmap colors
#'
#' This function is intended as a rapid way of applying a color
#' gradient to columns of numeric values, where each column
#' has its own base color. It calls `jamba::getColorRamp()`
#' for each column, and when supplied with one color, it
#' creates a color gradient from `"grey95"` to the output
#' of `jamba::color2gradient()`.
#'
#' When `lens` is non-zero, the color gradient is warped in order
#' to intensify the color saturation across the numeric range.
#'
#' @param x numeric matrix. If there are no `colnames(x)` they will
#' be created using `jamba::makeNames(rep("x", ncol(x)))`.
#' @param colorV character vector of R colors, named by `colnames(x)`,
#' and recycled to `ncol(x)` if needed. If `colorV` is supplied as
#' a list, the list elements are mapped to `colnames(x)` in order.
#' @param defaultBaseColor character vector of R colors used as the default
#' base color, when `colorV` is supplied as a vector.
#' @param transformFunc function applied to numeric values before
#' the color gradient is mapped to numeric values. For example,
#' `transformFunc=function(i)-log10(i)` would map colors to P-value
#' using a `-log10(p)` transformation.
#' @param lens numeric value passed to `warpRamp()` to adjust the
#' distribution of colors along the numeric range.
#' @param shareLimit logical indicating whether one numeric limit `numLimit`
#' should be used to define the numeric range for color mapping.
#' @param numLimitFactor when `numLimit` is NULL, this factor is applied to
#' the maximum numeric value to determine the `numLimit`.
#' @param numLimit numeric value to define the maximum numeric value
#' above which all numeric values are mapped to the maximum color.
#' When set to `NULL` the `numLimitFactor` is used to define
#' the `numLimit`.
#' @param baseline numeric value to define the numeric baseline, used
#' when `divergent=FALSE`. Values are recycled to `ncol(x)` to be
#' applied to each column individually.
#' @param color_below_baseline color used when numeric value is
#' below the `baseline`. Values are recycled to `ncol(x)` to be
#' applied to each column individually. When `color_below_baseline`
#' is `NULL`, the first color in the color ramp is used for all
#' values below the baseline.
#' @param divergent logical indicating whether to apply colors to the numeric
#' range symmetric around zero.
#' @param rampN integer value to define the number of color breaks for
#' each color gradient.
#' @param trimRamp numeric vector with two values, used by
#' `jamba::getColorRamp()` to trim the intermediate color gradient before
#' creating the final color ramp with length `rampN`. For example,
#' by default `jamba::getColorRamp()` creates a color gradient with
#' 15 colorr, defined by argument `gradientN=15`, so the argument
#' `trimRamp=c(4,2)` will trim the first 4 colors and the last 2 colors
#' from the 15-color gradient, before generating the final color
#' gradient with length `rampN`. The `trimRamp` argument is especially
#' useful to remove the leading white color, or to trim the first
#' few colors to ensure the first color in the gradient is visibly
#' different from the background color defined by `defaultBaseColor`.
#' @param verbose logical indicating whether to print verbose output.
#' @param ... additional arguments are passed to `jamba::getColorRamp()`
#' for additional customization. These arguments are handled across
#' all columns, and not a column-by-column basis.
#'
#' @family colorjam assignment
#'
#' @examples
#' set.seed(123);
#' # generate a random numeric matrix
#' m1 <- matrix(ncol=12, rnorm(120));
#' m1n <- m1;
#' m1n[] <- format(round(abs(m1), digits=2), trim=TRUE);
#' jamba::imageByColors(
#' matrix2heatColors(abs(m1),
#' transformFunc=c,
#' divergent=FALSE,
#' lens=-5,
#' shareNumLimit=TRUE,
#' baseline=0,
#' numLimit=4),
#' cellnote=m1n);
#'
#' @export
matrix2heatColors <- function
(x,
colorV=group2colors(colnames(x)),
defaultBaseColor="#FFFFFF",
transformFunc=c,
lens=0,
shareLimit=TRUE,
numLimitFactor=0.95,
numLimit=NULL,
baseline=0,
color_below_baseline="#FFFFFF",
divergent=FALSE,
rampN=15,
trimRamp=c(0, 0),
verbose=FALSE,
...)
{
## Purpose is to create a color gradient from a numeric matrix
## intended for when each column should have its own distinct color
## usually a gradient from white to the specified color.
##
## This function calls vals2colorLevels() for each column.
##
## Make sure x has colnames
if (length(colnames(x)) == 0) {
colnames(x) <- jamba::makeNames(rep("x", ncol(x)));
}
xNames <- colnames(x);
## Define farbeLim if not provided
if (length(numLimit) == 0) {
if (shareLimit) {
## Shared max color value
numLimit <- max(jamba::rmNA(abs(transformFunc(x)))) * numLimitFactor;
if (verbose) {
jamba::printDebug("matrix2heatColors():",
"defined shared farbeLim value:",
format(digits=2, numLimit));
}
numLimit <- rep(numLimit, length.out=ncol(x));
} else {
numLimit <- sapply(1:ncol(x), function(i){
numLimit <- max(jamba::rmNA(abs(transformFunc(x)))) * numLimitFactor;
});
if (verbose) {
jamba::printDebug("matrix2heatColors():",
"defined individual numLimit values:",
format(digits=2, numLimit));
}
}
names(numLimit) <- xNames;
} else {
numLimit <- rep(numLimit, length.out=ncol(x));
if (verbose) {
jamba::printDebug("matrix2heatColors():",
"numLimit values as provided:",
format(digits=2, numLimit));
}
if (length(names(numLimit)) > 0 &&
all(names(numLimit) %in% xNames)) {
numLimit <- numLimit[xNames];
} else {
names(numLimit) <- xNames;
}
}
lens <- jamba::nameVector(rep(lens,
length.out=ncol(x)),
xNames);
defaultBaseColor <- jamba::nameVector(rep(defaultBaseColor,
length.out=ncol(x)),
xNames);
baseline <- jamba::nameVector(rep(baseline,
length.out=ncol(x)),
xNames);
color_below_baseline <- jamba::nameVector(rep(color_below_baseline,
length.out=ncol(x)),
xNames);
numLimit <- jamba::nameVector(rep(numLimit,
length.out=ncol(x)),
xNames);
rampN <- jamba::nameVector(rep(rampN,
length.out=ncol(x)),
xNames);
divergent <- jamba::nameVector(rep(divergent,
length.out=ncol(x)),
xNames);
colorV <- jamba::nameVector(rep(colorV,
length.out=ncol(x)),
xNames);
xColors <- do.call(cbind, lapply(jamba::nameVector(colnames(x)), function(i){
k <- (transformFunc(x[,i]));
if (verbose) {
jamba::printDebug("matrix2heatColors():", i,
", lens:", format(lens[i], digits=2),
", defaultBaseColor:", defaultBaseColor[i],
", baseline:", format(baseline[i], digits=2),
", numLimit:", format(numLimit[i], digits=2),
", colorRamp:", colorV[[i]],
fgText=list("orange", "lightblue",
"orange", "lightblue",
"orange", defaultBaseColor[i],
"orange", "lightblue",
"orange", "lightblue",
"orange", colorV[[i]]));
}
if (divergent[i]) {
## divergent color ramp
k <- jamba::noiseFloor(k,
minimum=-numLimit[i],
ceiling=numLimit[i]);
kRamp <- jamba::getColorRamp(colorV[[i]],
defaultBaseColor=defaultBaseColor[i],
lens=lens[i],
divergent=TRUE,
n=rampN[i],
trimRamp=trimRamp,
...);
if (verbose) {
jamba::printDebug("matrix2heatColors(): ",
"divergent:", divergent,
",\nkRamp:", kRamp,
fgText=list("orange", "dodgerblue", "orange",
"dodgerblue", kRamp));
}
kCut <- cut(k,
include.lowest=TRUE,
breaks=seq(from=-numLimit[i],
to=numLimit[i],
length.out=rampN[i]+1));
kColor <- kRamp[kCut];
} else {
## one-directional color ramp
k <- jamba::noiseFloor(k,
minimum=baseline[i],
newValue=baseline[i]-1,
ceiling=numLimit[i]);
kRamp <- jamba::getColorRamp(colorV[[i]],
defaultBaseColor=defaultBaseColor[i],
lens=lens[i],
divergent=FALSE,
n=rampN[i],
trimRamp=trimRamp,
...);
if (length(color_below_baseline[i]) == 0) {
kRamp <- c(kRamp[1], kRamp);
} else {
kRamp <- c(color_below_baseline[i], kRamp);
}
if (verbose) {
jamba::printDebug("matrix2heatColors(): ",
"divergent:", divergent[i],
",\nkRamp:", kRamp,
fgText=list("orange", "dodgerblue", "orange",
"dodgerblue", kRamp));
}
kCut <- cut(k,
include.lowest=TRUE,
breaks=c(baseline[i]-1,
seq(from=baseline[i],
to=numLimit[i],
length.out=rampN[i]+1)));
kColor <- kRamp[kCut];
}
kColor;
}));
rownames(xColors) <- rownames(x);
return(xColors);
}
#' Apply color gradient to numeric values
#'
#' Apply color gradient to numeric values
#'
#' This function is similar to several other existing R functions
#' that take a vector of numeric values, and apply a color gradient
#' (color ramp) to the numeric values. This function provides the ability
#' to warp the color ramp, for example using `jamba::warpRamp()` in order
#' to adjust the color gradient relative to the numeric range of the
#' data.
#'
#' Note that the function `col_div_xf()` and `col_linear_xf()` may
#' be preferable to this function. Those functions assign colors
#' to specific numeric values, instead of assigning colors between
#' numeric break points.
#'
#' @family colorjam assignment
#'
#' @param x numeric vector
#' @param divergent logical indicating whether the numeric values
#' are divergent, by default baseline=0 will center the color
#' ramp at zero.
#' @param col color value compatible with the `col` argument of
#' `jamba::getColorRamp()`. Example include: single color; multiple
#' colors; single color ramp name; or a custom color function.
#' @param defaultBaseColor character color used as a base color when
#' a single color is supplied in `col`.
#' @param lens numeric value sent to `jamba::warpRamp()`, to define the
#' level of color warping to apply to the color gradient, where `lens=0`
#' applies no adjustment.
#' @param numLimit numeric value indicating the maximum numeric value,
#' where values in `x` greater than this value are assigned to the
#' maximum color. When not defined, and `divergent=TRUE` it uses
#' `max(abs(x), na.rm=TRUE)`, or `divergent=FALSE` it uses
#' `max(x, na.rm=TRUE)`.
#' @param baseline numeric value indicating the minimum numeric value,
#' where values in `x` less than this value are assigned to the
#' minimum color. When not defined, and `divergent=TRUE` it sets
#' `baseline=0`; when `divergent=FALSE` it uses `min(x, na.rm=TRUE)`.
#' @param rampN integer number of colors to define for the color
#' gradient. Higher values define a smooth color gradient.
#' @param verbose logical indicating whether to print verbose output.
#' @param ... additional arguments are passed to `jamba::getColorRamp()`.
#'
#' @family jam color functions
#'
#' @examples
#' # Start with an example numeric vector
#' x <- jamba::nameVector(-5:10);
#' jamba::showColors(vals2colorLevels(x));
#'
#' # decrease the number of gradient colors
#' jamba::showColors(vals2colorLevels(x, rampN=15))
#'
#' # change the baseline
#' jamba::showColors(vals2colorLevels(x, baseline=-2));
#'
#' # adjust the gradient using lens
#' par("mar"=c(5,5,4,2));
#' jamba::imageByColors(jamba::rbindList(lapply(jamba::nameVector(c(-5,-2,0,2,5)), function(lens){
#' vals2colorLevels(x, rampN=25, lens=lens);
#' })));
#' title(ylab="color lens factor", xlab="numeric value",
#' main="Effects of warping the color gradient");
#'
#' @export
vals2colorLevels <- function
(x,
divergent=TRUE,
col="RdBu_r",
defaultBaseColor="#FFFFFF",
lens=0,
numLimit=NULL,
baseline=NULL,
rampN=25,
verbose=FALSE,
...)
{
## Purpose is to convert a numeric vector into a color gradient
if (length(divergent) == 0) {
divergent <- FALSE;
}
if (length(defaultBaseColor) == 0) {
defaultBaseColor <- "#FFFFFF";
}
if (length(lens) == 0) {
lens <- 0;
}
if (length(rampN) == 0) {
rampN <- 15;
}
if (length(col) == 0) {
if (divergent) {
col <- "RdBu_r";
} else {
col <- "Reds";
}
}
## If no baseline is provided, infer an appropriate one
if (length(baseline) == 0) {
if (divergent || min(x, na.rm=TRUE) == max(x, na.rm=TRUE)) {
baseline <- 0;
} else {
baseline <- min(x, na.rm=TRUE);
}
}
if (length(numLimit) == 0) {
if (divergent) {
numLimit <- max(abs(x-baseline)+baseline, na.rm=TRUE);
} else {
numLimit <- max(x, na.rm=TRUE);
}
## Correct issue when numLimit == baseline
if (numLimit == baseline) {
numLimit <- baseline + 1;
}
}
## Get the color ramp values
colorV <- jamba::getColorRamp(col=col,
n=rampN,
defaultBaseColor=defaultBaseColor,
verbose=verbose,
...);
## Optionally print verbose output
if (verbose) {
if (divergent) {
colorVnames <- rep(seq(from=1, to=floor(length(colorV)/2)), each=2)*c(-1,1);
if (length(colorV) %% 2) {
colorVnames <- sort(c(0, colorVnames));
}
} else {
colorVnames <- seq_along(colorV);
}
jamba::printDebug("vals2colorLevels(): ",
"colorV:\n",
format(colorVnames),
sep=", ",
Lrange=c(10,95), Crange=c(40,95),
fgText=list("orange", "dodgerblue", colorV));
}
## Optionally warp the color ramp
if (lens != 0) {
colorV <- jamba::warpRamp(colorV,
divergent=TRUE,
lens=lens,
...);
if (verbose) {
jamba::printDebug("vals2colorLevels(): ",
"colorV (lens):\n",
format(colorVnames),
sep=", ",
Lrange=c(10,95), Crange=c(40,95),
fgText=list("orange", "dodgerblue", colorV));
}
}
## Apply the color gradient
if (divergent) {
## divergent color ramp
k <- jamba::noiseFloor(x,
minimum=baseline-numLimit,
ceiling=numLimit);
kBreaks <- seq(from=2*baseline-numLimit,
to=numLimit,
length.out=rampN+1);
} else {
## one-directional color ramp
k <- jamba::noiseFloor(x,
minimum=baseline,
ceiling=numLimit);
kBreaks <- seq(from=baseline,
to=numLimit,
length.out=rampN+1);
}
if (verbose) {
colorVbreaks <- c(head(colorV, ceiling(length(colorV)/2)),
tail(colorV, ceiling(length(colorV)/2)));
jamba::printDebug("vals2colorLevels(): ",
"kBreaks:\n",
format(round(digits=1, kBreaks)),
sep=", ",
Lrange=c(10,95), Crange=c(40,95),
fgText=list("orange", "dodgerblue", colorVbreaks));
}
kCut <- cut(k,
include.lowest=TRUE,
breaks=kBreaks);
kColor <- unname(colorV[as.numeric(kCut)]);
if (length(names(x)) > 0) {
names(kColor) <- names(x);
}
kColor;
}
#' Closest colorjam named_colors
#'
#' Closest colorjam named_colors for a vector of colors
#'
#' @family colorjam core
#'
#' @inheritParams closestRcolor
#'
#' @param colorSet `character` vector of colors, by default `named_colors`
#' with provides 4,447 total hex colors, each with human-assigned
#' color name. These colors also include hex colors from R `colors()`
#' which were not already included in the reference colors.
#'
#' @export
closest_named_color <- function
(x,
colorSet=named_colors,
C_min=Cgrey,
Cgrey=getOption("jam.Cgrey", 5),
showPalette=FALSE,
colorModel=c("hcl", "LUV"),
Hwt=2.5,
Cwt=1,
Lwt=4,
warpHue=TRUE,
preset="ryb",
method="maximum",
returnType=c("color",
"name",
"match"),
verbose=FALSE,
...)
{
#
closestRcolor(x=x,
colorSet=colorSet,
C_min=C_min,
Cgrey=Cgrey,
showPalette=showPalette,
colorModel=colorModel,
Hwt=Hwt,
Cwt=Cwt,
Lwt=Lwt,
warpHue=warpHue,
preset=preset,
method=method,
returnType=returnType,
verbose=verbose,
...);
}
jmw86069/colorjam documentation built on March 18, 2024, 3:32 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' rainbow categorical colors using varied luminance and chroma
#'
#' rainbow categorical colors using varied luminance and chroma
#'
#' This function customizes similar functions \code{grDevices::rainbow},
#' [colorspace::rainbow_hcl()], and [scales::hue_pal()] in two main
#' ways:
#'
#' 1. It uses the warped color wheel (see [h2hw()] which compresses the
#' green component of the standard HCL color hue wheel, extending the yellow.
#' 2. It uses a varying luminance and chroma vector which was selected to
#' optimize visual distinctiveness of adjacent colors. There is still a limit
#' to the maximum number of effectively different categorical colors, however
#' this function appears to improve other available methods.
#'
#' This function is also intended to enable use of a custom color wheel,
#' for example a set of color mappings could define color-blind friendly
#' ranges of colors when using the warped hue functions [h2hw()] and
#' [hw2h()]. When `warpHue=TRUE` the values for `h1` and
#' `h2` are used to define a mapping from warped hues to standard
#' hues recognized by [hcl()].
#'
#' @param n integer number of categorical colors to return
#' @param alpha numeric alpha transparency of colors, values ranging from
#' 0 to 1. If multiple values are supplied, they are applied in order to
#' the categorical colors returned.
#' @param nfloor the minimum number of effective color slices taken from the
#' hue color wheel, primarily used as an aesthetic choice so the first two
#' colors will be reasonably consistent when choosing 1, 2, 3, 4, or 5
#' categorical colors.
#' @param hues optional numeric vector of hues to use, only useful when the
#' exact hues should be used instead of taking slices along a hue color
#' wheel. Note that to use hue values with no modification, one should
#' also set \code{warpHue=FALSE}, otherwise the given hues are assumed to
#' warped hue values.
#' @param Cvals,Lvals vector of chroma (C) and luminance (L) values to be
#' cycled when creating colors along the vector of color hues. These
#' values are intended to maximize visual distinctiveness of adjacent and
#' nearly-adjacent colors. For example, varying from bright to dark may
#' provide additional distinction between two similar color hues.
#' @param Crange,Lrange vector of two numeric values which define the allowable
#' chroma (C) and luminance (L) ranges for \code{Cvals} and \code{Lvals}
#' parameter values. If supplied, the numeric vector Cvals will be scaled
#' so the lowest Cvals value maps to the first value in Crange, and the
#' highest Cvals value maps to the last value in Crange. Varying the
#' Crange and Lrange values can help produce categorical colors on a
#' dark or light background, by changing the range of values being used.
#' @param Hstart the hue to use for the first hue value in the color sequence.
#' Standard red has a hue 12.2, which is the default for this function.
#' @param doTest boolen indicating whether to perform a visual test for
#' the \code{n} number of colors produced, which helps judge the
#' visual distinctiveness of different combinations of dark and light
#' colors.
#' @param sFactor,darkFactor parameters sent to \code{jamba::makeColorDarker}
#' if either is not equal to 1. Setting \code{darkFactor=2} is a quick
#' way of generating categorical border colors, for example drawing a
#' colored border around categorical colors. Alternatively, setting
#' \code{sFactor=-2, darkFactor=-2} can be used to desaturate and lighten
#' colors used for the background area of a rectangle. The \code{alpha}
#' transparency parameter can also be helpful, however not all graphics
#' devices support transparency, in which case it is more robust to define
#' the exact color.
#' @param nameStyle character value indicating how to name the output
#' colors: "none" returns colors with no names; "hcl" assigns names with
#' the color number prefix, followed by H, C, L values; "colors" names the
#' vector by the hex color code.
#' @param h1,h2 numeric vectors as used by [h2hw()] and [hw2h()] to
#' convert from warped hues to standard hues. The default values define
#' red-yellow-blue (additive) color space, which is converted to
#' red-green-blue color space to produce the actual R color.
#' @param verbose logical whether to print verbose output
#'
#' @return vector of colors
#'
#' @family colorjam deprecated
#'
#' @examples
#' rainbowJam_v1(12);
#'
#' # show colors
#' jamba::showColors(rainbowJam_v1(12));
#'
#' # be fancy and label colors using the closest R named color
#' jamba::showColors(rainbowJam_v1(12, nameStyle="colors"));
#'
#' @export
rainbowJam_v1 <- function
(n=NULL,
alpha=1,
nfloor=4,
hues=NULL,
Cvals=c(75,95,80, 65,72,80),
Lvals=c(62,83,69,58,65,74),
# Scaling of the ranges above
#Crange=getOption("jam.Crange"),
#Lrange=getOption("jam.Lrange"),
#Cgrey=getOption("jam.Cgrey"),
Crange=NULL,
Lrange=NULL,
Cgrey=NULL,
Hstart=12.2,
warpHue=TRUE,
doTest=FALSE,
sFactor=1,
darkFactor=1,
nameStyle=c("none","hcl","colors"),
h1=h2hwOptions()$h1,
h2=h2hwOptions()$h2,
verbose=FALSE,
...)
{
## Purpose is to provide categorical colors, using the HCL
## smooth colorspace (which offers uniform changes in lightness,
## chromaticity(saturation). But for here, we deliberately
## fluctuate the lightness and saturation as we rotate around
## the rainbow of colors, to help visually separate each color.
##
##
nameStyle <- match.arg(nameStyle);
## Test with doTest=TRUE:
if (doTest) {
oPar <- par();
par(mfrow=c(5,1));
colSet <- jamba::nameVector(rainbowJam_v1(n), 1:n);
jamba::showColors(colSet,
main=paste("n =", n, " colors"),
xaxt="n");
title("The more colors, the more likely non-adjacent colors will look similar");
jamba::showColors(colSet[seq(from=1, to=n, by=3)],
main="offset by 3 (Dark colors)",
xaxt="n");
if (n > 1) {
fullHiSet <- seq(from=2, to=n, by=3);
whichHiSet <- fullHiSet[-seq(from=2, to=length(fullHiSet), by=2)];
jamba::showColors(colSet[whichHiSet],
main="Light colors",
xaxt="n");
jamba::showColors(colSet[-whichHiSet],
main="Non-light colors",
xaxt="n");
if (n > 2) {
jamba::showColors(colSet[seq(from=3, to=n, by=2)],
main="offset by 2 + 3 (Medium colors)",
xaxt="n");
}
}
par(oPar);
return(NULL);
}
if (length(n) == 0) {
n <- 1;
}
if (length(Cvals) == 0) {
stop("rainbowJam() requires Cvals and Lvals to be defined.");
}
if (length(Lvals) == 0) {
stop("rainbowJam() requires Cvals and Lvals to be defined.");
}
## Generate a color hue sequence
nHues <- max(c(nfloor, n));
if (length(hues) == 0) {
## hue starts from 0 to 360,
## add the Hstart to rotate the color hues,
## trim to values between 0 and 360
hues <- head(
(seq(from=0,
to=360,
length.out=(nHues+1)) + Hstart) %% 360,
n);
}
## adjust hues to warped hues
if (warpHue) {
if (verbose) {
jamba::printDebug("rainbowJam(): ",
"warping hues");
ch(data.frame(h1=h1, h2=h2), Inf);
}
hues <- hw2h(hues,
h1=h1,
h2=h2);
}
if (verbose) {
jamba::printDebug("rainbowJam(): ",
"hues:",
format(digits=2, hues));
}
## Scale the lVals and cVals ranges to given lRange and cRange if needed
## (note we have to do the scaling before taking a subset of values!)
if (length(Lrange) == 2 && !all(Lrange %in% range(Lvals))) {
#Lvals <- normScale(Lvals,
# from=Lrange[1],
# to=Lrange[2]);
## 19nov2018 changed to restrict the extremes, not stretch the
## interior values to the minimum/maximum
Lvals <- normScale(Lvals,
low=min(c(Lrange[1], min(Lvals))),
high=max(c(Lrange[2], max(Lvals))),
from=Lrange[1],
to=Lrange[2]);
}
if (length(Crange) == 2 && !all(Crange %in% range(Cvals))) {
#Cvals <- normScale(Cvals,
# from=Crange[1],
# to=Crange[2]);
Cvals <- normScale(Cvals,
low=min(c(Crange[1], min(Cvals))),
high=max(c(Crange[2], max(Cvals))),
from=Crange[1],
to=Crange[2]);
}
Cvals <- rep(Cvals, length.out=n);
Lvals <- rep(Lvals, length.out=n);
alpha <- rep(alpha, length.out=n);
if (verbose) {
hclDF <- data.frame(H=hues,
C=Cvals,
L=Lvals,
alpha=alpha);
jamba::printDebug("H: ", format(digits=2, hues));
jamba::printDebug("C:", format(digits=2, Cvals));
jamba::printDebug("L:", format(digits=2, Lvals));
jamba::printDebug("alpha:", alpha);
}
## Generate colors using HCL definitions
hclSet <- jamba::hcl2col(H=hues,
C=Cvals,
L=Lvals,
alpha=alpha);
if (any(abs(sFactor) != 1) || any(abs(darkFactor) != 1)) {
if (verbose) {
jamba::printDebug("rainbowJam(): ",
"applying darkFactor, sFactor with makeColorDarker().")
}
hclSet <- makeColorDarker(hclSet,
darkFactor=postDarkFactor,
sFactor=postSfactor,
...);
}
if (nameStyle %in% "hcl") {
hclNames <- jamba::makeNames(paste(seq_len(n),
paste0("H", signif(hues, digits=3)),
paste0("C", signif(Cvals, digits=3)),
paste0("L", signif(Lvals, digits=3)),
sep="_"));
names(hclSet) <- hclNames;
} else if (nameStyle %in% "colors") {
hclNames <- jamba::makeNames(closestRcolor(hclSet));
names(hclSet) <- hclNames;
} else {
hclSet <- unname(hclSet);
}
return(hclSet);
}
#' Find the closest R color
#'
#' Find the closest R color for a vector of colors
#'
#' This function is intended as a relatively efficient method to compare
#' a set of colors to the named R colors provided by `grDevices::colors()`.
#'
#' Color matching provides substantial improvements over similar functions
#' from other R packages. Notably, colors are matched using either
#' HCL or LUB color model by default, both of which provide vast
#' improvement over RGB color matching, due to better spacing of
#' colors, and increased resolution of color hue.
#'
#' For `colorModel="HCL"` the coordinates are weighted to prioritize
#' matching color Hue above Chroma and Luminance. The distance method
#' by default uses `method="maximum"` which also emphasizes the lowest
#' distance in any of the three dimensions.
#'
#' @returns `character` vector of colors, optionally customized
#' by argument `returnType`.
#'
#' @param x character vector of colors, either in hex format or any
#' valid color in R.
#' @param colorSet `character` vector of colors, by default includes
#' the R colors `grDevices::colors()`.
#' @param C_min,Cgrey `numeric` minimum color Chroma filter applied to
#' handle greyscale colors. In most practical cases `C_min` and `Cgrey`
#' should be the same value. Note `Cgrey` is used as an option in
#' `jamba::make_styles()`, `jamba::applyCLrange()` for similar
#' use cases, so it is used here as well: `getOption("jamba.Cgrey", 5)`.
#' * `C_min` is applied to `colorSet` to require the closest matching
#' color to have at least this color Chroma (saturation).
#' * `Cgrey` is applied to `x` to determine if the input color itself
#' is considered greyscale, in which case it should not be matched
#' with saturated colors since there is no reliable color hue.
#' Instead, the subset of `colorSet` with Chroma below `C_min` is used
#' for color-matching.
#'
#' Reworded in short:
#' * Colors in `x` with Chroma above `Cgrey` are matched with
#' colors in `colorSet` with Chroma above `C_min`.
#' * Colors in `x` with Chroma below `Cgrey` are matched with
#' colors in `colorSet` with Chroma below `C_min`.
#' * The end result should be that saturated input colors match
#' saturated reference colors, and unsaturated input colors match
#' unsaturated reference colors.
#' @param Cgrey `numeric` color Chroma at or below which the input color `x`
#' is considered to be "grey" (or "gray"), and therefore the color
#' hue is no longer matched.
#' @param showPalette `logical` indicating whether to display the input
#' colors and resulting closest matching colors by using
#' `jamba::showColors()`.
#' @param colorModel `character` color model to use:
#' * `"hcl"`: default, uses HCL provided by `jamba::col2hcl()` which
#' uses the equivalent of `colorspace::polarLUV()` and considers
#' color hues in terms of 360 degree angles along a color wheel.
#' * `"LUV"`: uses CIELUV color space, provided by `colorspace::LUV()`
#' which encodes the angular color hue in 3-D Cartesian space,
#' allowing comparisons using Euclidean distance.
#' @param Hwt,Cwt,Lwt `numeric` relative weights for each dimension of
#' HCL colors, for the H, C, and L channels, respectively.
#' @param warpHue `logical` indicating whether to perform the hue warp
#' operation using `h2hw()` which improves the ability to match
#' colors between orange and green.
#' @param preset `character` string to define the color wheel used
#' when matching input colors `x` to colors in `colorSet`.
#' This preset is used with `h2hw()` and `hw2h()`.
#' The default `preset="ryb"` allows greatest distinction in colors
#' without imposing additional restrictions such as by `preset="dichromat"`
#' which would only match color-safe colors. The purpose here is
#' to identify and label colors based upon a reference set of colors.
#' @param method `character` string passed to `stats::dist()`. The default
#' `method="maximum"` works well for `colorModel="hcl"`, and
#' assigns distance using the largest distance across
#' the three color coordinates H, C, and L. It requires the best
#' overall match across all three coordinates rather than any weighted
#' combination of coordinate distances. Other methods in testing allowed
#' matches of different color hues when luminance and chroma values
#' were very similar.
#' With `colorModel="LUV"` we recommend using `method="euclidean"`,
#' which seems to work well with projected color coordinates
#' L, U, and V. The U, and V coordinates are roughly the angular
#' color hue projected into a flat plane, the L describing Luminance.
#' @param returnType `character` type of data to return:
#' * `"color"` returns the color values in `colorSet`, which by default
#' are color names from `grDevices::colors()`
#' * `"name"` returns `names(colorSet)` if they exist, otherwise
#' values from `colorSet`
#' * `"match"` returns an integer vector as an index to `colorSet`
#' @param verbose `logical` whether to print verbose output.
#'
#' @family colorjam core
#'
#' @examples
#' closestRcolor(rainbowJam(12), showPalette=TRUE);
#'
#' @export
closestRcolor <- function
(x,
colorSet=colors(),
C_min=Cgrey,
Cgrey=getOption("jam.Cgrey", 5),
showPalette=FALSE,
colorModel=c("hcl","LUV"),
Hwt=2.5,
Cwt=1,
Lwt=4,
warpHue=TRUE,
preset="ryb",
method="maximum",
returnType=c("color",
"name",
"match"),
verbose=FALSE,
...)
{
## Purpose is simply to name a color by its nearest colors from R colors()
##
## returnType == "color" will return the closest color from colorSet
## returnType == "name" will return the name of the closest color from colorSet
## returnType == "which" will return to closest match as an index integer
colorModel <- match.arg(colorModel);
returnType <- match.arg(returnType);
classX <- class(x);
if (classX %in% "data.frame") {
origXdf <- x;
origX <- as.vector(as.matrix(origXdf));
} else if (classX %in% "matrix") {
origXdf <- x;
origX <- as.vector(origXdf);
} else {
origX <- x;
}
if (length(names(origX)) == 0) {
names(origX) <- jamba::makeNames(origX);
}
if (length(C_min) == 0) {
C_min <- 0;
} else {
C_min <- head(C_min, 1);
}
colorSet_lo <- NULL;
if (C_min > 0) {
colorSet_hcl <- jamba::col2hcl(colorSet);
colorSet_hcl["C",] <- round(colorSet_hcl["C",],
digits=3)
colorSet_lo <- colorSet[colorSet_hcl["C",] < C_min];
colorSet <- colorSet[colorSet_hcl["C",] >= C_min];
}
if (returnType %in% "name" && length(names(colorSet)) == 0) {
names(colorSet) <- jamba::makeNames(colorSet);
}
x <- jamba::nameVector(unique(origX));
xHCL <- NULL;
newX <- NULL;
if (Cgrey > 0 && C_min > 0 && length(colorSet_lo) > 0) {
if (verbose) {
jamba::printDebug("closestRcolor(): ",
"processing low chroma colors.")
}
# convert to HCL
xHCL <- jamba::col2hcl(x);
is_lo <- (xHCL["C",] < Cgrey);
if (any(is_lo)) {
# process unsaturated colors
newX_lo <- closestRcolor(x=x[is_lo],
colorSet=colorSet_lo,
C_min=0,
Cgrey=0,
colorModel=colorModel,
Hwt=Hwt,
Cwt=Cwt,
Lwt=Lwt,
warpHue=warpHue,
preset=preset,
method=method,
returnType="color",
verbose=verbose,
...)
newX <- rep("", length(x));
newX[is_lo] <- newX_lo;
# names(newX)[is_lo] <- x[is_lo];
# process saturated colors
if (any(!is_lo)) {
newX_hi <- closestRcolor(
x=x[!is_lo],
colorSet=colorSet,
C_min=0,
Cgrey=0,
colorModel=colorModel,
Hwt=Hwt,
Cwt=Cwt,
Lwt=Lwt,
warpHue=warpHue,
preset=preset,
method=method,
returnType="color",
verbose=verbose,
...)
newX[!is_lo] <- newX_hi;
# names(newX)[!is_lo] <- names(newX_hi);
# names(newX)[!is_lo] <- x[!is_lo];
} else {
newX_hi <- NULL;
}
names(newX) <- x;
}
}
if (length(newX) == 0) {
if ("hcl" %in% colorModel) {
# hcl
# Simple angular distance
angDist <- function(a, b, ...){
x1 <- rep(a, length(b));
y1 <- rep(b, each=length(a));
diff1 <- abs(x1-y1);
diff1[diff1 > 180] <- 360 - diff1[diff1 > 180];
diff1;
matrix(diff1, ncol=length(b), nrow=length(a),
dimnames=list(names(a), names(b)));
}
if (length(xHCL) == 0) {
xHCL <- jamba::col2hcl(x);
}
colorSetHCL <- jamba::col2hcl(jamba::nameVector(colorSet));
## Adjust H to RYB
if (warpHue) {
xHCL["H",] <- h2hw(xHCL["H",],
preset=preset);
colorSetHCL["H",] <- h2hw(colorSetHCL["H",],
preset=preset);
}
Hdist <- angDist(a=xHCL["H",],
b=colorSetHCL["H",])/180*100;
CLm <- rbind(t(xHCL), t(colorSetHCL))[,c("L","C"),drop=FALSE];
CLm[,"C"] <- CLm[,"C"] * Cwt;
CLm[,"L"] <- CLm[,"L"] * Lwt;
CLdist <- as.matrix(dist(CLm,
method=method))[colnames(xHCL), colnames(colorSetHCL), drop=FALSE];
if (verbose) {
jamba::printDebug("dim(Hdist):", dim(Hdist));
jamba::printDebug("dim(CLdist):", dim(CLdist));
}
HCLdist <- Hdist * Hwt + CLdist;
iClosestColorWhich <- apply(HCLdist, 1, which.min);
newX <- jamba::nameVector(colorSet[iClosestColorWhich],
colnames(xHCL));
} else if ("LUV" %in% colorModel) {
## Use LUV
col2LUV <- function(a) {
if (length(names(a)) == 0) {
names(a) <- jamba::makeNames(a);
}
# convert color
colorspace::coords(as(colorspace::hex2RGB(
jamba::rgb2col(grDevices::col2rgb(a))), "LUV"));
}
xLUV <- col2LUV(x);
colorSetLUV <- col2LUV(colorSet);
LUVdist <- as.matrix(dist(rbind(xLUV,
colorSetLUV),
method=method))[rownames(xLUV), rownames(colorSetLUV), drop=FALSE];
iClosestColorWhich <- apply(LUVdist, 1, which.min);
newX <- jamba::nameVector(colorSet[iClosestColorWhich],
rownames(xLUV));
}
}
# 0.0.25.900 - names are not assigned from input
# instead are assigned from `colorSet`
retX <- newX[origX];
if (length(colorSet_lo) > 0) {
colorSet <- c(colorSet, colorSet_lo);
}
imatch <- match(retX, colorSet);
# print("head(imatch, 20):");print(head(imatch, 20));# debug
if (length(names(colorSet)) > 0) {
names(retX) <- jamba::makeNames(names(colorSet)[imatch]);
} else {
names(retX) <- NULL;
}
if ("match" %in% returnType) {
retX[] <- imatch;
} else if ("name" %in% returnType && length(names(colorSet)) > 0) {
retX[] <- names(colorSet)[imatch];
}
# if (length(names(origX)) > 0) {
# names(retX) <- names(origX);
# }
## Optionally display the palette before and after
if (showPalette) {
use_origX <- origX;
if (length(names(use_origX)) == 0) {
names(use_origX) <- origX;
}
use_retX <- retX;
if (length(names(use_retX)) == 0) {
names(use_retX) <- retX;
}
jamba::showColors(list(
original=use_origX,
returned=use_retX),
...);
}
## Return to data.frame or matrix form if needed
if (classX %in% c("data.frame", "matrix")) {
retX <- matrix(ncol=ncol(origXdf), retX, dimnames=dimnames(origXdf));
if (classX %in% c("data.frame")) {
retX <- as.data.frame(retX);
}
}
return(retX);
}
#' Assign colors to vector of group labels
#'
#' Assign colors to vector of group labels
#'
#' This function takes a character or factor vector as input, then
#' assigns categorical colors to each label using `colorFunc`, by
#' default `rainbowJam()`.
#'
#' If a previous set of colors has already been defined, the parameter
#' `colorSub` is intended to maintain that same set of colors. However,
#' all input values in `x` must be present in the `names(colorSub)`
#' otherwise all colors are reassigned.
#'
#' In future, this function will maintain a partial set of colors,
#' while assigning colors with maximum visible differences from the
#' existing colors.
#'
#' @param x character or factor vector representing group membership.
#' @param alpha numerical value indicating the alpha transparency to
#' apply to the output colors, scaled from 0 (fully transparent) to
#' 1 (no transparency).
#' @param colorFunc function whose first parameter is the number of
#' colors to return, and where `...` is passed for additional
#' parameters as needed. By default it uses `colorjam::rainbowJam()`.
#' @param colorSub optional named vector of colors, whose names must
#' match all entries in `x`. This vector is used to re-apply
#' colors which have already been assigned to the labels in `x`.
#' @param useGradient logical indicating whether to apply a light-to-dark
#' gradient to repeated colors, for example to distinguish multiple
#' replicates of a group.
#' @param sortFunc function to use when sorting character or numeric
#' input in `x`, by default `jamba::mixedSort()`. When input `x` is
#' a factor, the factor levels are maintained in the same order.
#' @param verbose logical indicating whether to print verbose output.
#' @param ... additional parameters are passed to `colorFunc`
#'
#' @family colorjam core
#' @family colorjam assignment
#'
#' @examples
#' abcde <- group2colors(letters[1:5]);
#' aabbccddee <- group2colors(rep(letters[1:5], each=2));
#' aaabbcccccdeeee <- group2colors(rep(letters[1:5], c(3,2,5,1,4)));
#' aaabbcccccdeeee2 <- group2colors(rep(letters[1:5], c(3,2,5,1,4)), useGradient=TRUE);
#'
#' jamba::showColors(list(abcde=abcde,
#' aabbccddee=aabbccddee,
#' aaabbcccccdeeee=aaabbcccccdeeee,
#' aaabbcccccdeeee2=aaabbcccccdeeee2));
#'
#' @export
group2colors <- function
(x,
alpha=1,
colorFunc=rainbowJam,
colorSub=NULL,
sortFunc=jamba::mixedSort,
useGradient=FALSE,
verbose=FALSE,
...)
{
## Purpose is to take a character vector input, and assign colors
## to each unique value.
## By default, it uses colorjam::rainbowJam(), however any function
## which return n number of colors will suffice, for example
##
if (length(sortFunc) == 0 || !is.function(sortFunc)) {
sortFunc <- c;
}
if (jamba::igrepHas("factor", class(x))) {
xLabels <- levels(x);
} else {
xLabels <- sortFunc(unique(x));
}
if (all(xLabels %in% names(colorSub))) {
xColors <- colorSub;
} else {
xColors <- jamba::nameVector(
colorFunc(length(xLabels),
...),
xLabels);
}
## Apply colors to the input data
xColorsNew <- xColors[match(as.character(x), names(xColors))];
if (useGradient) {
xColorsNew <- jamba::color2gradient(xColorsNew,
...);
}
if (length(names(x)) > 0) {
names(xColorsNew) <- names(x);
}
xColorsNew;
}
#' Convert numeric matrix to heatmap colors
#'
#' Convert numeric matrix to heatmap colors
#'
#' This function is intended as a rapid way of applying a color
#' gradient to columns of numeric values, where each column
#' has its own base color. It calls `jamba::getColorRamp()`
#' for each column, and when supplied with one color, it
#' creates a color gradient from `"grey95"` to the output
#' of `jamba::color2gradient()`.
#'
#' When `lens` is non-zero, the color gradient is warped in order
#' to intensify the color saturation across the numeric range.
#'
#' @param x numeric matrix. If there are no `colnames(x)` they will
#' be created using `jamba::makeNames(rep("x", ncol(x)))`.
#' @param colorV character vector of R colors, named by `colnames(x)`,
#' and recycled to `ncol(x)` if needed. If `colorV` is supplied as
#' a list, the list elements are mapped to `colnames(x)` in order.
#' @param defaultBaseColor character vector of R colors used as the default
#' base color, when `colorV` is supplied as a vector.
#' @param transformFunc function applied to numeric values before
#' the color gradient is mapped to numeric values. For example,
#' `transformFunc=function(i)-log10(i)` would map colors to P-value
#' using a `-log10(p)` transformation.
#' @param lens numeric value passed to `warpRamp()` to adjust the
#' distribution of colors along the numeric range.
#' @param shareLimit logical indicating whether one numeric limit `numLimit`
#' should be used to define the numeric range for color mapping.
#' @param numLimitFactor when `numLimit` is NULL, this factor is applied to
#' the maximum numeric value to determine the `numLimit`.
#' @param numLimit numeric value to define the maximum numeric value
#' above which all numeric values are mapped to the maximum color.
#' When set to `NULL` the `numLimitFactor` is used to define
#' the `numLimit`.
#' @param baseline numeric value to define the numeric baseline, used
#' when `divergent=FALSE`. Values are recycled to `ncol(x)` to be
#' applied to each column individually.
#' @param color_below_baseline color used when numeric value is
#' below the `baseline`. Values are recycled to `ncol(x)` to be
#' applied to each column individually. When `color_below_baseline`
#' is `NULL`, the first color in the color ramp is used for all
#' values below the baseline.
#' @param divergent logical indicating whether to apply colors to the numeric
#' range symmetric around zero.
#' @param rampN integer value to define the number of color breaks for
#' each color gradient.
#' @param trimRamp numeric vector with two values, used by
#' `jamba::getColorRamp()` to trim the intermediate color gradient before
#' creating the final color ramp with length `rampN`. For example,
#' by default `jamba::getColorRamp()` creates a color gradient with
#' 15 colorr, defined by argument `gradientN=15`, so the argument
#' `trimRamp=c(4,2)` will trim the first 4 colors and the last 2 colors
#' from the 15-color gradient, before generating the final color
#' gradient with length `rampN`. The `trimRamp` argument is especially
#' useful to remove the leading white color, or to trim the first
#' few colors to ensure the first color in the gradient is visibly
#' different from the background color defined by `defaultBaseColor`.
#' @param verbose logical indicating whether to print verbose output.
#' @param ... additional arguments are passed to `jamba::getColorRamp()`
#' for additional customization. These arguments are handled across
#' all columns, and not a column-by-column basis.
#'
#' @family colorjam assignment
#'
#' @examples
#' set.seed(123);
#' # generate a random numeric matrix
#' m1 <- matrix(ncol=12, rnorm(120));
#' m1n <- m1;
#' m1n[] <- format(round(abs(m1), digits=2), trim=TRUE);
#' jamba::imageByColors(
#' matrix2heatColors(abs(m1),
#' transformFunc=c,
#' divergent=FALSE,
#' lens=-5,
#' shareNumLimit=TRUE,
#' baseline=0,
#' numLimit=4),
#' cellnote=m1n);
#'
#' @export
matrix2heatColors <- function
(x,
colorV=group2colors(colnames(x)),
defaultBaseColor="#FFFFFF",
transformFunc=c,
lens=0,
shareLimit=TRUE,
numLimitFactor=0.95,
numLimit=NULL,
baseline=0,
color_below_baseline="#FFFFFF",
divergent=FALSE,
rampN=15,
trimRamp=c(0, 0),
verbose=FALSE,
...)
{
## Purpose is to create a color gradient from a numeric matrix
## intended for when each column should have its own distinct color
## usually a gradient from white to the specified color.
##
## This function calls vals2colorLevels() for each column.
##
## Make sure x has colnames
if (length(colnames(x)) == 0) {
colnames(x) <- jamba::makeNames(rep("x", ncol(x)));
}
xNames <- colnames(x);
## Define farbeLim if not provided
if (length(numLimit) == 0) {
if (shareLimit) {
## Shared max color value
numLimit <- max(jamba::rmNA(abs(transformFunc(x)))) * numLimitFactor;
if (verbose) {
jamba::printDebug("matrix2heatColors():",
"defined shared farbeLim value:",
format(digits=2, numLimit));
}
numLimit <- rep(numLimit, length.out=ncol(x));
} else {
numLimit <- sapply(1:ncol(x), function(i){
numLimit <- max(jamba::rmNA(abs(transformFunc(x)))) * numLimitFactor;
});
if (verbose) {
jamba::printDebug("matrix2heatColors():",
"defined individual numLimit values:",
format(digits=2, numLimit));
}
}
names(numLimit) <- xNames;
} else {
numLimit <- rep(numLimit, length.out=ncol(x));
if (verbose) {
jamba::printDebug("matrix2heatColors():",
"numLimit values as provided:",
format(digits=2, numLimit));
}
if (length(names(numLimit)) > 0 &&
all(names(numLimit) %in% xNames)) {
numLimit <- numLimit[xNames];
} else {
names(numLimit) <- xNames;
}
}
lens <- jamba::nameVector(rep(lens,
length.out=ncol(x)),
xNames);
defaultBaseColor <- jamba::nameVector(rep(defaultBaseColor,
length.out=ncol(x)),
xNames);
baseline <- jamba::nameVector(rep(baseline,
length.out=ncol(x)),
xNames);
color_below_baseline <- jamba::nameVector(rep(color_below_baseline,
length.out=ncol(x)),
xNames);
numLimit <- jamba::nameVector(rep(numLimit,
length.out=ncol(x)),
xNames);
rampN <- jamba::nameVector(rep(rampN,
length.out=ncol(x)),
xNames);
divergent <- jamba::nameVector(rep(divergent,
length.out=ncol(x)),
xNames);
colorV <- jamba::nameVector(rep(colorV,
length.out=ncol(x)),
xNames);
xColors <- do.call(cbind, lapply(jamba::nameVector(colnames(x)), function(i){
k <- (transformFunc(x[,i]));
if (verbose) {
jamba::printDebug("matrix2heatColors():", i,
", lens:", format(lens[i], digits=2),
", defaultBaseColor:", defaultBaseColor[i],
", baseline:", format(baseline[i], digits=2),
", numLimit:", format(numLimit[i], digits=2),
", colorRamp:", colorV[[i]],
fgText=list("orange", "lightblue",
"orange", "lightblue",
"orange", defaultBaseColor[i],
"orange", "lightblue",
"orange", "lightblue",
"orange", colorV[[i]]));
}
if (divergent[i]) {
## divergent color ramp
k <- jamba::noiseFloor(k,
minimum=-numLimit[i],
ceiling=numLimit[i]);
kRamp <- jamba::getColorRamp(colorV[[i]],
defaultBaseColor=defaultBaseColor[i],
lens=lens[i],
divergent=TRUE,
n=rampN[i],
trimRamp=trimRamp,
...);
if (verbose) {
jamba::printDebug("matrix2heatColors(): ",
"divergent:", divergent,
",\nkRamp:", kRamp,
fgText=list("orange", "dodgerblue", "orange",
"dodgerblue", kRamp));
}
kCut <- cut(k,
include.lowest=TRUE,
breaks=seq(from=-numLimit[i],
to=numLimit[i],
length.out=rampN[i]+1));
kColor <- kRamp[kCut];
} else {
## one-directional color ramp
k <- jamba::noiseFloor(k,
minimum=baseline[i],
newValue=baseline[i]-1,
ceiling=numLimit[i]);
kRamp <- jamba::getColorRamp(colorV[[i]],
defaultBaseColor=defaultBaseColor[i],
lens=lens[i],
divergent=FALSE,
n=rampN[i],
trimRamp=trimRamp,
...);
if (length(color_below_baseline[i]) == 0) {
kRamp <- c(kRamp[1], kRamp);
} else {
kRamp <- c(color_below_baseline[i], kRamp);
}
if (verbose) {
jamba::printDebug("matrix2heatColors(): ",
"divergent:", divergent[i],
",\nkRamp:", kRamp,
fgText=list("orange", "dodgerblue", "orange",
"dodgerblue", kRamp));
}
kCut <- cut(k,
include.lowest=TRUE,
breaks=c(baseline[i]-1,
seq(from=baseline[i],
to=numLimit[i],
length.out=rampN[i]+1)));
kColor <- kRamp[kCut];
}
kColor;
}));
rownames(xColors) <- rownames(x);
return(xColors);
}
#' Apply color gradient to numeric values
#'
#' Apply color gradient to numeric values
#'
#' This function is similar to several other existing R functions
#' that take a vector of numeric values, and apply a color gradient
#' (color ramp) to the numeric values. This function provides the ability
#' to warp the color ramp, for example using `jamba::warpRamp()` in order
#' to adjust the color gradient relative to the numeric range of the
#' data.
#'
#' Note that the function `col_div_xf()` and `col_linear_xf()` may
#' be preferable to this function. Those functions assign colors
#' to specific numeric values, instead of assigning colors between
#' numeric break points.
#'
#' @family colorjam assignment
#'
#' @param x numeric vector
#' @param divergent logical indicating whether the numeric values
#' are divergent, by default baseline=0 will center the color
#' ramp at zero.
#' @param col color value compatible with the `col` argument of
#' `jamba::getColorRamp()`. Example include: single color; multiple
#' colors; single color ramp name; or a custom color function.
#' @param defaultBaseColor character color used as a base color when
#' a single color is supplied in `col`.
#' @param lens numeric value sent to `jamba::warpRamp()`, to define the
#' level of color warping to apply to the color gradient, where `lens=0`
#' applies no adjustment.
#' @param numLimit numeric value indicating the maximum numeric value,
#' where values in `x` greater than this value are assigned to the
#' maximum color. When not defined, and `divergent=TRUE` it uses
#' `max(abs(x), na.rm=TRUE)`, or `divergent=FALSE` it uses
#' `max(x, na.rm=TRUE)`.
#' @param baseline numeric value indicating the minimum numeric value,
#' where values in `x` less than this value are assigned to the
#' minimum color. When not defined, and `divergent=TRUE` it sets
#' `baseline=0`; when `divergent=FALSE` it uses `min(x, na.rm=TRUE)`.
#' @param rampN integer number of colors to define for the color
#' gradient. Higher values define a smooth color gradient.
#' @param verbose logical indicating whether to print verbose output.
#' @param ... additional arguments are passed to `jamba::getColorRamp()`.
#'
#' @family jam color functions
#'
#' @examples
#' # Start with an example numeric vector
#' x <- jamba::nameVector(-5:10);
#' jamba::showColors(vals2colorLevels(x));
#'
#' # decrease the number of gradient colors
#' jamba::showColors(vals2colorLevels(x, rampN=15))
#'
#' # change the baseline
#' jamba::showColors(vals2colorLevels(x, baseline=-2));
#'
#' # adjust the gradient using lens
#' par("mar"=c(5,5,4,2));
#' jamba::imageByColors(jamba::rbindList(lapply(jamba::nameVector(c(-5,-2,0,2,5)), function(lens){
#' vals2colorLevels(x, rampN=25, lens=lens);
#' })));
#' title(ylab="color lens factor", xlab="numeric value",
#' main="Effects of warping the color gradient");
#'
#' @export
vals2colorLevels <- function
(x,
divergent=TRUE,
col="RdBu_r",
defaultBaseColor="#FFFFFF",
lens=0,
numLimit=NULL,
baseline=NULL,
rampN=25,
verbose=FALSE,
...)
{
## Purpose is to convert a numeric vector into a color gradient
if (length(divergent) == 0) {
divergent <- FALSE;
}
if (length(defaultBaseColor) == 0) {
defaultBaseColor <- "#FFFFFF";
}
if (length(lens) == 0) {
lens <- 0;
}
if (length(rampN) == 0) {
rampN <- 15;
}
if (length(col) == 0) {
if (divergent) {
col <- "RdBu_r";
} else {
col <- "Reds";
}
}
## If no baseline is provided, infer an appropriate one
if (length(baseline) == 0) {
if (divergent || min(x, na.rm=TRUE) == max(x, na.rm=TRUE)) {
baseline <- 0;
} else {
baseline <- min(x, na.rm=TRUE);
}
}
if (length(numLimit) == 0) {
if (divergent) {
numLimit <- max(abs(x-baseline)+baseline, na.rm=TRUE);
} else {
numLimit <- max(x, na.rm=TRUE);
}
## Correct issue when numLimit == baseline
if (numLimit == baseline) {
numLimit <- baseline + 1;
}
}
## Get the color ramp values
colorV <- jamba::getColorRamp(col=col,
n=rampN,
defaultBaseColor=defaultBaseColor,
verbose=verbose,
...);
## Optionally print verbose output
if (verbose) {
if (divergent) {
colorVnames <- rep(seq(from=1, to=floor(length(colorV)/2)), each=2)*c(-1,1);
if (length(colorV) %% 2) {
colorVnames <- sort(c(0, colorVnames));
}
} else {
colorVnames <- seq_along(colorV);
}
jamba::printDebug("vals2colorLevels(): ",
"colorV:\n",
format(colorVnames),
sep=", ",
Lrange=c(10,95), Crange=c(40,95),
fgText=list("orange", "dodgerblue", colorV));
}
## Optionally warp the color ramp
if (lens != 0) {
colorV <- jamba::warpRamp(colorV,
divergent=TRUE,
lens=lens,
...);
if (verbose) {
jamba::printDebug("vals2colorLevels(): ",
"colorV (lens):\n",
format(colorVnames),
sep=", ",
Lrange=c(10,95), Crange=c(40,95),
fgText=list("orange", "dodgerblue", colorV));
}
}
## Apply the color gradient
if (divergent) {
## divergent color ramp
k <- jamba::noiseFloor(x,
minimum=baseline-numLimit,
ceiling=numLimit);
kBreaks <- seq(from=2*baseline-numLimit,
to=numLimit,
length.out=rampN+1);
} else {
## one-directional color ramp
k <- jamba::noiseFloor(x,
minimum=baseline,
ceiling=numLimit);
kBreaks <- seq(from=baseline,
to=numLimit,
length.out=rampN+1);
}
if (verbose) {
colorVbreaks <- c(head(colorV, ceiling(length(colorV)/2)),
tail(colorV, ceiling(length(colorV)/2)));
jamba::printDebug("vals2colorLevels(): ",
"kBreaks:\n",
format(round(digits=1, kBreaks)),
sep=", ",
Lrange=c(10,95), Crange=c(40,95),
fgText=list("orange", "dodgerblue", colorVbreaks));
}
kCut <- cut(k,
include.lowest=TRUE,
breaks=kBreaks);
kColor <- unname(colorV[as.numeric(kCut)]);
if (length(names(x)) > 0) {
names(kColor) <- names(x);
}
kColor;
}
#' Closest colorjam named_colors
#'
#' Closest colorjam named_colors for a vector of colors
#'
#' @family colorjam core
#'
#' @inheritParams closestRcolor
#'
#' @param colorSet `character` vector of colors, by default `named_colors`
#' with provides 4,447 total hex colors, each with human-assigned
#' color name. These colors also include hex colors from R `colors()`
#' which were not already included in the reference colors.
#'
#' @export
closest_named_color <- function
(x,
colorSet=named_colors,
C_min=Cgrey,
Cgrey=getOption("jam.Cgrey", 5),
showPalette=FALSE,
colorModel=c("hcl", "LUV"),
Hwt=2.5,
Cwt=1,
Lwt=4,
warpHue=TRUE,
preset="ryb",
method="maximum",
returnType=c("color",
"name",
"match"),
verbose=FALSE,
...)
{
#
closestRcolor(x=x,
colorSet=colorSet,
C_min=C_min,
Cgrey=Cgrey,
showPalette=showPalette,
colorModel=colorModel,
Hwt=Hwt,
Cwt=Cwt,
Lwt=Lwt,
warpHue=warpHue,
preset=preset,
method=method,
returnType=returnType,
verbose=verbose,
...);
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.