.hcl_colors_parameters <- as.data.frame(rbind(structure(numeric(0L), dim = c(0L, 16L), dimnames = list(NULL, c("type", "h1", "h2", "h3", "c1", "c2", "c3", "l1", "l2", "l3", "p1", "p2", "p3", "p4", "cmax1", "cmax2"))), ## 1 : qualitative "Pastel 1" = c( 1, 0, NA, NA, 35, NA, NA, 85, NA, NA, NA, NA, NA, NA, NA, NA), "Dark 2" = c( 1, 0, NA, NA, 50, NA, NA, 60, NA, NA, NA, NA, NA, NA, NA, NA), "Dark 3" = c( 1, 0, NA, NA, 80, NA, NA, 60, NA, NA, NA, NA, NA, NA, NA, NA), "Set 2" = c( 1, 0, NA, NA, 60, NA, NA, 70, NA, NA, NA, NA, NA, NA, NA, NA), "Set 3" = c( 1, 10, NA, NA, 50, NA, NA, 80, NA, NA, NA, NA, NA, NA, NA, NA), "Warm" = c( 1, 90, -30, NA, 50, NA, NA, 70, NA, NA, NA, NA, NA, NA, NA, NA), "Cold" = c( 1, 270, 150, NA, 50, NA, NA, 70, NA, NA, NA, NA, NA, NA, NA, NA), "Harmonic" = c( 1, 60, 240, NA, 50, NA, NA, 70, NA, NA, NA, NA, NA, NA, NA, NA), "Dynamic" = c( 1, 30, NA, NA, 50, NA, NA, 70, NA, NA, NA, NA, NA, NA, NA, NA), ## 2 : sequential "Grays" = c( 2, 0, NA, NA, 0, NA, NA, 10, 98, NA, 1.3, NA, NA, NA, NA, NA), "Light Grays" = c( 2, 0, NA, NA, 0, NA, NA, 30, 90, NA, 1.5, NA, NA, NA, NA, NA), "Blues 2" = c( 2, 260, NA, NA, 80, NA, NA, 30, 90, NA, 1.5, NA, NA, NA, NA, NA), "Blues 3" = c( 2, 245, NA, NA, 50, NA, NA, 20, 98, NA, 0.8, 1.4, NA, NA, 75, NA), "Purples 2" = c( 2, 270, NA, NA, 70, NA, NA, 25, 95, NA, 1.2, NA, NA, NA, NA, NA), "Purples 3" = c( 2, 270, NA, NA, 50, NA, NA, 20, 98, NA, 0.9, 1.4, NA, NA, 75, NA), "Reds 2" = c( 2, 10, NA, NA, 85, NA, NA, 25, 95, NA, 1.3, NA, NA, NA, NA, NA), "Reds 3" = c( 2, 10, NA, NA, 65, NA, NA, 20, 97, NA, 1.1, 1.3, NA, NA, 150, NA), "Greens 2" = c( 2, 135, NA, NA, 45, NA, NA, 35, 95, NA, 1.3, NA, NA, NA, NA, NA), "Greens 3" = c( 2, 135, NA, NA, 35, NA, NA, 25, 98, NA, 1, 1.5, NA, NA, 70, NA), "Oslo" = c( 2, 250, NA, NA, 0, 0, NA, 99, 1, NA, 1, NA, NA, NA, 70, NA), "Purple-Blue" = c( 2, 300, 200, NA, 60, 0, NA, 25, 95, NA, 0.7, 1.3, NA, NA, NA, NA), "Red-Purple" = c( 2, 10, -80, NA, 80, 5, NA, 25, 95, NA, 0.7, 1.3, NA, NA, NA, NA), "Red-Blue" = c( 2, 0, -100, NA, 80, 40, NA, 40, 75, NA, 1, 1, NA, NA, NA, NA), "Purple-Orange" = c( 2, -83, 20, NA, 65, 18, NA, 32, 90, NA, 0.5, 1, NA, NA, NA, NA), "Purple-Yellow" = c( 2, 320, 80, NA, 60, 20, NA, 30, 95, NA, 0.7, 1.3, NA, NA, 65, NA), "Blue-Yellow" = c( 2, 265, 80, NA, 60, 10, NA, 25, 95, NA, 0.7, 2, NA, NA, NA, NA), "Green-Yellow" = c( 2, 140, 80, NA, 50, 10, NA, 40, 97, NA, 0.7, 1.8, NA, NA, NA, NA), "Red-Yellow" = c( 2, 10, 85, NA, 80, 10, NA, 25, 95, NA, 0.4, 1.3, NA, NA, NA, NA), "Heat" = c( 2, 0, 90, NA, 80, 30, NA, 30, 90, NA, 0.2, 2, NA, NA, NA, NA), "Heat 2" = c( 2, 0, 90, NA, 100, 30, NA, 50, 90, NA, 0.2, 1, NA, NA, NA, NA), "Terrain" = c( 2, 130, 0, NA, 80, 0, NA, 60, 95, NA, 0.1, 1, NA, NA, NA, NA), "Terrain 2" = c( 2, 130, 30, NA, 65, 0, NA, 45, 90, NA, 0.5, 1.5, NA, NA, NA, NA), "Viridis" = c( 2, 300, 75, NA, 40, 95, NA, 15, 90, NA, 1, 1.1, NA, NA, NA, NA), "Plasma" = c( 2, -100, 100, NA, 60, 100, NA, 15, 95, NA, 2, 0.9, NA, NA, NA, NA), "Inferno" = c( 2, -100, 85, NA, 0, 65, NA, 1, 98, NA, 1.1, 0.9, NA, NA, 120, NA), "Rocket" = c( 2, -70, 60, NA, 0, 10, NA, 2, 97, NA, 0.8, 0.8, NA, NA, 130, NA), "Mako" = c( 2, 325, 130, NA, 0, 18, NA, 2, 95, NA, 1.0, 1.0, NA, NA, 70, NA), "Dark Mint" = c( 2, 240, 130, NA, 30, 33, NA, 25, 95, NA, 1, NA, NA, NA, NA, NA), "Mint" = c( 2, 205, 140, NA, 40, 12, NA, 34, 94, NA, 0.5, 1, NA, NA, NA, NA), "BluGrn" = c( 2, 215, 120, NA, 25, 30, NA, 31, 88, NA, 0.7, 1.1, NA, NA, 45, NA), "Teal" = c( 2, 240, 180, NA, 35, 15, NA, 35, 92, NA, 0.6, 1.1, NA, NA, 40, NA), "TealGrn" = c( 2, 220, 125, NA, 44, 50, NA, 49, 90, NA, 0.8, 1.2, NA, NA, 60, NA), "Emrld" = c( 2, 224, 105, NA, 23, 55, NA, 25, 92, NA, 1.5, 1, NA, NA, NA, NA), "BluYl" = c( 2, 250, 90, NA, 40, 55, NA, 33, 98, NA, 0.5, 1, NA, NA, NA, NA), "ag_GrnYl" = c( 2, 225, 87, NA, 27, 86, NA, 34, 92, NA, 0.9, NA, NA, NA, NA, NA), "Peach" = c( 2, 15, 50, NA, 128, 30, NA, 55, 90, NA, 1.1, NA, NA, NA, NA, NA), "PinkYl" = c( 2, -4, 80, NA, 100, 47, NA, 55, 96, NA, 1, NA, NA, NA, NA, NA), "Burg" = c( 2, -10, 10, NA, 40, 40, NA, 25, 85, NA, 1.2, 1, NA, NA, 75, NA), "BurgYl" = c( 2, -10, 55, NA, 45, 30, NA, 30, 90, NA, 0.7, 1, NA, NA, 80, NA), "RedOr" = c( 2, -3, 53, NA, 75, 42, NA, 44, 86, NA, 0.8, 1, NA, NA, 90, NA), "OrYel" = c( 2, 5, 72, NA, 120, 49, NA, 56, 87, NA, 1, NA, NA, NA, 125, NA), "Purp" = c( 2, 270, 300, NA, 55, 20, NA, 42, 92, NA, 0.6, 1, NA, NA, 60, NA), "PurpOr" = c( 2, -83, 20, NA, 55, 18, NA, 32, 90, NA, 0.6, 1, NA, NA, 65, NA), "Sunset" = c( 2, -80, 78, NA, 60, 55, NA, 40, 91, NA, 0.8, 1, NA, NA, 75, NA), "Magenta" = c( 2, 312, 358, NA, 50, 24, NA, 27, 85, NA, 0.6, 1.1, NA, NA, 65, NA), "SunsetDark" = c( 2, -35, 50, NA, 55, 60, NA, 30, 90, NA, 1.2, 1, NA, NA, 120, NA), "ag_Sunset" = c( 2, -85, 70, NA, 70, 45, NA, 25, 85, NA, 0.6, 1, NA, NA, 105, NA), "BrwnYl" = c( 2, -20, 70, NA, 30, 20, NA, 20, 90, NA, 1, 1.1, NA, NA, 60, NA), "YlOrRd" = c( 2, 5, 85, NA, 75, 40, NA, 25, 99, NA, 1.6, 1.3, NA, NA, 180, NA), "YlOrBr" = c( 2, 20, 85, NA, 50, 20, NA, 25, 99, NA, 1.3, 1.5, NA, NA, 150, NA), "OrRd" = c( 2, 0, 60, NA, 90, 10, NA, 25, 97, NA, 1, 1.5, NA, NA, 135, NA), "Oranges" = c( 2, 20, 55, NA, 70, 10, NA, 30, 97, NA, 1.2, 1.3, NA, NA, 150, NA), "YlGn" = c( 2, 160, 85, NA, 25, 20, NA, 25, 99, NA, 1.2, 1.6, NA, NA, 70, NA), "YlGnBu" = c( 2, 270, 90, NA, 40, 25, NA, 15, 99, NA, 2, 1.5, NA, NA, 90, NA), "Reds" = c( 2, 0, 35, NA, 65, 5, NA, 20, 97, NA, 1.1, 1.3, NA, NA, 150, NA), "RdPu" = c( 2, -70, 40, NA, 45, 5, NA, 15, 97, NA, 1, 1.3, NA, NA, 100, NA), "PuRd" = c( 2, 20, -95, NA, 60, 5, NA, 20, 97, NA, 1.6, 1.1, NA, NA, 140, NA), "Purples" = c( 2, 275, 270, NA, 55, 5, NA, 20, 99, NA, 1.3, 1.3, NA, NA, 70, NA), "PuBuGn" = c( 2, 160, 320, NA, 25, 5, NA, 25, 98, NA, 1.4, 1.2, NA, NA, 70, NA), "PuBu" = c( 2, 240, 260, NA, 30, 5, NA, 25, 98, NA, 1.5, 1.2, NA, NA, 70, NA), "Greens" = c( 2, 135, 115, NA, 35, 5, NA, 25, 98, NA, 1, 1.5, NA, NA, 70, NA), "BuGn" = c( 2, 125, 200, NA, 30, 5, NA, 25, 98, NA, 1.4, 1.6, NA, NA, 65, NA), "GnBu" = c( 2, 265, 95, NA, 55, 10, NA, 25, 97, NA, 1.3, 1.7, NA, NA, 80, NA), "BuPu" = c( 2, 320, 200, NA, 40, 5, NA, 15, 98, NA, 1.2, 1.3, NA, NA, 65, NA), "Blues" = c( 2, 260, 220, NA, 45, 5, NA, 25, 98, NA, 1.2, 1.3, NA, NA, 70, NA), "Lajolla" = c( 2, 90, -20, NA, 40, 5, NA, 99, 5, NA, 0.7, 0.8, NA, NA, 100, NA), "Turku" = c( 2, 10, 120, NA, 20, 0, NA, 95, 1, NA, 1.7, 0.8, NA, NA, 55, NA), "Hawaii" = c( 2, -30, 200, NA, 70, 35, NA, 30, 92, NA, 0.3, 1, NA, NA, 75, NA), "Batlow" = c( 2, 270, -40, NA, 35, 35, NA, 12, 88, NA, 0.6, 1.1, NA, NA, 75, NA), ## 3 : diverging "Blue-Red" = c( 3, 260, 0, NA, 80, NA, NA, 30, 90, NA, 1.5, NA, NA, NA, NA, NA), "Blue-Red 2" = c( 3, 260, 0, NA, 100, NA, NA, 50, 90, NA, 1, NA, NA, NA, NA, NA), "Blue-Red 3" = c( 3, 255, 12, NA, 50, NA, NA, 20, 97, NA, 1, 1.3, NA, NA, 80, NA), "Red-Green" = c( 3, 340, 128, NA, 60, NA, NA, 30, 97, NA, 0.8, 1.5, NA, NA, 80, NA), "Purple-Green" = c( 3, 300, 128, NA, 30, NA, NA, 20, 95, NA, 1, 1.4, NA, NA, 65, NA), "Purple-Brown" = c( 3, 270, 40, NA, 30, NA, NA, 20, 98, NA, 0.8, 1.2, NA, NA, 70, NA), "Green-Brown" = c( 3, 180, 55, NA, 40, NA, NA, 25, 97, NA, 0.8, 1.4, NA, NA, 65, NA), "Blue-Yellow 2" = c( 3, 265, 80, NA, 80, NA, NA, 40, 95, NA, 1.2, NA, NA, NA, NA, NA), "Blue-Yellow 3" = c( 3, 265, 80, NA, 80, NA, NA, 70, 95, NA, 0.5, 2, NA, NA, NA, NA), "Green-Orange" = c( 3, 130, 43, NA, 100, NA, NA, 70, 90, NA, 1, NA, NA, NA, NA, NA), "Cyan-Magenta" = c( 3, 180, 330, NA, 59, NA, NA, 75, 95, NA, 1.5, NA, NA, NA, NA, NA), "Tropic" = c( 3, 195, 325, NA, 70, NA, NA, 55, 95, NA, 1, NA, NA, NA, NA, NA), "Broc" = c( 3, 240, 85, NA, 30, NA, NA, 15, 98, NA, 0.9, NA, NA, NA, 45, NA), "Cork" = c( 3, 245, 125, NA, 30, NA, NA, 15, 95, NA, 0.9, 1.1, NA, NA, 55, NA), "Vik" = c( 3, 240, 55, NA, 45, NA, NA, 15, 95, NA, 0.8, 1.1, NA, NA, 65, NA), "Berlin" = c( 3, 240, 15, NA, 60, NA, NA, 75, 5, NA, 1.2, 1.5, NA, NA, 80, NA), "Lisbon" = c( 3, 240, 85, NA, 30, NA, NA, 98, 8, NA, 1, NA, NA, NA, 45, NA), "Tofino" = c( 3, 260, 120, NA, 45, NA, NA, 90, 5, NA, 0.8, 1, NA, NA, 55, NA), ## 4 : divergingx "ArmyRose" = c( 4, 0, NA, 93, 73, 18, 47, 58, 98, 52, 1.5, 0.8, 0.8, 1, NA, 55), "Earth" = c( 4, 43, 82, 221, 61, 30, 45, 50, 92, 52, 1, 1, 0.8, 1, NA, 10), "Fall" = c( 4, 133, 77, 21, 20, 35, 100, 35, 95, 50, 1, NA, 1.5, NA, NA, NA), "Geyser" = c( 4, 192, 77, 21, 40, 35, 100, 50, 95, 50, 1, 1, 1.2, 1, 20, NA), "TealRose" = c( 4, 190, 77, 0, 50, 25, 80, 55, 92, 55, 1.5, 1, 1.8, 1, 15, NA), "Temps" = c( 4, 191, 80, -4, 43, 50, 78, 55, 89, 54, 1.6, 1, 1, 1, 57, 85), "PuOr" = c( 4, 40, NA, 270, 70, 0, 30, 30, 98, 10, 0.6, 1.4, 1.5, 1.3, 100, 65), "RdBu" = c( 4, 20, NA, 230, 60, 0, 50, 20, 98, 15, 1.4, 1.2, 1.5, 1.5, 125, 90), "RdGy" = c( 4, 5, 50, 50, 60, 0, 0, 20, 98, 20, 1.2, 1.2, 1, 1.2, 125, NA), "PiYG" = c( 4, 340, NA, 115, 75, 0, 50, 30, 98, 35, 1.3, 1.4, 0.8, 1.5, 100, 80), "PRGn" = c( 4, 300, NA, 128, 30, 0, 30, 15, 97, 25, 1.3, 1.2, 0.9, 1.5, 65, 65), "BrBG" = c( 4, 55, NA, 180, 40, 0, 30, 25, 97, 20, 0.8, 1.4, 0.8, 1.4, 75, 45), "RdYlBu" = c( 4, 10, 85, 260, 105, 45, 70, 35, 98, 35, 1.5, 1.2, 0.6, 1.2, 150, 10), "RdYlGn" = c( 4, 10, 85, 140, 105, 45, 50, 35, 98, 35, 1.5, 1.2, 0.8, 1.2, 150, 75), "Spectral" = c( 4, 0, 85, 270, 90, 45, 65, 37, 98, 37, 1, 1.2, 1, 1.2, 120, NA), "Zissou 1" = c( 4, 218, 71, 12, 46, 88, 165, 59, 82, 52, 0.2, 1, 3, 1, 33, NA), "Cividis" = c( 4, 255, NA, 75, 30, 0, 95, 13, 52, 92, 1.1, 1, 1, NA, 47, NA), "Roma" = c( 4, 10, 120, 265, 80, 25, 80, 25, 92, 25, 0.4, 1.5, 1.0, 1.2, NA, NA) )) .hcl_colors_parameters$type <- factor(.hcl_colors_parameters$type, labels = c("qualitative", "sequential", "diverging", "divergingx")) hcl.pals <- function(type = NULL) { if (is.null(type)) return(rownames(.hcl_colors_parameters)) type <- match.arg(tolower(type), levels(.hcl_colors_parameters$type)) rownames(.hcl_colors_parameters)[.hcl_colors_parameters$type == type] } ## palette function a la rainbow(n, ...), heat.colors(n) etc. hcl.colors <- function(n, palette = "viridis", alpha = NULL, rev = FALSE, fixup = TRUE) { ## empty palette n <- as.integer(n[1L]) if(n < 1L) return(character()) ## match palette (ignoring case, space, -, _) fx <- function(x) tolower(gsub("[-, _, \\,, (, ), \\ , \\.]", "", x)) p <- charmatch(fx(palette), fx(rownames(.hcl_colors_parameters))) if(is.na(p)) stop("'palette' does not match any given palette") if(p < 1L) stop("'palette' is ambiguous") p <- .hcl_colors_parameters[p, ] p.type <- as.character(p$type[1L]) # one of the factor levels p <- unlist(p[1L, -1L, drop = TRUE]) ## trajectories lintrj <- function(i, p1, p2) p2 - (p2 - p1) * i tritrj <- function(i, j, p1, p2, pm) ifelse(i <= j, p2 - (p2 - pm) * i/j, pm - (pm - p1) * abs((i - j)/(1 - j))) seqhcl <- function(i, h1, h2, c1, c2, l1, l2, p1, p2, cmax) { j <- 1/(1 + abs(cmax - c1) / abs(cmax - c2)) if (!is.na(j) && (j <= 0 || 1 <= j)) j <- NA hcl(h = lintrj(i, h1, h2), c = if(is.na(j)) lintrj(i^p1, c1, c2) else tritrj(i^p1, j, c1, c2, cmax), l = lintrj(i^p2, l1, l2), alpha = alpha, fixup = fixup) } ## adapt defaults and set up HCL colors switch(p.type, "qualitative" = { if(is.na(p[["h2"]])) p[["h2"]] <- p[["h1"]] + 360 * (n - 1L)/n ## h/c/l trajectories i <- seq.int(1, 0, length.out = n) col <- hcl(h = lintrj(i, p[["h1"]], p[["h2"]]), c = p[["c1"]], l = p[["l1"]], alpha = alpha, fixup = fixup) }, "sequential" = { if(is.na(p[["h2"]])) p[["h2"]] <- p[["h1"]] if(is.na(p[["c2"]])) p[["c2"]] <- 0 if(is.na(p[["p2"]])) p[["p2"]] <- p[["p1"]] ## h/c/l trajectories i <- seq.int(1, 0, length.out = n) col <- seqhcl(i, p[["h1"]], p[["h2"]], p[["c1"]], p[["c2"]], p[["l1"]], p[["l2"]], p[["p1"]], p[["p2"]], p[["cmax1"]]) }, "diverging" = { if(is.na(p[["p2"]])) p[["p2"]] <- p[["p1"]] ## h/c/l trajectories n2 <- ceiling(n/2) i <- seq.int(1, by = -2/(n - 1), length.out = n2) col <- c(seqhcl(i, p[["h1"]], p[["h1"]], p[["c1"]], 0, p[["l1"]], p[["l2"]], p[["p1"]], p[["p2"]], p[["cmax1"]]), rev(seqhcl(i, p[["h2"]], p[["h2"]], p[["c1"]], 0, p[["l1"]], p[["l2"]], p[["p1"]], p[["p2"]], p[["cmax1"]]))) if(n%/%2 < n2) col <- col[-n2] }, "divergingx" = { if(is.na(p[["p2"]])) p[["p2"]] <- p[["p1"]] if(is.na(p[["p4"]])) p[["p4"]] <- p[["p2"]] ## h/c/l trajectories n2 <- ceiling(n/2) i <- seq.int(1, by = -2/(n - 1), length.out = n2) col <- c(seqhcl(i, p[["h1"]], if(is.na(p[["h2"]])) p[["h1"]] else p[["h2"]], p[["c1"]], p[["c2"]], p[["l1"]], p[["l2"]], p[["p1"]], p[["p2"]], p[["cmax1"]]), rev(seqhcl(i, p[["h3"]], if(is.na(p[["h2"]])) p[["h3"]] else p[["h2"]], p[["c3"]], p[["c2"]], p[["l3"]], p[["l2"]], p[["p3"]], p[["p4"]], p[["cmax2"]]))) if(n%/%2 < n2) col <- col[-n2] }, stop("wrong 'type'; should never happen, please report!")) if(rev) rev(col) else col }