1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
#' Desaturate Colors by Chroma Removal in HCL Space
#'
#' Transform a vector of given colors to the corresponding colors with chroma
#' reduced (by a tunable amount) in HCL space.
#'
#' If input \code{col} is a vector given colors are first transformed to RGB
#' (either using \code{\link[colorspace]{hex2RGB}} or
#' \code{\link[grDevices]{col2rgb}}) and then to HCL
#' (\code{\link[colorspace]{polarLUV}}). In HCL, chroma is reduced
#' and then the color is transformed back to a hexadecimal
#' string.
#'
#' If input \code{col} is a matrix with three rows named \code{R}, \code{G}, and
#' \code{B} (top down) they are interpreted as Red-Green-Blue values within the
#' range \code{[0-255]}. The desaturation takes place in the HCL space as well.
#' Instead of an (s)RGB color vector a matrix of the same size as the input
#' \code{col} with desaturated Red-Green-Blue values will be returned.
#' This can be handy to avoid too many conversions.
#'
#' Similarly, \code{col} can be a formal \code{\link[colorspace]{color-class}} object, in which
#' case the desaturated colors are returned as a formal object of the same class as the input.
#'
#' @param col vector of R colors. Can be any of the three kinds of R colors,
#' i.e., either a color name (an element of \code{\link[grDevices]{colors}}), a hexadecimal (hex)
#' string of the form \code{"#rrggbb"} or \code{"#rrggbbaa"} (see
#' \code{\link[grDevices]{rgb}}), or an integer \code{i} meaning
#' \code{palette()[i]}. Additionally, \code{col} can be
#' a formal \code{\link[colorspace]{color-class}} object or a matrix with three named
#' rows (or columns) containing R/G/B (0-255) values.
#' @param amount numeric specifying the amount of desaturation where \code{1}
#' corresponds to complete desaturation, \code{0} to no desaturation, and
#' values in between to partial desaturation.
#' @param ... additional arguments. If \code{severity} is specified it will
#' overrule the input argument \code{amount} (for convenience).
#' @return A color object as specified in the input \code{col} (hexadecimal string, RGB matrix,
#' or formal color class) with desaturated colors.
#' @seealso \code{\link[colorspace]{polarLUV}}, \code{\link[colorspace]{hex}}, \code{\link[colorspace]{lighten}}
#' @references Zeileis A, Fisher JC, Hornik K, Ihaka R, McWhite CD, Murrell P, Stauffer R, Wilke CO (2020).
#' \dQuote{colorspace: A Toolbox for Manipulating and Assessing Colors and Palettes.}
#' \emph{Journal of Statistical Software}, \bold{96}(1), 1--49. \doi{10.18637/jss.v096.i01}
#' @keywords color
#' @examples
#' ## rainbow of colors and their desaturated counterparts
#' rainbow_hcl(12)
#' desaturate(rainbow_hcl(12))
#'
#' ## convenience demo function
#' wheel <- function(col, radius = 1, ...)
#' pie(rep(1, length(col)), col = col, radius = radius, ...)
#'
#' ## compare base and colorspace palettes
#' ## (in color and desaturated)
#' par(mar = rep(0, 4), mfrow = c(2, 2))
#' ## rainbow color wheel
#' wheel(rainbow_hcl(12))
#' wheel(rainbow(12))
#' wheel(desaturate(rainbow_hcl(12)))
#' wheel(desaturate(rainbow(12)))
#'
#' ## apply desaturation directly on wide RGB matrix (with R/G/B channels in rows)
#' RGB <- diag(3) * 255
#' rownames(RGB) <- c("R", "G", "B")
#' desaturate(RGB)
#' @export desaturate
#' @importFrom grDevices col2rgb
#' @importFrom stats setNames
desaturate <- function(col, amount = 1, ...) {
## convenience: interpret 'severity' argument in dots as 'amount'
args <- as.list(match.call(expand.dots = TRUE))
if (!is.null(args$severity)) amount <- args$severity
## determine input type
input_type <- if (inherits(col, "color")) {
## S4 colorspace class
"colorspace"
} else if (is.matrix(col)) {
## named RGB matrix (0-255)
"matrix"
} else if (is.character(col) && (all(substr(col, 1L, 1L) == "#") & all(nchar(col) %in% c(7L, 9L)))) {
## all hex
"hex"
} else {
## assume built-in colors
"other"
}
## convert input to color object (typically sRGB)
if (input_type == "colorspace") {
color_class <- class(col)
} else if (input_type == "matrix") {
if (NROW(col) != 3L && NCOL(col) == 3L && all(toupper(colnames(col)) == c("R", "G", "B"))) {
col <- t(col)
transpose <- FALSE
} else {
transpose <- TRUE
}
stopifnot(all(toupper(rownames(col)) == c("R", "G", "B")))
col <- sRGB(t(col[1L:3L, ])/255)
} else if (input_type == "hex") {
# keep indices of NA colors
NAidx <- which(is.na(col))
## extract alpha (if any) and convert RGB to colorspace::sRGB
alpha <- substr(col, 8L, 9L)
col <- hex2RGB(setNames(substr(col, 1L, 7L), names(col)))
} else {
# keep indices of NA colors
NAidx <- which(is.na(col))
col <- grDevices::col2rgb(col, alpha = TRUE)
## extract alpha values (if non-FF)
alpha <- format(as.hexmode(col[4L, ]), width = 2L, upper.case = TRUE)
alpha[alpha == "FF"] <- ""
## retain only RGB
col <- sRGB(t(col[1L:3L, ])/255)
}
## convert to HCL and decrease chroma
col <- as(col, "polarLUV")
col@coords[, 2L] <- (1 - amount) * col@coords[, 2L]
## fix-up extreme luminance cases
col@coords[col@coords[, 1L] <= 0 | col@coords[, 1L] >= 100, 2L:3L] <- 0
## convert back to input type
if (input_type == "colorspace") {
## convert back to original class
col <- as(col, color_class)
} else if (input_type == "matrix") {
## convert back to matrix (either long or wide)
RGB <- as(col, "sRGB")@coords * 255
col <- if (transpose) t(RGB) else RGB
} else {
## convert back to hex and add alpha again (if any)
col <- hex(col)
col[] <- paste0(col[], alpha)
if (length(NAidx) > 0L) col[NAidx] <- NA
}
return(col)
}
|
