1#' Palette Plot in HCL Space 2#' 3#' Visualization of color palettes in HCL space projections. 4#' 5#' The function \code{hclplot} is an auxiliary function for illustrating 6#' the trajectories of color palettes in two-dimensional HCL space projections. 7#' It collapses over one of the three coordinates (either the hue H or the 8#' luminance L) and displays a heatmap of colors combining the remaining 9#' two dimensions. The coordinates for the given color palette are highlighted 10#' to bring out its trajectory. 11#' 12#' The function \code{hclplot} has been designed to work well with the 13#' \code{\link{hcl_palettes}} in this package. While it is possible to apply 14#' it to other color palettes as well, the results might look weird or confusing 15#' if these palettes are constructed very differently (e.g., as in the highly 16#' saturated base R palettes). 17#' 18#' More specifically, the following palettes can be visualized well: \itemize{ 19#' \item Qualitative with (approximately) constant luminance. In this case, 20#' \code{hclplot} shows a hue-chroma plane (in polar coordinates), keeping 21#' luminance at a fixed level (by default displayed in the main title of 22#' the plot). If the luminance is, in fact, not approximately constant, 23#' the luminance varies along with hue and chroma, using a simple linear 24#' function (fitted by least squares). 25# \item Sequential with (approximately) constant hue. In this case, 26#' \code{hclplot} shows a chroma-luminance plane, keeping hue at a fixed 27#' level (by default displayed in the main title of the plot). If the hue 28#' is, in fact, not approximately constant, the hue varies along with 29#' chroma and luminance, using a simple linear function (fitted by least 30#' squares. 31#' \item Diverging with two (approximately) constant hues: This case is 32#' visualized with two back-to-back sequential displays. 33#' } 34#' To infer the type of display to use, by default, the following heuristic is 35#' used: If luminance is not approximately constant (range > 10) and follows 36#' rougly a triangular pattern, a diverging display is used. If luminance is 37#' not constant and follows roughly a linear pattern, a sequential display is 38#' used. Otherwise a qualitative display is used. 39#' 40#' @param x character vector containing color hex codes, or a \code{\link{color-class}} 41#' object. 42#' @param type type character specifying which type of palette should be visualized 43#' (\code{"qualitative"}, \code{"sequential"}, or \code{"diverging"}). 44#' For qualitative palettes a hue-chroma plane is used, otherwise a chroma-luminance plane. 45#' By default, the \code{type} is inferred from the luminance trajectory corresponding 46#' to \code{x}. 47#' @param h numeric hue(s) to be used for \code{type = "sequential"} and \code{type = "diverging"}. 48#' By default, these are inferred from the colors in \code{x}. 49#' @param c numeric. Maximal chroma value to be used. 50#' @param l numeric luminance(s) to be used for \code{type = "qualitative"}. 51#' By default, this is inferred from the colors in \code{x}. 52#' @param xlab,ylab,main character strings for annotation, by default generated from 53#' the type of color palette visualized. 54#' @param cex numeric character extension. 55#' @param axes logical. Should axes be drawn? 56#' @param bg,lwd,size graphical control parameters for the color palette trajectory. 57#' @param \dots currently not used. 58#' 59#' @return \code{hclplot} invisibly returns a matrix with the HCL coordinates corresponding to \code{x}. 60#' @seealso \code{\link{specplot}} 61#' @references Zeileis A, Fisher JC, Hornik K, Ihaka R, McWhite CD, Murrell P, Stauffer R, Wilke CO (2020). 62#' \dQuote{colorspace: A Toolbox for Manipulating and Assessing Colors and Palettes.} 63#' \emph{Journal of Statistical Software}, \bold{96}(1), 1--49. \doi{10.18637/jss.v096.i01} 64#' @keywords hplot 65#' @examples 66#' ## for qualitative palettes luminance and chroma are fixed, varying only hue 67#' hclplot(qualitative_hcl(9, c = 50, l = 70)) 68#' 69#' ## single-hue sequential palette (h = 260) with linear vs. power-transformed trajectory 70#' hclplot(sequential_hcl(7, h = 260, c = 80, l = c(35, 95), power = 1)) 71#' hclplot(sequential_hcl(7, h = 260, c = 80, l = c(35, 95), power = 1.5)) 72#' 73#' ## advanced single-hue sequential palette with triangular chroma trajectory 74#' ## (piecewise linear vs. power-transformed) 75#' hclplot(sequential_hcl(7, h = 245, c = c(40, 75, 0), l = c(30, 95), power = 1)) 76#' hclplot(sequential_hcl(7, h = 245, c = c(40, 75, 0), l = c(30, 95), power = c(0.8, 1.4))) 77#' 78#' ## multi-hue sequential palette with small hue range and triangular chroma vs. 79#' ## large hue range and linear chroma trajectory 80#' hclplot(sequential_hcl(7, h = c(260, 220), c = c(50, 75, 0), l = c(30, 95), power = 1)) 81#' hclplot(sequential_hcl(7, h = c(260, 60), c = 60, l = c(40, 95), power = 1)) 82#' 83#' ## balanced diverging palette constructed from two simple single-hue sequential 84#' ## palettes (for hues 260/blue and 0/red) 85#' hclplot(diverging_hcl(7, h = c(260, 0), c = 80, l = c(35, 95), power = 1)) 86#' 87#' @export hclplot 88#' @importFrom graphics box lines mtext par plot points rect text 89#' @importFrom stats cor lm median predict 90hclplot <- function(x, type = NULL, h = NULL, c = NULL, l = NULL, 91 xlab = NULL, ylab = NULL, main = NULL, cex = 1.0, axes = TRUE, 92 bg = "white", lwd = 1, size = 2.5, ...) 93{ 94 95 ## TODO: Not yet able to handle NA values. Thus, replace 96 ## NA values with white, if needed. 97 NAidx <- which(is.na(x)); if (length(NAidx) > 0) x[NAidx] <- "#FFFFFF" 98 ## convert to HCL coordinates 99 if(is.character(x)) { 100 HCL <- hex2RGB(x) 101 } else { 102 HCL <- x 103 x <- hex(x) 104 } 105 HCL <- coords(as(HCL, "polarLUV"))[, c("H", "C", "L")] 106 n <- nrow(HCL) 107 108 ## determine type of palette based on luminance trajectory 109 lran <- diff(range(HCL[, "L"], na.rm = TRUE)) 110 llin <- cor(HCL[, "L"], 1L:n, use = "pairwise.complete.obs")^2 111 ltri <- cor(HCL[, "L"], abs(1L:n - (n + 1)/2), use = "pairwise.complete.obs")^2 112 if(is.null(type)) { 113 type <- if(ltri > 0.75 & lran > 10) { 114 "diverging" 115 } else if(llin > 0.75 & lran > 10) { 116 "sequential" 117 } else { 118 "qualitative" 119 } 120 } else { 121 type <- match.arg(type, c("diverging", "sequential", "qualitative")) 122 } 123 124 ## FIXME: put into separate function 125 if(n > 1L) { 126 for(i in 2L:n) { 127 if ( any(is.na(HCL[(i-1L):i,])) ) next 128 d <- HCL[i, "H"] - HCL[i - 1L, "H"] 129 if (abs(d) > 320) HCL[i, "H"] <- HCL[i, "H"] - sign(d) * 360 130 if (abs(HCL[i, "H"]) > 360) HCL[1L:i, "H"] <- HCL[1L:i, "H"] - sign(HCL[i, "H"]) * 360 131 } 132 133 # (2) Smoothing hue values in batches where chroma is very low 134 idx <- which(HCL[, "C"] < 8) 135 if (length(idx) == n) { 136 HCL[,"H"] <- mean(HCL[,"H"]) 137 } else if (length(idx) > 0L) { 138 ## pre-smooth hue 139 if(n >= 49L) { 140 HCL[, "H"] <- 1/3 * ( 141 HCL[c(rep.int(1L, 2L), 1L:(n - 2L)), "H"] + 142 HCL[c(rep.int(1L, 1L), 1L:(n - 1L)), "H"] + 143 HCL[ 1L:n, "H"]) 144 } 145 idxs <- split(idx, cumsum(c(1, diff(idx)) > 1)) 146 s <- 1L 147 while(length(idxs) > 0L) { 148 e <- if(s %in% idxs[[1L]]) { 149 if(length(idxs) > 1L) idxs[[2L]] - 1L else n 150 } else { 151 if(n %in% idxs[[1L]]) n else round(mean(range(idxs[[1L]]))) 152 } 153 io <- split(s:e, s:e %in% idx) 154 if (length(io) == 2L & sum(!is.na(HCL[io[["FALSE"]],"H"])) > 0) { 155 HCL[io[["TRUE"]], "H"] <- stats::spline(io[["FALSE"]], HCL[io[["FALSE"]], "H"], 156 xout = io[["TRUE"]], method = "natural")$y 157 } 158 idxs[[1L]] <- NULL 159 s <- e + 1L 160 } 161 } 162 } 163 164 maxchroma <- if(!is.null(c)) ceiling(c) else pmax(100, pmin(180, ceiling(max(HCL[, "C"], na.rm = TRUE)/20) * 20)) 165 166 switch(type, 167 "sequential" = { 168 opar <- par(cex = cex, mar = c(3, 3, 2, 1) * cex, no.readonly = TRUE) 169 on.exit(par(opar)) 170 nd <- expand.grid(C = 0:maxchroma, L = 0:100) 171 if(!is.null(h)) { 172 nd$H <- h 173 } else if(n < 3L || diff(range(HCL[, "H"], na.rm = TRUE)) < 12) { 174 nd$H <- median(HCL[, "H"], na.rm = TRUE) 175 } else { 176 m <- lm(H ~ C + L, data = as.data.frame(HCL)) 177 sig <- summary(m)$sigma 178 if(is.na(sig) || sig > 7.5) warning("cannot approximate H well as a linear function of C and L") 179 nd$H <- predict(m, nd) 180 } 181 if(is.null(main)) { 182 main <- if(length(unique(nd$H)) <= 1L) { 183 round(nd$H[1L]) 184 } else { 185 paste("[", round(min(nd$H, na.rm = TRUE)), ", ", round(max(nd$H, na.rm = TRUE)), "]", sep = "") 186 } 187 main <- paste("Hue =", main) 188 } 189 HCL2 <- hex(polarLUV(H = nd$H, C = nd$C, L = nd$L), fixup = FALSE) 190 HCL2[nd$L < 1 & nd$C > 0] <- NA 191 plot(0, 0, type = "n", xlim = c(0, maxchroma), ylim = c(0, 100), xaxs = "i", yaxs = "i", 192 xlab = NA, ylab = NA, main = main, axes = axes) 193 # Adding axis labels 194 if(axes) { 195 if ( is.null(xlab) ) xlab <- "Chroma" 196 if ( is.null(ylab) ) ylab <- "Luminance" 197 mtext(side = 1, line = 2 * cex, xlab, cex = cex) 198 mtext(side = 2, line = 2 * cex, ylab, cex = cex) 199 } 200 # Adding colors 201 points(nd$C, nd$L, col = HCL2, pch = 19, cex = 3) 202 points(HCL[, 2L:3L], pch = 19, cex = 1.1 * size * cex, type = "p", lwd = 5 * lwd, col = bg) 203 points(HCL[, 2L:3L], pch = 21, bg = x, cex = size * cex, type = "o", lwd = lwd) 204 box() 205 }, 206 "diverging" = { 207 opar <- par(cex = cex, mar = c(3, 3, 2, 1) * cex, no.readonly = TRUE) 208 on.exit(par(opar)) 209 nd <- expand.grid(C = -maxchroma:maxchroma, L = 0:100) 210 nd$H <- NA 211 nd$left <- nd$C < 0 212 left <- 1L:floor(n/2) 213 left <- left[HCL[left, "C"] > 10] 214 right <- ceiling(n/2):n 215 right <- right[HCL[right, "C"] > 10] 216 217 if(!is.null(h)) { 218 if(length(h) == 2L) { 219 nd$H[nd$left] <- h[1L] 220 nd$H[!nd$left] <- h[2L] 221 } else { 222 nd$H <- h 223 } 224 } else if(n < 6L || (diff(range(HCL[left, "H"] - min(HCL[ left, "H"], na.rm = TRUE), na.rm = TRUE)) < 12 & 225 diff(range(HCL[right, "H"] - min(HCL[right, "H"], na.rm = TRUE), na.rm = TRUE)) < 12)) { 226 nd$H[nd$left] <- median(HCL[ left, "H"] - min(HCL[ left, "H"], na.rm = TRUE), na.rm = TRUE) + min(HCL[ left, "H"], na.rm = TRUE) 227 nd$H[!nd$left] <- median(HCL[right, "H"] - min(HCL[right, "H"], na.rm = TRUE), na.rm = TRUE) + min(HCL[right, "H"], na.rm = TRUE) 228 } else { 229 HCLdata <- as.data.frame(HCL) 230 HCLdata$left <- factor(rep(c(TRUE, FALSE), c(floor(n/2), ceiling(n/2)))) 231 nd$left <- factor(nd$left) 232 m <- lm(H ~ left * (C + L), data = HCLdata) 233 sig <- summary(m)$sigma 234 if(is.na(sig) || sig > 7.5) warning("cannot approximate H well as a linear function of C and L") 235 nd$H <- predict(m, nd) 236 nd$left <- nd$left == "TRUE" 237 } 238 if(is.null(main)) { 239 main <- if(length(unique(nd$H)) <= 2L) { 240 paste(round(nd$H[nd$left][1L]), "/", round(nd$H[!nd$left][1L])) 241 } else { 242 paste("[", 243 round(min(nd$H[nd$left], na.rm = TRUE)), ", ", round(max(nd$H[nd$left], na.rm = TRUE)), "] / [", 244 round(min(nd$H[!nd$left], na.rm = TRUE)), ", ", round(max(nd$H[!nd$left], na.rm = TRUE)), "]", sep = "") 245 } 246 main <- paste("Hue =", main) 247 } 248 HCL2 <- hex(polarLUV(H = nd$H, C = abs(nd$C), L = nd$L), fixup = FALSE) 249 HCL2[nd$L < 1 & abs(nd$C) > 0] <- NA 250 plot(0, 0, type = "n", xlim = c(-1, 1) * maxchroma, ylim = c(0, 100), xaxs = "i", yaxs = "i", 251 xlab = NA, ylab = NA, main = main, axes = FALSE) 252 # Axis labels 253 if(axes) { 254 if ( is.null(xlab) ) xlab <- "Chroma" 255 if ( is.null(ylab) ) ylab <- "Luminance" 256 mtext(side = 1, line = 2 * cex, xlab, cex = cex) 257 mtext(side = 2, line = 2 * cex, ylab, cex = cex) 258 at1 <- pretty(c(-1, 1) * maxchroma) 259 axis(1, at = at1, labels = abs(at1)) 260 axis(2) 261 } 262 # Plotting colors 263 points(nd$C, nd$L, col = HCL2, pch = 19, cex = 3) 264 points( HCL[, "C"] * ifelse(1L:n <= floor(mean(n/2)), -1, 1), 265 HCL[, "L"], pch = 19, cex = 1.1 * size * cex, type = "p", lwd = 5 * lwd, col = bg) 266 points( HCL[, "C"] * ifelse(1L:n <= floor(mean(n/2)),-1,1), 267 HCL[, "L"], pch = 21, bg = x, cex = size * cex, type = "o", lwd = lwd) 268 box() 269 }, 270 "qualitative" = { 271 opar <- par(cex = cex, mar = c(1, 1, 2, 1) * cex, bty = "n", no.readonly = TRUE) 272 on.exit(par(opar)) 273 nd <- expand.grid(H = 0:180 * 2, C = 0:maxchroma) 274 275 if(!is.null(l)) { 276 nd$L <- l 277 } else if(n < 3L || diff(range(HCL[, "L"], na.rm = TRUE)) < 10) { 278 nd$L <- median(HCL[, "L"], na.rm = TRUE) 279 } else { 280 m <- lm(L ~ C + H, data = as.data.frame(HCL)) 281 sig <- summary(m)$sigma 282 if(is.na(sig) || sig > 7.5) warning("cannot approximate L well as a linear function of H and C") 283 nd$L <- predict(m, nd) 284 nd$L <- pmin(100, pmax(0, nd$L)) 285 } 286 if(is.null(main)) { 287 main <- if(length(unique(nd$L)) <= 1L) { 288 round(nd$L[1L]) 289 } else { 290 paste("[", round(min(nd$L, na.rm = TRUE)), ", ", round(max(nd$L, na.rm = TRUE)), "]", sep = "") 291 } 292 main <- paste("Luminance =", main) 293 } 294 HCL2 <- hex(polarLUV(H = nd$H, C = nd$C, L = nd$L), fixup = FALSE) 295 HCL2[nd$L < 1 & nd$C > 0] <- NA 296 297 # fact: used for scaling 298 fact <- 1.1 + (cex - 1) / 10 299 plot(0, 0, type = "n", axes = FALSE, xlab = NA, ylab = NA, main = main, 300 xlim = c(-maxchroma, maxchroma) * fact, ylim = c(-maxchroma, maxchroma) * fact, asp = 1) 301 xpos <- function(h, c) cos(h * pi/180) * c 302 ypos <- function(h, c) sin(h * pi/180) * c 303 points(xpos(nd$H, nd$C), ypos(nd$H, nd$C), col = HCL2, pch = 19, cex = 3) 304 lines(xpos(0:360, maxchroma), ypos(0:360, maxchroma)) 305 306 if(axes) { 307 if(is.null(xlab)) xlab <- "Chroma" 308 if(is.null(ylab)) ylab <- "Hue" 309 at.c <- if(maxchroma >= 150) 0:3 * 50 else 0:3 * 25 310 at.h <- 0:6 * 60 311 lines(c(0, maxchroma), c(0, 0)) 312 text(at.c, rep(-7, length(at.c)), at.c) 313 text(50, -14, xlab) 314 rect(at.c, 0, at.c, -3) 315 if(0 %in% at.h | 360 %in% at.h) { 316 lines(xpos(0, maxchroma + c(0, 3)), ypos(0, maxchroma + c(0, 3))) 317 text(xpos(0, maxchroma + 7), ypos(0, maxchroma + 7), 0, pos = 3) 318 text(xpos(0, maxchroma + 7), ypos(0, maxchroma + 7), 360, pos = 1) 319 text(xpos(0, maxchroma + 16), ypos(0, maxchroma + 16), ylab) 320 } 321 at.h <- at.h[at.h > 0 & at.h < 360] 322 for(hue in at.h) { 323 text(xpos(hue, maxchroma + 7), ypos(hue, maxchroma + 7), hue) 324 lines(xpos(hue, maxchroma + c(0, 3)), ypos(hue, maxchroma + c(0, 3))) 325 } 326 } 327 points(xpos(HCL[, "H"], HCL[, "C"]), ypos(HCL[, "H"], HCL[, "C"]), 328 pch = 19, cex = 1.1 * size * cex, type = "p", lwd = 5 * lwd, col = bg) 329 points(xpos(HCL[, "H"], HCL[, "C"]), ypos(HCL[, "H"], HCL[, "C"]), 330 pch = 21, bg = x, cex = size * cex, type = "o", lwd = lwd) 331 box() 332 } 333 ) 334 335 invisible(HCL) 336} 337