72 lines
2.5 KiB
R
72 lines
2.5 KiB
R
|
## [Bug 18476] alpha handling in palette functions (23 Feb 2023)
|
||
|
|
## https://bugs.r-project.org/show_bug.cgi?id=18476
|
||
|
|
## Attachment 3131 https://bugs.r-project.org/attachment.cgi?id=3131
|
||
|
|
## and comment #3 by Achim Zeileis
|
||
|
|
|
||
|
|
|
||
|
|
## from attachment #3131 :
|
||
|
|
check_alpha <- function(colors = "topo.colors", ncolor = 3, nalpha = 3, ...) {
|
||
|
|
## alpha sequence of length nalpha
|
||
|
|
alpha <- seq(0, 1, length.out = nalpha)
|
||
|
|
|
||
|
|
## generate colors with alpha=...
|
||
|
|
col1 <- tryCatch(do.call(colors, c(list(n = ncolor, alpha = alpha), list(...))),
|
||
|
|
error = identity)
|
||
|
|
if(inherits(col1, "error")) return(FALSE)
|
||
|
|
|
||
|
|
## generate colors without alpha= and add manually afterwards
|
||
|
|
alpha <- format(as.hexmode(round(alpha * 255 + 0.0001)), width = 2L, upper.case = TRUE)
|
||
|
|
col2 <- paste0(do.call(colors, c(list(n = ncolor), list(...))),
|
||
|
|
rep_len(alpha, ncolor))
|
||
|
|
|
||
|
|
## check whether both strategies yield identical output
|
||
|
|
identical(col1, col2)
|
||
|
|
}
|
||
|
|
|
||
|
|
expndGrid <- function(...)
|
||
|
|
expand.grid(..., KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)
|
||
|
|
|
||
|
|
iSamp <- function(n, f=1/4, nS = max(min(n, 24L), f*n), full = interactive())
|
||
|
|
if(full) seq_len(n) else sample.int(n, nS)
|
||
|
|
|
||
|
|
chkALLalpha <- function(d)
|
||
|
|
vapply(iSamp(nrow(d)), function(i) do.call(check_alpha, d[i,]), NA)
|
||
|
|
|
||
|
|
## Check old palettes ------------------
|
||
|
|
d1 <- expndGrid(colors = c("rainbow", "topo.colors", "terrain.colors",
|
||
|
|
"heat.colors", "cm.colors", "gray.colors"),
|
||
|
|
ncolor = c(1, 3, 9, 100),
|
||
|
|
nalpha = c(2, 3, 9, 100))
|
||
|
|
table(L <- chkALLalpha(d1)) ## R-4.2.x: 71 FALSE, 25 TRUE -- now 96 TRUE
|
||
|
|
if(!all(L)) stop("---> not all ok")
|
||
|
|
|
||
|
|
|
||
|
|
## Check the new palettes -----------------
|
||
|
|
|
||
|
|
d2 <- expndGrid(colors = "palette.colors",
|
||
|
|
ncolor = c(1, 3, 7),
|
||
|
|
nalpha = c(2, 3, 7),
|
||
|
|
palette = print(palette.pals()))
|
||
|
|
table(L <- chkALLalpha(d2)) ## R-4.2.x: 64 FALSE, 80 TRUE -- now 144 TRUE
|
||
|
|
if(!all(L)) stop("---> not all ok")
|
||
|
|
|
||
|
|
d3 <- expndGrid(colors = "hcl.colors",
|
||
|
|
ncolor = c(1, 3, 9, 100),
|
||
|
|
nalpha = c(2, 3, 9, 100),
|
||
|
|
palette = print(hcl.pals()))
|
||
|
|
table(L <- chkALLalpha(d3)) ## R-4.2.x: 1057 FALSE, 783 TRUE -- now 1840 TRUE
|
||
|
|
if(!all(L)) stop("---> not all ok")
|
||
|
|
|
||
|
|
## Regr.test for PR#18523:
|
||
|
|
stopifnot(identical(c("#002E60", "#3E2000"),
|
||
|
|
hcl.colors(2, "Vik")))
|
||
|
|
|
||
|
|
div.pals <- hcl.pals(type="diverging")
|
||
|
|
divXpals <- hcl.pals(type="divergingx")
|
||
|
|
for(p in c(div.pals, divXpals)) {
|
||
|
|
c2 <- hcl.colors(2, p)
|
||
|
|
c3 <- hcl.colors(3, p)
|
||
|
|
stopifnot(length(setdiff(c3,c2)) == 1L)
|
||
|
|
## cat(p,": "); print(c2)
|
||
|
|
}
|