diff --git a/DESCRIPTION b/DESCRIPTION index fcb6b5b..072e920 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -42,4 +42,4 @@ URL: https://mtennekes.github.io/cols4all/, https://github.com/mtennekes/cols4al BugReports: https://github.com/mtennekes/cols4all/issues Roxygen: list(markdown = TRUE) VignetteBuilder: knitr -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index 8c4a861..ec1b44e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,7 @@ export(c4a_palettes) export(c4a_plot) export(c4a_plot_cvd) export(c4a_plot_hex) +export(c4a_ramp) export(c4a_scores) export(c4a_series) export(c4a_sysdata_export) diff --git a/R/c4a.R b/R/c4a.R index 859f755..c7cbaf4 100644 --- a/R/c4a.R +++ b/R/c4a.R @@ -22,7 +22,7 @@ #' @rdname c4a #' @name c4a #' @export -c4a = function(palette = NULL, n = NA, m = NA, type = c("cat", "seq", "div", "bivs", "bivc", "bivd", "bivg"), reverse = FALSE, order = NULL, range = NA, colorsort = "orig", format = c("hex", "RGB", "HCL"), nm_invalid = c("error", "repeat", "interpolate"), verbose = TRUE) { +c4a = function(palette = NULL, n = NA, m = NA, type = c("cat", "seq", "div", "cyc", "bivs", "bivc", "bivd", "bivg"), reverse = FALSE, order = NULL, range = NA, colorsort = "orig", format = c("hex", "RGB", "HCL"), nm_invalid = c("error", "repeat", "interpolate"), verbose = TRUE) { calls = names(match.call(expand.dots = TRUE)[-1]) type = match.arg(type) @@ -96,6 +96,23 @@ c4a = function(palette = NULL, n = NA, m = NA, type = c("cat", "seq", "div", "bi } } +#' @param space a character string; interpolation in RGB or CIE Lab color spaces +#' @param interpolate use spline or linear interpolation +#' @param ... passed on to `c4a`. +#' @rdname c4a +#' @name c4a_ramp +#' @export +c4a_ramp = function(..., space = c("rgb", "Lab"), + interpolate = c("linear", "spline")) { + space = match.arg(space) + interpolate = match.arg(interpolate) + args = list(...) + pal = do.call(c4a, args) + if (is.null(pal)) return(invisible(NULL)) + colorRampPalette(pal, space = space, interpolate = interpolate) +} + + #' Get information from a cols4all palette #' #' Get information from a cols4all palette @@ -134,7 +151,7 @@ c4a_info = function(palette, no.match = c("message", "error", "null"), verbose = #' @rdname c4a #' @name c4a_na #' @export -c4a_na = function(palette = NULL, type = c("cat", "seq", "div"), verbose = TRUE) { +c4a_na = function(palette = NULL, type = c("cat", "seq", "div", "cyc"), verbose = TRUE) { type = match.arg(type) if (is.null(palette)) { palette = c4a_default_palette(type) diff --git a/R/c4a_data.R b/R/c4a_data.R index c54fcf7..f8de9a5 100644 --- a/R/c4a_data.R +++ b/R/c4a_data.R @@ -24,7 +24,7 @@ #' @param nmin,nmax,ndef minimum / maximum / default number of colors for the palette. By default: `nmin = 1`, for `"cat"` `nmax` and `ndef` the number of supplied colors. For the other types, `nmax` is `Inf`. `ndef` is 7 for `"seq"`, 9. For diverging palettes, these numbers refer to the number of columns. (See `mmin`, `mmax`, `mdef` for the rows) #' @param mmin,mmax,mdef minimum / maximum / default number of rows for bivariate palettes. #' @param format.palette.name should palette names be formatted to lowercase/underscore format? -#' @param remove.blacks,take.gray.for.NA,remove.other.grays These arguments determine the processing of grayscale colors for categorical `"cat"` palettes: if `remove.blacks` and there are (near) blacks, these are removed first. Next, if `take.gray.for.NA`, `xNA` is `NA`, and a palette contains at least one grayscale color (which can also be white), this is used as color for missing values. In case there are more than one grayscale color, the lightest is taken. `remove.other.grays` determines what happens with the other grays. +#' @param remove.blacks,remove.whites,take.gray.for.NA,remove.other.grays These arguments determine the processing of grayscale colors for categorical `"cat"` palettes: if `remove.blacks` and there are (near) blacks, these are removed first. Next, if `take.gray.for.NA`, `xNA` is `NA`, and a palette contains at least one grayscale color (which can also be white), this is used as color for missing values. In case there are more than one grayscale color, the lightest is taken. `remove.other.grays` determines what happens with the other grays. #' @param light.to.dark should sequential `"seq"` palettes be automatically ordered from light to dark? #' @param remove.names should individual color names be removed? #' @param biv.method method to a create bivariate palette. Options are `"byrow"` means that the colors are wrapped row-wise to a color matrix where the number of rows and columns is automatically determined, `"byrowX"` the same but with X (integer between 2 and 9) columns, `"bycol"` and `"bycolX` similar but wrapped column-wise. `"div2seqseq"` and `"div2catseq` means that colors are extracted from a divering palette. The former translates colors into a matrix with the neutral color in the diagonal, while the latter places the neutral color in the middle column. `"seq2uncseq"` @@ -38,7 +38,7 @@ #' @rdname c4a_data #' @name c4a_data #' @export -c4a_data = function(x, xNA = NA, types = "cat", series = "x", nmin = NA, nmax = NA, ndef = NA, mmin = NA, mmax = NA, mdef = NA, format.palette.name = TRUE, remove.blacks = TRUE, take.gray.for.NA = TRUE, remove.other.grays = FALSE, light.to.dark = FALSE, remove.names = TRUE, biv.method = "byrow", space = "rgb", range_matrix_args = list(NULL), bib = NA, description = NA) { +c4a_data = function(x, xNA = NA, types = "cat", series = "x", nmin = NA, nmax = NA, ndef = NA, mmin = NA, mmax = NA, mdef = NA, format.palette.name = TRUE, remove.blacks = NA, remove.whites = NA, take.gray.for.NA = FALSE, remove.other.grays = FALSE, light.to.dark = FALSE, remove.names = TRUE, biv.method = "byrow", space = "rgb", range_matrix_args = list(NULL), bib = NA, description = NA) { check_installed_packages("colorblindcheck") @@ -94,6 +94,7 @@ c4a_data = function(x, xNA = NA, types = "cat", series = "x", nmin = NA, nmax = take.gray.for.NA = take.gray.for.NA, remove.other.grays = remove.other.grays, remove.blacks = remove.blacks, + remove.whites = remove.whites, light.to.dark = light.to.dark, remove.names = remove.names, biv.method = biv.method, @@ -302,9 +303,9 @@ c4a_load = function(data, overwrite = FALSE) { #' @rdname c4a_data #' @name c4a_data_as_is #' @export -c4a_data_as_is = function(..., format.palette.name = FALSE, remove.blacks = FALSE, take.gray.for.NA = FALSE, remove.other.grays = FALSE, light.to.dark = FALSE, remove.names = FALSE) { +c4a_data_as_is = function(..., format.palette.name = FALSE, remove.blacks = FALSE, remove.whites = FALSE, take.gray.for.NA = FALSE, remove.other.grays = FALSE, light.to.dark = FALSE, remove.names = FALSE) { - args = c(list(...), list(format.palette.name = format.palette.name, take.gray.for.NA = take.gray.for.NA, remove.other.grays = remove.other.grays, remove.blacks = remove.blacks, light.to.dark = light.to.dark, remove.names = remove.names)) + args = c(list(...), list(format.palette.name = format.palette.name, take.gray.for.NA = take.gray.for.NA, remove.other.grays = remove.other.grays, remove.blacks = remove.blacks, remove.whites = remove.whites, light.to.dark = light.to.dark, remove.names = remove.names)) do.call(c4a_data, args) } diff --git a/R/c4a_default_contrast.R b/R/c4a_default_contrast.R index 07d772b..9a7a566 100644 --- a/R/c4a_default_contrast.R +++ b/R/c4a_default_contrast.R @@ -29,6 +29,11 @@ range_seq = function(n = 9, nmin = 3, nmax = 9, slope_min = 1/30, slope_max = 1/ rm } +range_cyc = function(n = 9) { + # n x 2 matrix with 0 1 (full range) + matrix(c(0,1), nrow = n, ncol = 2, byrow = TRUE) +} + range_div = function(n = 11, nmin = 3, nmax = 11, slope = 1/20) { nmax = min(nmax, n) diff --git a/R/c4a_gui.R b/R/c4a_gui.R index 4c2e3c5..bddb515 100644 --- a/R/c4a_gui.R +++ b/R/c4a_gui.R @@ -123,7 +123,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { x = c4a_info(palette) n_init = x$ndef - pal_init = c(c4a(palette, n = n_init), "#ffffff", "#000000") + pal_init = unique(c(c4a(palette, n = n_init), "#ffffff", "#000000")) getNames = function(p) { @@ -193,7 +193,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { condition = "input.type1 == 'biv'", shiny::fluidRow( shiny::column(6, - shiny::sliderInput("nbiv", "Number of columns", min = 3, max = 7, value = 3, ticks = FALSE)), + shiny::uiOutput("nbivUI")), shiny::column(6, shinyjs::disabled(shiny::sliderInput("mbiv", "Number of rows", min = 3, max = 7, value = 3, ticks = FALSE))))), shiny::checkboxInput("na", "Color for missing values", value = FALSE), @@ -526,7 +526,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { tab_vals = shiny::reactiveValues(pal = pal_init, na = FALSE, - palBW = c(pal_init, "#FFFFFF", "#000000"), + palBW = unique(c(pal_init, "#FFFFFF", "#000000")), pal_name = palette, n = n_init, colA1 = pal_init[1], colA2 = pal_init[2], @@ -551,6 +551,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { }) shiny::observeEvent(get_cols(), { + if (is.null(input$sort)) return(NULL) cols = get_cols() sort = shiny::isolate(input$sort) shiny::freezeReactiveValue(input, "sort") @@ -573,9 +574,12 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { type = get_type12() if (!(type %in% types_available)) return(NULL) - if (type %in% c("cat", "seq", "div")) { + if (is.null(input$n)) return(NULL) + + if (type %in% c("cat", "seq", "div", "cyc")) { series = series_d() if (is.null(series)) return(NULL) + ns = def_n(npref = input$n, type, series, tab_nmin, tab_nmax) shiny::freezeReactiveValue(input, "n") shiny::updateSliderInput(session, "n", min = ns$nmin, max = ns$nmax, value = ns$n) @@ -607,7 +611,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { shiny::observeEvent(series_d(), { type = get_type12() - if (!(type %in% c("cat", "seq", "div"))) return(NULL) + if (!(type %in% c("cat", "seq", "div", "cyc"))) return(NULL) series = series_d() @@ -632,6 +636,12 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { size = "l")) }) + output$nbivUI = shiny::renderUI({ + type = get_type12() + shiny::sliderInput("nbiv", "Number of columns", min = 3, max = ifelse(type == "bivc", 10, 7), value = 3, ticks = FALSE) + }) + + get_cols = shiny::reactive({ type = get_type12() res = table_columns(type, input$advanced) @@ -686,7 +696,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { } else { if (substr(type, 1, 3) == "biv") { #browser() - prep = prep_table(type = type, n = nbiv, m = mbiv, sort = sort, series = series, range = range, colorsort = colorsort, show.scores = show.scores, columns = columns, verbose = FALSE, n.only = FALSE) + prep = prep_table(type = type, n = nbiv, m = mbiv, sort = sort, series = series, range = range, colorsort = colorsort, show.scores = show.scores, columns = nbiv, verbose = FALSE, n.only = FALSE) } else { prep = prep_table(type = type, n = n, sort = sort, series = series, range = range, colorsort = colorsort, show.scores = show.scores, columns = columns, verbose = FALSE, n.only = n.only) @@ -716,7 +726,6 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { shiny::freezeReactiveValue(input, "mbiv") shiny::updateSliderInput(session, "mbiv", value = nbiv) } - }) # shiny::observe({ @@ -820,7 +829,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { tab_vals$na = na if (na) cols = c(cols, c4a_na(tab_vals$pal_name)) tab_vals$pal = cols - tab_vals$palBW = c(cols, "#FFFFFF", "#000000") + tab_vals$palBW = unique(c(cols, "#FFFFFF", "#000000")) tab_vals$type = values$type tab_vals$colA1 = cols[1] tab_vals$colA2 = cols[2] @@ -917,7 +926,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { cols = as.vector(c4a(x$fullname, n = tab_vals$n)) if (tab_vals$na) cols = c(cols, c4a_na(tab_vals$pal_name)) - colsBW = c(cols, "#FFFFFF", "#000000") + colsBW = unique(c(cols, "#FFFFFF", "#000000")) tab_vals$pal = cols tab_vals$pal_name = pal_name @@ -978,7 +987,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") { progress$set(message = "Colors in progress...", value = 0) - #sort = paste0({if (values$sortRev) "-" else ""}, values$sort) + tab = if (is.null(values$prep)) NULL else plot_table(p = values$prep, text.format = values$format, text.col = values$textcol, include.na = values$na, cvd.sim = values$cvd, verbose = FALSE) } diff --git a/R/c4a_palettes.R b/R/c4a_palettes.R index 334c537..441b3ba 100644 --- a/R/c4a_palettes.R +++ b/R/c4a_palettes.R @@ -12,7 +12,7 @@ #' @rdname c4a_palettes #' @name c4a_palettes #' @export -c4a_palettes = function(type = c("all", "cat", "seq", "div"), series = NULL, full.names = TRUE) { +c4a_palettes = function(type = c("all", "cat", "seq", "div", "cyc"), series = NULL, full.names = TRUE) { type = match.arg(type) z = .C4A$z if (is.null(z)) { @@ -29,7 +29,7 @@ c4a_palettes = function(type = c("all", "cat", "seq", "div"), series = NULL, ful #' @rdname c4a_palettes #' @name c4a_series #' @export -c4a_series = function(type = c("all", "cat", "seq", "div"), as.data.frame = TRUE) { +c4a_series = function(type = c("all", "cat", "seq", "div", "cyc"), as.data.frame = TRUE) { type = match.arg(type) z = .C4A$z if (is.null(z)) { diff --git a/R/c4a_table.R b/R/c4a_table.R index 287be60..381d8a3 100644 --- a/R/c4a_table.R +++ b/R/c4a_table.R @@ -1,5 +1,5 @@ table_columns = function(type, show.scores) { - if (type %in% c("seq", "div")) { + if (type %in% c("seq", "div", "cyc")) { qn = character(0) qs = character(0) } else { @@ -14,6 +14,10 @@ table_columns = function(type, show.scores) { qn = c(qn, "hueType", "contrastWT", "contrastBK", "float") qs = c(qs, "Hwidth", "CRwt", "CRbk", "Blues") sn = "H" + } else if (type == "cyc") { + qn = c(qn, "contrastWT", "contrastBK", "float") + qs = c(qs, "CRwt", "CRbk", "Blues") + sn = character(0) } else if (type %in% c("div", "bivs", "bivd", "bivg")) { qn = c(qn, "hueType", "contrastWT", "contrastBK", "float") qs = c(qs, "HwidthLR", "CRwt", "CRbk", "Blues") @@ -38,7 +42,7 @@ table_columns = function(type, show.scores) { list(qn = qn, ql = ql, qs = qs, sn = sn, sl = sl) } -prep_table = function(type = c("cat", "seq", "div", "bivs", "bivc", "bivd", "bivg"), n = NULL, m = NULL, n.only = FALSE, sort = "name", series = "all", range = NA, colorsort = "orig", show.scores = FALSE, columns = NA, verbose = TRUE) { +prep_table = function(type = c("cat", "seq", "div", "cyc", "bivs", "bivc", "bivd", "bivg"), n = NULL, m = NULL, n.only = FALSE, sort = "name", series = "all", range = NA, colorsort = "orig", show.scores = FALSE, columns = NA, verbose = TRUE) { id = NULL type = match.arg(type) @@ -273,7 +277,7 @@ plot_table = function(p, text.format, text.col, include.na, cvd.sim, verbose) { # make icons (cannot do that in onLoad due to dependency of suggested kableExtra) tc = lapply(.C4A$tc, function(tci) { - if (any(names(tci) %in% c("seq", "cat", "div"))) { + if (any(names(tci) %in% c("seq", "cat", "div", "cyc"))) { lapply(tci, function(tcii) { lapply(tcii, function(tciii) { if (is.list(tciii)) do.call(kableExtra::cell_spec, tciii) else tciii @@ -294,7 +298,7 @@ plot_table = function(p, text.format, text.col, include.na, cvd.sim, verbose) { rownames(e2) = NULL for (var in c("cbfriendly", "chroma", "hueType", "fair", "nameable", "equiluminance", "contrastWT", "contrastBK", "float")) { tcv = tc[[var]] - if (any(names(tcv) %in% c("seq", "cat", "div"))) { + if (any(names(tcv) %in% c("seq", "cat", "div", "cyc"))) { tcv = if (type %in% names(tcv)) tcv[[type]] else tcv[["x"]] } if (var %in% qn) { @@ -425,7 +429,7 @@ plot_table = function(p, text.format, text.col, include.na, cvd.sim, verbose) { #' @return An HMTL table (`kableExtra` object) #' @rdname c4a_gui #' @name c4a_gui -c4a_table = function(type = c("cat", "seq", "div", "bivs", "bivc", "bivd", "bivg"), n = NULL, m = NULL, n.only = FALSE, cvd.sim = c("none", "deutan", "protan", "tritan"), sort = "name", text.format = "hex", text.col = "same", series = "all", range = NA, colorsort = "orig", include.na = FALSE, show.scores = FALSE, columns = NA, verbose = TRUE) { +c4a_table = function(type = c("cat", "seq", "div", "cyc", "bivs", "bivc", "bivd", "bivg"), n = NULL, m = NULL, n.only = FALSE, cvd.sim = c("none", "deutan", "protan", "tritan"), sort = "name", text.format = "hex", text.col = "same", series = "all", range = NA, colorsort = "orig", include.na = FALSE, show.scores = FALSE, columns = NA, verbose = TRUE) { cvd.sim = match.arg(cvd.sim) p = prep_table(type = type, n = n, m = m, n.only = n.only, sort = sort, series = series, range = range, colorsort = colorsort, show.scores = show.scores, columns = columns, verbose = verbose) plot_table(p = p, text.format = text.format, text.col = text.col, include.na = include.na, cvd.sim = cvd.sim, verbose = verbose) diff --git a/R/check_pals.R b/R/check_pals.R index 300b2a8..50a3817 100644 --- a/R/check_pals.R +++ b/R/check_pals.R @@ -139,11 +139,12 @@ check_seq_pal = function(p) { max_step_size = max(step_sizes) #mean_step_size = mean(step_sizes) #step_indicator = max(abs(step_sizes - mean_step_size)) / mean_step_size + min_dist = min(m, na.rm = TRUE) - c(min_step = round(min_step_size * 100), max_step = round(max_step_size * 100)) + c(min_step = round(min_step_size * 100), max_step = round(max_step_size * 100), min_dist = round(min_dist * 100)) })) - sc = as(c(min_step = min(scores[,1]), max_step = min(scores[,2])), "integer") + sc = as(c(min_step = min(scores[,1]), max_step = min(scores[,2]), min_dist = min(scores[,3])), "integer") prop = hcl_prop(p) rgb = rgb_prop(p) @@ -152,23 +153,10 @@ check_seq_pal = function(p) { # Check cyclic palette # -# Check cyclic palette. Same as \code{check_seq_pal}, but also the difference between the first and last color is considered as step -# -# check_cyc_pal = function(p) { -# n = length(p) -# cvds = c("deu", "pro", "tri") -# -# scores = t(sapply(cvds, function(cvd) { -# m = colorblindcheck::palette_dist(c(p, p[1]), cvd = cvd) -# step_sizes = mapply(function(i,j) m[i,j], 1:n, 2:(n+1)) -# min_step_size = min(step_sizes) -# max_step_size = max(step_sizes) -# #mean_step_size = mean(step_sizes) -# #step_indicator = max(abs(step_sizes - mean_step_size)) / mean_step_size -# c(min_step = round(min_step_size), max_step = round(max_step_size)) -# })) -# as.integer(c(min_step = min(scores[,1]), max_step = min(scores[,2]))) -# } +check_cyc_pal = function(p) { + if (p[1] != tail(p,1)) stop("first color should be equal to last color") + check_seq_pal(head(p, -1)) +} # Check categorical palette # diff --git a/R/create_biv_palette.R b/R/create_biv_palette.R index 69c5c47..c29b25b 100644 --- a/R/create_biv_palette.R +++ b/R/create_biv_palette.R @@ -10,8 +10,15 @@ convert2grey = function(x) { create_biv_palette = function(palette, biv.method) { if (!(biv.method %in% c("div2seqseq", "div2catseq", "seq2uncseq", "byrow", "bycol"))) { - n = as.integer(substr(biv.method, nchar(biv.method), nchar(biv.method))) - biv.method = substr(biv.method, 1, nchar(biv.method) - 1) + # test 2 digits + n = suppressWarnings(as.integer(substr(biv.method, nchar(biv.method)-1, nchar(biv.method)))) + if (is.na(n)) { + n = as.integer(substr(biv.method, nchar(biv.method), nchar(biv.method))) + biv.method = substr(biv.method, 1, nchar(biv.method) - 1) + } else { + biv.method = substr(biv.method, 1, nchar(biv.method) - 2) + } + if (!(biv.method %in% c("div2seqseq", "byrow", "bycol"))) stop("Invalid biv.method", call. = FALSE) } else { np = length(palette) diff --git a/R/get_pal_n.R b/R/get_pal_n.R index 5f69095..53a5d06 100644 --- a/R/get_pal_n.R +++ b/R/get_pal_n.R @@ -41,7 +41,7 @@ get_pal_n = function(n, m = NA, name, type, series, palette, nmin, nmax, ndef, m } else { palette[index[[n]]] } - } else if (type %in% c("seq", "div")) { + } else if (type %in% c("seq", "div", "cyc")) { if (is.na(range[1])) { if (!is.null(index)) { pal = palette[index[[min(n, length(index))]]] @@ -62,7 +62,7 @@ get_pal_n = function(n, m = NA, name, type, series, palette, nmin, nmax, ndef, m rng = range } - if (type == "seq") { + if (type %in% c("seq", "cyc")) { if (rng[1] == 0 && rng[2] == 1) { rampPal(pal, n, space = space) } else { diff --git a/R/onLoad.R b/R/onLoad.R index d1b4398..e6fbc62 100644 --- a/R/onLoad.R +++ b/R/onLoad.R @@ -135,7 +135,8 @@ do_cellspec = function(lst) { #color-blind-friendly thresholds CBF_th = list(cat = c(min_dist = 10), - seq = c(min_step = 5), + seq = c(min_dist = 5), + cyc = c(min_dist = 5), div = c(inter_wing_dist = 10, min_step = 5), bivs = c(inter_wing_dist = 7, min_step = 3), bivc = c(min_dist = 10), @@ -147,7 +148,8 @@ do_cellspec = function(lst) { # unfriendly (rolling eyes) CBU_th = list(cat = c(min_dist = 2), - seq = c(min_step = 1), + seq = c(min_dist = 1), + cyc = c(min_dist = 1), div = c(inter_wing_dist = 4, min_step = 1), bivs = c(inter_wing_dist = 3, min_step = 1), bivc = c(min_dist = 2), @@ -189,6 +191,7 @@ do_cellspec = function(lst) { types = c("Categorical" = "cat", "Sequential" = "seq", + "Cyclic" = "cyc", "Diverging" = "div", "Bivariate (sequential x sequential)" = "bivs", "Bivariate (sequential x categorical)" = "bivc", @@ -197,6 +200,7 @@ do_cellspec = function(lst) { types1 = c("Categorical" = "cat", "Sequential" = "seq", + "Cyclic" = "cyc", "Diverging" = "div", "Bivariate" = "biv") @@ -205,17 +209,19 @@ do_cellspec = function(lst) { "Sequential x diverging" = "bivd", "Sequential x desaturated" = "bivg")) - type_info = data.frame(type = c("cat", "seq", "div", "bivs", "bivc", "bivd", "bivg"), + type_info = data.frame(type = c("cat", "seq", "div", "cyc", "bivs", "bivc", "bivd", "bivg"), description = c("categorical", "sequential", "diverging", + "cyclic", "bivariate (sequential x sequential)", "bivariate (sequential x categorical)", "bivariate (sequential x diverging)", "bivariate (sequential x desaturated)")) - ndef = c(cat = Inf, seq = 7, div = 9, bivc = Inf, bivs = 3, bivd = 3, bivg = 3) # Inf meaning maximum available colors - mdef = c(cat = 1, seq = 1, div = 1, bivc = 3, bivs = NA, bivd = 3, bivg = 3) # NA meaning same as ndef + ndef = c(cat = Inf, seq = 7, cyc = 9, div = 9, bivc = Inf, bivs = 3, bivd = 3, bivg = 3) # Inf meaning maximum available colors + mdef = c(cat = 1, seq = 1, cyc = 1, div = 1, bivc = 3, bivs = NA, bivd = 3, bivg = 3) # NA meaning same as ndef CB_ranges = list(cat = list(min_dist = c(0, 20)), - seq = list(min_step = c(0, 20), max_step = c(0, 20)), + seq = list(min_dist = c(0, 20)), + cyc = list(min_dist = c(0, 20)), div = list(inter_wing_dist = c(0, 20), min_step = c(0, 20)), bivs = list(inter_wing_dist = c(0, 20), min_step = c(0, 20)), bivc = list(min_dist = c(0, 20)), @@ -398,8 +404,8 @@ do_cellspec = function(lst) { ) - nmax = c(cat = 36, seq = 15, div = 15, bivs = 7, bivc = 7, bivd = 7, bivg = 7) - nmin = c(cat = 1, seq = 2, div = 3, bivs = 2, bivc = 2, bivd = 3, bivg = 2) + nmax = c(cat = 36, seq = 15, cyc = 15, div = 15, bivs = 7, bivc = 10, bivd = 7, bivg = 7) + nmin = c(cat = 1, seq = 2, cyc = 3, div = 3, bivs = 2, bivc = 2, bivd = 3, bivg = 2) mdef = c(bivc = 5, bivd = 5, bivg = 5) matrix_breaks = list(CR = c(1, 1.2, 1.5, 2, 3, 4.5, 7), dist = c(0, 2, 5, 10, 15)) matrix_pchs = list(CR = c(15, 17, 16, 1, 1, 2, 0), dist = c(15, 17, 16, 16, 1)) diff --git a/R/process_palette.R b/R/process_palette.R index 2e7181a..9ca0ae4 100644 --- a/R/process_palette.R +++ b/R/process_palette.R @@ -1,4 +1,7 @@ -process_palette = function(pal, type, colNA = NA, take.gray.for.NA = TRUE, remove.other.grays = FALSE, remove.blacks = TRUE, light.to.dark = TRUE, remove.names = TRUE, biv.method = "byrow", space = "rgb", range_matrix_args = list()) { +process_palette = function(pal, type, colNA = NA, take.gray.for.NA = FALSE, remove.other.grays = FALSE, remove.blacks = NA, remove.whites = NA, light.to.dark = TRUE, remove.names = TRUE, biv.method = "byrow", space = "rgb", range_matrix_args = list()) { + + if (is.na(remove.blacks)) remove.blacks = (type == "cat") + if (is.na(remove.whites)) remove.whites = (type == "cat") # maybe need to reindex index = attr(pal, "index") @@ -9,6 +12,13 @@ process_palette = function(pal, type, colNA = NA, take.gray.for.NA = TRUE, remov pal = create_biv_palette(pal, biv.method) } + if (type == "cyc") { + if (pal[1] != tail(pal, 1)) { + pal = c(pal, pal[1]) + } + } + + hcl = get_hcl_matrix(pal) #specplot(hcl(h=seq(0,360,by=10), c = 0, l= 15)) @@ -16,7 +26,7 @@ process_palette = function(pal, type, colNA = NA, take.gray.for.NA = TRUE, remov #specplot(hcl(h=seq(0,360,by=10), c = 10, l= 5)) #specplot(hcl(h=seq(0,360,by=10), c = 15, l= 0)) if (remove.blacks && type == "cat") { - isB = (hcl[,3] + hcl[,2]) <= 15 + isB = ((hcl[,3] + hcl[,2]) <= 15) | (hcl[,2] == 0) if (all(isB)) { message("Palette contains only (almost) blacks. Therefore remove.blacks is set to FALSE") remove.blacks = FALSE @@ -26,6 +36,21 @@ process_palette = function(pal, type, colNA = NA, take.gray.for.NA = TRUE, remov } } + #specplot(hcl(h=seq(0,360,by=10), c = 0, l= 15)) + #specplot(hcl(h=seq(0,360,by=10), c = 5, l= 10)) + #specplot(hcl(h=seq(0,360,by=10), c = 10, l= 5)) + #specplot(hcl(h=seq(0,360,by=10), c = 15, l= 0)) + if (remove.whites && type == "cat") { + isW = hcl[,2] <= 3 & hcl[,3] >= 99 + if (all(isW)) { + message("Palette contains only (almost) whites. Therefore remove.whites is set to FALSE") + remove.whites = FALSE + } else if (any(isW)) { + pal = pal[!isW] + hcl = hcl[!isW,] + } + } + # take lightest gray as NA color if (type == "cat") { if (take.gray.for.NA) { @@ -68,6 +93,8 @@ process_palette = function(pal, type, colNA = NA, take.gray.for.NA = TRUE, remov reversed = FALSE } + + if (is.na(colNA)) { if (substr(type, 1, 3) == "biv") { colNA = "#FFFFFF" @@ -118,7 +145,7 @@ process_palette = function(pal, type, colNA = NA, take.gray.for.NA = TRUE, remov index2[[w]] }) attr(pal, "index") = index3 - } else if (is.null(range_matrix) && type %in% c("seq", "div")) { + } else if (is.null(range_matrix) && type %in% c("seq", "div", "cyc")) { rma = formals(get(paste0("range_", type))) rma$n = NULL diff --git a/R/show_attach_scores.R b/R/show_attach_scores.R index c0dd315..a97e813 100644 --- a/R/show_attach_scores.R +++ b/R/show_attach_scores.R @@ -63,7 +63,7 @@ show_attach_scores = function(z) { z2$HwidthLR = pmax(z2$HwidthL, z2$HwidthR) } else if (type == "seq") { z2$hueType = ifelse(z2$Hwidth < .C4A$HwidthSeqSingle, "SH", ifelse(z2$Hwidth < .C4A$HwidthSeqRainbow, "MH", "RH")) - } else if (type %in% c("cat", "bivc")) { + } else if (type %in% c("cat", "cyc", "bivc")) { } else if (type %in% c("bivs", "bivd", "bivg")) { z2$hueType = ifelse(z2$HwidthL >= .C4A$HwidthDivRainbow | z2$HwidthR >= .C4A$HwidthDivRainbow, "RH", ifelse(z2$HwidthL < .C4A$HwidthDivSingle & z2$HwidthR < .C4A$HwidthDivSingle, "SH", "MH")) @@ -90,9 +90,11 @@ get_friendlyness = function(zn) { ifelse(min_dist <= .C4A$CBU_th$cat["min_dist"], -1, 0))), - ifelse(type == "seq", (min_step / 1000) + ifelse(min_step >= .C4A$CBF_th$seq["min_step"], 1, - ifelse(min_step <= .C4A$CBU_th$seq["min_step"], -1, 0)), + ifelse(type == "seq", (min_dist / 1000) + ifelse(min_dist >= .C4A$CBF_th$seq["min_dist"], 1, + ifelse(min_dist <= .C4A$CBU_th$seq["min_dist"], -1, 0)), + ifelse(type == "cyc", (min_dist / 1000) + ifelse(min_dist >= .C4A$CBF_th$cyc["min_dist"], 1, + ifelse(min_dist <= .C4A$CBU_th$cyc["min_dist"], -1, 0)), ifelse(type == "div", (inter_wing_dist / 1000) + (min_step / 1e6) + ifelse(inter_wing_dist >= .C4A$CBF_th$div["inter_wing_dist"] & min_step >= .C4A$CBF_th$div["min_step"], 1, ifelse(inter_wing_dist <= .C4A$CBU_th$div["inter_wing_dist"] | min_step <= .C4A$CBU_th$div["min_step"], -1, 0)), @@ -111,6 +113,6 @@ get_friendlyness = function(zn) { ifelse(type == "bivg", (inter_wing_dist / 1000) + (min_step / 1e6) + ifelse(inter_wing_dist >= .C4A$CBF_th$bivg["inter_wing_dist"] & min_step >= .C4A$CBF_th$bivg["min_step"], 1, - ifelse(inter_wing_dist <= .C4A$CBU_th$bivg["inter_wing_dist"] | min_step <= .C4A$CBU_th$bivg["min_step"], -1, 0)), 0))))))) + ifelse(inter_wing_dist <= .C4A$CBU_th$bivg["inter_wing_dist"] | min_step <= .C4A$CBU_th$bivg["min_step"], -1, 0)), 0)))))))) }) } diff --git a/R/sysdata.rda b/R/sysdata.rda index ceb527d..c81019f 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/build/build_palettes.R b/build/build_palettes.R index 85216f6..9962745 100644 --- a/build/build_palettes.R +++ b/build/build_palettes.R @@ -29,7 +29,7 @@ sessioninfo::session_info(pkgs = "attached") # viridisLite * 0.4.2 2023-05-02 [1] CRAN (R 4.4.0) -source("build/build_naming_model.R") +#source("build/build_naming_model.R") c4a_sysdata_remove(are.you.sure = TRUE) @@ -106,6 +106,9 @@ local({ types = ifelse(inf$category == "qual", "cat", inf$category) c4a_load(c4a_data(pals, types = types, series = "brewer")) + + divc = list(paired_biv = pals$Paired) + c4a_load(c4a_data(divc, types = "bivc", series = "brewer", biv.method = "bycol6")) }) @@ -296,21 +299,85 @@ local({ } ################################### -### package viridisLite +### matplotlib: package viridisLite ################################### +# in the original cols4all package <0.8 +# now in seaborn and matplotlib +if (FALSE) { + local({ + nms = c("magma", "inferno", "plasma", "viridis", "cividis", "rocket", "mako", "turbo") + types = ifelse(nms == "cividis", "div", "seq") -local({ - nms = c("magma", "inferno", "plasma", "viridis", "cividis", "rocket", "mako", "turbo") - types = ifelse(nms == "cividis", "div", "seq") + pals = lapply(nms, function(nm) { + viridisLite::viridis(11, option = nm) + }) + names(pals) = nms - pals = lapply(nms, function(nm) { - viridisLite::viridis(11, option = nm) + c4a_load(c4a_data(pals, types = types, series = "matplotlib")) }) - names(pals) = nms +} - c4a_load(c4a_data(pals, types = types, series = "viridis")) -}) +################################### +### matplotlib: other palettes +################################### +local({ + library(reticulate) + + mpl = import("matplotlib") + + v = c("magma", "inferno", "plasma", "viridis", "cividis") + + sq1 = c('Greys', 'Purples', 'Blues', 'Greens', 'Oranges', 'Reds', + 'YlOrBr', 'YlOrRd', 'OrRd', 'PuRd', 'RdPu', 'BuPu', + 'GnBu', 'PuBu', 'YlGnBu', 'PuBuGn', 'BuGn', 'YlGn') + + sq2 = c('gray', 'bone', + 'pink', 'spring', 'summer', 'autumn', 'winter', 'cool', + 'Wistia', 'hot', 'afmhot', 'gist_heat', 'copper') + # 'gist_gray' same as gray: + # b = mpl$colormaps$get_cmap("gist_gray")(seq(0,1,length.out = 5)) + # a = mpl$colormaps$get_cmap("gray")(seq(0,1,length.out = 5)) + # a-b + # 'gist_yarg' just a reverse + # 'binary' also identical + + # (almost?) identical to brewer + dv = c('PiYG', 'PRGn', 'BrBG', 'PuOr', 'RdGy', 'RdBu', 'RdYlBu', + 'RdYlGn', 'Spectral', 'coolwarm', 'bwr', 'seismic') + + cyc = c("twilight", "twilight_shifted", "hsv") + + # qualitative are equal to Brewer and Tableau (?) + misc = c('ocean', 'gist_earth', 'terrain', + 'gist_stern', 'gnuplot', 'gnuplot2', 'CMRmap', + 'cubehelix', 'brg', 'gist_rainbow', 'rainbow', 'jet', + 'turbo', 'nipy_spectral', 'gist_ncar') + # 'flag', 'prism' left out + + get_pals = function(nms) { + pals = lapply(nms, function(nm) { + x = mpl$colormaps$get_cmap(nm)(seq(0,1,length.out = 7)) + rgb(x[,1], x[,2], x[,3]) + }) + names(pals) = nms + pals + } + + pals_v = get_pals(v) + pals_sq1 = get_pals(sq1) + pals_sq2 = get_pals(sq2) + pals_dv = get_pals(dv) + pals_cyc = get_pals(cyc) + pals_misc = get_pals(misc) + + c4a_load(c4a_data(pals_v, types = "seq", series = "matplotlib")) + c4a_load(c4a_data(pals_sq1, types = "seq", series = "matplotlib")) + c4a_load(c4a_data(pals_sq2, types = "seq", series = "matplotlib")) + c4a_load(c4a_data(pals_dv, types = "div", series = "matplotlib")) + c4a_load(c4a_data(pals_cyc, types = "cyc", series = "matplotlib")) + c4a_load(c4a_data(pals_misc, types = "seq", series = "matplotlib")) +}) @@ -329,7 +396,7 @@ local({ pals = syspals[palsCat] names(pals) = palsNew - pals4 = syspals[substr(names(syspals), 1, 6) == "kovesi" & substr(names(syspals), 1, 13) != "kovesi.cyclic"] + pals4 = syspals[substr(names(syspals), 1, 6) == "kovesi"] # & substr(names(syspals), 1, 13) != "kovesi.cyclic"] isdiv = substr(names(pals4), 1, 16) == "kovesi.diverging" iscyc = substr(names(pals4), 1, 13) == "kovesi.cyclic" @@ -355,33 +422,22 @@ local({ "linear_bgy_10_95_c74", "isoluminant_cgo_70_c39") - new = c("linear_grey", - "rainbow_bu_rd", - "rainbow_bu_pk", - "linear_ternary_blue", - "linear_ternary_green", - "linear_ternary_red", - "linear_yl_rd_bk", - "linear_wh_rd_bk", - "linear_green", - "linear_yl_mg_bu", - "linear_wh_mg_bu", - "linear_blue", - "linear_tq_bu", - "linear_wh_yl_gn_bu", - "linear_yl_gn_bu", - "isoluminant_tq_or") - - ids = match(orig, names(pals4)) - pals4_sel = pals4[ids] - pals4_type_sel = pals4_type[ids] - names(pals4_sel) = new - - - pals_ter = pals4["linear_gow_65_90_c35"] - names(pals_ter) = "linear_terrain" - - + new = c("grey", + "rainbow_bu_gn_yl_rd", + "rainbow_bu_gn_yl_rd_mg", + "ternary_blue", + "ternary_green", + "ternary_red", + "bk_rd_yl", + "bk_rd_wh", + "green", + "bu_yl_mg", + "bu_wh_mg", + "blue", + "blue_cyan", + "bu_gn_yl", + "bu_gn_yl_wh", + "cy_or") orig_div = c("diverging_gwv_55_95_c39", "diverging_bky_60_10_c30", @@ -398,19 +454,28 @@ local({ "diverging_gkr_60_10_c40") - new_div = c("div_gn_wh_pu", - "div_bu_bk_br", - "div_bu_wh_rd", - "div_bu_wh_rd2", - "div_bu_gy_yl", - "div_bu_bk_rd", - "div_bu_gy_rd", - "div_isoluminant_tq_or", - "div_rainbow", - "div_tq_wh_pk", - "div_tq_gy_pk", - "div_gn_wh_rd", - "div_gn_bk_rd") + new_div = c("gn_wh_pu", + "bu_bk_br", + "bu_wh_rd", + "bu_wh_rd2", + "bu_gy_yl", + "bu_bk_rd", + "bu_gy_rd", + "cy_gy_or", + "rainbow", + "cy_wh_mg", + "cy_gy_mg", + "gn_wh_rd", + "gn_bk_rd") + + + orig_cyc = c("cyclic_grey_15_85_c0", "cyclic_grey_15_85_c0_s25", "cyclic_mrybm_35_75_c68", + "cyclic_mrybm_35_75_c68_s25", "cyclic_mygbm_30_95_c78", "cyclic_mygbm_30_95_c78_s25", + "cyclic_wrwbw_40_90_c42", "cyclic_wrwbw_40_90_c42_s25") + + new_cyc = c("cyclic_grey", "cyclic_grey2", "cyclic_mg_rd_yl_bu_mg", + "cyclic_bu_mg_rd_yl_bu", "cyclic_mg_yl_gn_bu_mg", "cyclic_bu_mg_yl_gn_bu", + "cyclic_wh_rd_wh_bu_wh", "cyclic_bu_wh_rd_wh_bu") ids = match(orig_div, names(pals4)) pals5 = pals4[ids] @@ -418,10 +483,16 @@ local({ names(pals5) = new_div + #misc.watlington c4a_load(c4a_data(pals, types = "cat", series = series)) - c4a_load(c4a_data(pals4_sel, types = pals4_type_sel, series = "kovesi", format.palette.name = FALSE)) - c4a_load(c4a_data_as_is(pals_ter, types = "seq", series = "kovesi", format.palette.name = FALSE)) - c4a_load(c4a_data(pals5, types = pals5_type, series = "kovesi", format.palette.name = FALSE)) + + # kovesi + names(pals4)[match(orig, names(pals4))] = new + names(pals4)[match(orig_div, names(pals4))] = new_div + names(pals4)[match(orig_cyc, names(pals4))] = new_cyc + + # c4a_data_as_is to prevent black and whites to be removed + c4a_load(c4a_data_as_is(pals4, types = pals4_type, series = "kovesi", format.palette.name = FALSE)) }) @@ -526,6 +597,8 @@ local({ if (nm %in% mseq) { c(rampPal(rgb(x$r[128:1], x$g[128:1], x$b[128:1], maxColorValue = 1), 7), rampPal(rgb(x$r[256:129], x$g[256:129], x$b[256:129], maxColorValue = 1), 7)) + } else if (nm %in% cyc) { + rampPal(rgb(c(x$r, x$r[1]), c(x$g, x$g[1]), c(x$b, x$b[1]), maxColorValue = 1), 15) } else { rampPal(rgb(x$r, x$g, x$b, maxColorValue = 1), 15) } @@ -541,6 +614,7 @@ local({ matrix(p[c(1:7,8:14)], ncol = 2) }) pals_biv[["fes"]] = pals_biv[["fes"]][,2:1] + pals_cyc = pals[cyc] #names(pals_seq)[match(c("batlowK", "batlowW", "grayC"), names(pals_seq))] = c("k_batlow", "w_batlow", "c_gray") # reverse names (because palettes will be reversed) @@ -548,6 +622,7 @@ local({ c4a_load(c4a_data(pals_div, types = "div", series = "scico")) c4a_load(c4a_data(pals_seq, types = "seq", series = "scico")) c4a_load(c4a_data(pals_biv, types = c("bivc", "bivc", "bivg"), series = "scico", biv.method = "bycol2")) + c4a_load(c4a_data(pals_cyc, types = "cyc", series = "scico")) }) ################################### @@ -599,8 +674,19 @@ local({ c4a_load(c4a_data(tab_cat, types = "cat", series = "tableau")) c4a_load(c4a_data(tab_seq, types = "seq", series = "tableau")) c4a_load(c4a_data(tab_div, types = "div", series = "tableau")) + + divc = list(winter_biv = tab_cat$Winter) + c4a_load(c4a_data(divc, types = "bivc", series = "tableau", biv.method = "bycol5")) + + divc2 = list('20_div' = tab_cat$'20', + classic20_div = tab_cat$'Classic 20') + c4a_load(c4a_data(divc2, types = "bivc", series = "tableau", biv.method = "bycol10")) + }) +################################### +### seaborn +################################### local({ @@ -834,4 +920,4 @@ local({ save(.z, .s, .zbib, .zdes, file="R/sysdata.rda", compress="xz") source("build/build_data.R") - +source("build/build_naming_model.R") diff --git a/build/references.bib b/build/references.bib index 543c8f3..b71f6dd 100644 --- a/build/references.bib +++ b/build/references.bib @@ -73,16 +73,21 @@ @misc{tol note = "Online publication" } -@unpublished{viridis, - title = {A Better Default Colormap for Matplotlib}, - author = {Smith, Nathaniel, and St\'efan Van der Walt}, - year = {2015}, - note = {SciPy 2015}, - url = {https://www.youtube.com/watch?v=xAoljeRJ3lU} +@article{matplotlib, + Author = {Hunter, J. D.}, + Title = {Matplotlib: A 2D graphics environment}, + Journal = {Computing in Science \& Engineering}, + Volume = {9}, + Number = {3}, + Pages = {90--95}, + publisher = {IEEE COMPUTER SOC}, + doi = {10.1109/MCSE.2007.55}, + year = 2007 } + @article{kovesi, author = {Peter Kovesi}, title = {Good Colour Maps: How to Design Them}, diff --git a/man/c4a.Rd b/man/c4a.Rd index ce62ee3..a5a623f 100644 --- a/man/c4a.Rd +++ b/man/c4a.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/c4a.R \name{c4a} \alias{c4a} +\alias{c4a_ramp} \alias{c4a_na} \title{Get a cols4all color palette} \usage{ @@ -19,6 +20,8 @@ c4a( verbose = TRUE ) +c4a_ramp(..., space = c("rgb", "Lab"), interpolate = c("linear", "spline")) + c4a_na(palette = NULL, type = c("cat", "seq", "div"), verbose = TRUE) } \arguments{ @@ -43,6 +46,12 @@ c4a_na(palette = NULL, type = c("cat", "seq", "div"), verbose = TRUE) \item{nm_invalid}{what should be done in case \code{n} or \code{m} is larger than the maximum number of colors or smaller than the minimum number? Options are \code{"error"} (an error is returned), \code{"repeat"}, the palette is repeated, \code{"interpolate"} colors are interpolated. For categorical \code{"cat"} palettes only.} \item{verbose}{should messages be printed?} + +\item{...}{passed on to \code{c4a}.} + +\item{space}{a character string; interpolation in RGB or CIE Lab color spaces} + +\item{interpolate}{use spline or linear interpolation} } \value{ A vector of colors (\code{c4a}) and a color (\code{c4a_na}) diff --git a/man/c4a_palettes.Rd b/man/c4a_palettes.Rd index 3107f61..b3a0eff 100644 --- a/man/c4a_palettes.Rd +++ b/man/c4a_palettes.Rd @@ -22,7 +22,7 @@ c4a_series(type = c("all", "cat", "seq", "div"), as.data.frame = TRUE) c4a_types(series = NULL, as.data.frame = TRUE) -c4a_overview() +c4a_overview(return.matrix = FALSE) .P }