! palettes updated, cyc added !

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

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)

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)

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)
 }
 

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)
 

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)
 			}

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)) {

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)

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
 #

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)

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 {