colNA is only grayscale, removed tri_eq from bivariate palettes, impr…

…oved c4a_scores

R/c4a.R

@@ -169,6 +169,13 @@ c4a_na = function(palette = NULL, type = c("cat", "seq", "div", "cyc"), verbose
 }
 
 
+get_zp = function(p, n = NA) {
+	x = c4a_info(p, no.match, verbose)
+	if (is.na(n)) {
+		n = x$ndef
+	}
+	z = data.frame(name = x$name, series = x$series, fullname = x$fullname, type = x$type, n = n)
+}
 
 #' Get information from a cols4all palette
 #'
@@ -180,19 +187,18 @@ c4a_na = function(palette = NULL, type = c("cat", "seq", "div", "cyc"), verbose
 #' @param verbose should messages be printed?
 #' @return list with the following items: name, series, fullname, type, palette (colors), na (color), nmax, and reverse. The latter is `TRUE` when there is a `"-"` prefix before the palette name.
 #' @export
-c4a_scores = function(palette, n = NA, no.match = c("message", "error", "null"), verbose = TRUE) {
-	x = c4a_info(palette, no.match, verbose)
-	if (is.na(n)) {
-		n = x$ndef
+#' @example examples/c4a_scores.R
+c4a_scores = function(palette = NULL, type = NULL, series = NULL, n = NA, no.match = c("message", "error", "null"), verbose = TRUE) {
+	if (!is.null(palette)) {
+		z = get_zp(palette, n)
+	} else {
+		if (is.null(type)) stop("Please specify either palette or type (optionally in combination with series)")
+		if (is.na(n)) n = .C4A$ndef[[type]]
+		pals = c4a_palettes(type = type, series = series)
+		z = do.call(rbind, lapply(pals, get_zp))
 
 	}
-	s = .C4A$s
-	rowid = which(x$fullname == dimnames(s)[[1]])[1]
-	if (is.na(rowid)) stop("No scores have been found")
-
-	si = s[rowid, , n]
-	si[.C4A$score_x100] = si[.C4A$score_x100] / 100
-	si
+	show_attach_scores(z)
 }
 
 

R/c4a_gui.R

@@ -192,7 +192,7 @@ c4a_gui = function(type = "cat", n = NA, series = "all") {
 					 				  	condition = "input.type1 != 'biv'",
 					 				  	shiny::sliderInput("n", "Number of colors", min = ns$nmin, max = ns$nmax, value = ns$n, ticks = FALSE)),
 					 				  shiny::conditionalPanel(
-					 				  	condition = "input.type1 == 'seq' || input.type1 == 'div'",
+					 				  	condition = "input.type1 == 'seq' || input.type1 == 'div' || input.type1 == 'cyc'",
 					 				  	shiny::checkboxInput("continuous", "Show as continuous palette", value = FALSE)
 					 				  ),
 					 				  shiny::conditionalPanel(

R/c4a_plot_scatter.R

@@ -43,7 +43,7 @@ c4a_plot_scatter = function(cols = NULL, col1 = "blue", col2 = "red", borders =
 	# 	pushViewport(viewport(width = unit(dasp, "snpc"), height = unit(1, "snpc")))
 	# }
 
-	grid::pushViewport(grid::viewport(xscale = c(-2, 2), yscale = c(-1, 1)))
+	grid::pushViewport(grid::viewport(xscale = c(-1.5, 1.5), yscale = c(-1.5, 1.5)))
 
 	grid::grid.points(x = x, y = y, pch = 21, size = grid::unit(size, "char"), gp = grid::gpar(col = col, fill = fill, lwd = lwd))
 

R/check_pals.R

@@ -83,7 +83,7 @@ check_bivs_pal = function(p) {
 	x1d = check_div_pal(c(rev(p1[-1]), pd))
 	x2d = check_div_pal(c(rev(p2[-1]), pd))
 
-	sc = pmin(x12, x1d, x2d)[1:3]
+	sc = pmin(x12, x1d, x2d)[1:2]
 
 	p2 = c(as.vector(p[lower.tri(p)]), p[1,1], as.vector(p[upper.tri(p)]))
 
@@ -124,7 +124,7 @@ check_bivd_pal = function(p) {
 	x12 = check_div_pal(c(rev(p[,c1]), "#FFFFFF", p[,c2]))
 	x23 = check_div_pal(c(rev(p[,c2]), "#FFFFFF", p[,c3]))
 
-	sc = pmin(x12, x13, x23)[1:3]
+	sc = pmin(x12, x13, x23)[1:2]
 
 	p2 = c(rev(p[, 1]), p[1, round((ncol(p)+1)/2)], p[, ncol(p)])
 	prop = hcl_prop(p2)
@@ -134,7 +134,7 @@ check_bivd_pal = function(p) {
 }
 
 check_bivg_pal = function(p) {
-	sc = check_div_pal(c(rev(p[,1]), "#FFFFFF", p[,ncol(p)]))[1:3]
+	sc = check_div_pal(c(rev(p[,1]), "#FFFFFF", p[,ncol(p)]))[1:2]
 
 	p2 = c(rev(p[, 1]), p[1, round((ncol(p)+1)/2)], p[, ncol(p)])
 	prop = hcl_prop(p2)

R/onLoad.R

@@ -138,10 +138,10 @@ do_cellspec = function(lst) {
 					  seq = c(min_dist = 5, tri_ineq = 2),
 					  cyc = c(min_dist = 5, tri_ineq = 2),
 					  div = c(inter_wing_dist = 10, min_step = 5, tri_ineq = 2),
-					  bivs = c(inter_wing_dist = 7, min_step = 3, tri_ineq = 1),
+					  bivs = c(inter_wing_dist = 7, min_step = 3),
 					  bivc = c(min_dist = 10),
-					  bivd = c(inter_wing_dist = 7, min_step = 3, tri_ineq = 1),
-					  bivg = c(inter_wing_dist = 7, min_step = 3, tri_ineq = 1))
+					  bivd = c(inter_wing_dist = 7, min_step = 3),
+					  bivg = c(inter_wing_dist = 7, min_step = 3))
 
 		#color-blind-very-friendly thresholds
 		CBVF_th = list(cat = c(min_dist = 15))
@@ -151,10 +151,10 @@ do_cellspec = function(lst) {
 					  seq = c(min_dist = 2, tri_ineq = 0),
 					  cyc = c(min_dist = 2, tri_ineq = 0),
 					  div = c(inter_wing_dist = 4, min_step = 2, tri_ineq = 0),
-					  bivs = c(inter_wing_dist = 3, min_step = 2, tri_ineq = 0),
+					  bivs = c(inter_wing_dist = 3, min_step = 2),
 					  bivc = c(min_dist = 2),
-					  bivd = c(inter_wing_dist = 3, min_step = 2, tri_ineq = 0),
-					  bivg = c(inter_wing_dist = 3, min_step = 2, tri_ineq = 0))
+					  bivd = c(inter_wing_dist = 3, min_step = 2),
+					  bivg = c(inter_wing_dist = 3, min_step = 2))
 
 		Cgray = 10 # maximum chroma value to be considered as gray (used for Hwidth and c4a_add_series)
 
@@ -226,10 +226,10 @@ do_cellspec = function(lst) {
 						 seq = list(min_dist = c(0, 20), tri_ineq = c(-50, 50)),
 						 cyc = list(min_dist = c(0, 20), tri_ineq = c(-50, 50)),
 						 div = list(inter_wing_dist = c(0, 20), min_step = c(0, 20), tri_ineq = c(-50, 50)),
-						 bivs = list(inter_wing_dist = c(0, 20), min_step = c(0, 20), tri_ineq = c(-50, 50)),
+						 bivs = list(inter_wing_dist = c(0, 20), min_step = c(0, 20)),
 						 bivc = list(min_dist = c(0, 20)),
-						 bivd = list(inter_wing_dist = c(0, 20), min_step = c(0, 20), tri_ineq = c(-50, 50)),
-						 bivg = list(inter_wing_dist = c(0, 20), min_step = c(0, 20), tri_ineq = c(-50, 50)))
+						 bivd = list(inter_wing_dist = c(0, 20), min_step = c(0, 20)),
+						 bivg = list(inter_wing_dist = c(0, 20), min_step = c(0, 20)))
 
 		Ohter_ranges = list(C = c(0, 180, 5),
 							L = c(0, 100, 5),

R/process_palette.R

@@ -99,26 +99,40 @@ process_palette = function(pal, type, colNA = NA, take.gray.for.NA = FALSE, remo
 		if (substr(type, 1, 3) == "biv") {
 			colNA = "#FFFFFF"
 		} else {
-			# first candidates: choose NA from grays, such that luminance is at most 0.3 lighter and not darker than the lightest resp. darkest color.
+			# first candidates: choose NA from grays: for bright palette prefer even lighter grey, dark palettes dark gray or black
 			# prefer lightest gray
-			gray_range = c(min(hcl[,3]/100), min(1, (max(hcl[,3]/100) + 0.3)))
-			candidates = list(grDevices::gray.colors(10, start = gray_range[1], end = gray_range[2]),
-							  grDevices::hcl(h = seq(0, 340, by = 20), c = 30, l = 70),
-							  grDevices::hcl(h = seq(0, 340, by = 20), c = 50, l = 70))
+			gray_range = range(hcl[,3]) / 100
 
-			colNA = "#FFFFFF"
-			for (cand in candidates) {
-				pal2 = c(pal, cand)
-				m = sapply(c("protan", "deutan", "tritan"), function(cvd) {
-					m = get_dist_matrix(pal2, cvd = cvd)
-					m2 = m[1L:length(pal), (length(pal) + 1L):length(pal2)]
-					apply(m2, MARGIN = 2, min)
-				})
-				scores = apply(m, MARGIN = 1, min)
-				if (max(scores) >= 10) {
-					colNA = cand[which.max(scores)[1]]
-					break
-				}
+
+			candidates = list(grDevices::gray.colors(10, start = gray_range[2], end = 1),
+							  grDevices::gray.colors(10, start = gray_range[2], end = 0))
+
+			if (gray_range[2] < 0.6) {
+				# => dark palette
+				candidates = rev(candidates)
+			}
+
+			if (substr(type, 1, 3) == "cat") {
+				# restrict to ligher color for bright palettes and darker colors for dark palettes, because otherwise colNA stands out too much
+				candidates = candidates[[1]]
+			}
+
+
+			cand = unlist(candidates)
+			pal2 = c(pal, cand)
+			m = sapply(c("protan", "deutan", "tritan"), function(cvd) {
+				m = get_dist_matrix(pal2, cvd = cvd)
+				m2 = m[1L:length(pal), (length(pal) + 1L):length(pal2)]
+				apply(m2, MARGIN = 2, min)
+			})
+			scores = apply(m, MARGIN = 1, min)
+
+			# take the first with at least 10 difference (larger would be too much)
+			s10 = which(scores >= 10)
+			if (length(s10)) {
+				colNA = cand[s10[1]]
+			} else {
+				colNA = cand[which.max(scores)]
 			}
 		}
 	}

examples/c4a_scores.R

@@ -0,0 +1,6 @@
+c4a_scores("blues3")
+
+pals = c4a_palettes(type = "cat")
+scores_cat7 = t(sapply(pals, c4a_scores, n = 7))
+
+head(scores_cat7)