accessPalettes.R

#################################################-
## Evaluate color palettes for colorblindness accessibility ----
## W.K. Petry
#################################################-
## Preliminaries ----
#################################################-
library(colorspace)
library(colorscience)
library(paletteer)  # devtools::install_github("EmilHvitfeldt/paletteer")
library(tidyverse)
library(colorblindr)  # for palette_plot() function
library(gplots)

# Convert RGB hexadecimal strings to CIE Lab color space
# (!) uncritically accepts default conversion settings
hex2Lab <- function(x){
  require(colorspace)
  XYZ2Lab(RGB2XYZ(coords(hex2RGB(x))))
}

# Convert R color names to hexadecimal strings
hexNames <- function (cname){  # modified from gplots::col2hex
  require(gplots)
  modify(.x = cname, .f = ~simplify(ifelse(grepl("^#", .x), .x, gplots::col2hex(.x))))
}

# Calculate pairwise delta E 2000 scores for color palettes in hexadecimal strings
pal_dE00 <- function(pal){
  require(colorscience)
  pairs_hex <- combn(pal, 2, simplify = FALSE)
  pairs_Lab <- lapply(pairs_hex, hex2Lab)
  unname(sapply(pairs_Lab, function(x) deltaE2000(Lab1 = x[1, ], Lab2 = x[2, ])))
}

#################################################-
## Fetch all palettes, calculate minimum delta E score under colorblind simulations ----
#################################################-
threshold <- 6  # minimum perceptible difference in Delta E, no less than 2-10 [range: 0-100]

palette_access <- palettes_d_names %>%
  as.tibble() %>%
  mutate(colors_orig = map2(.x = package, .y = palette, .f = paletteer_d),
         colors_orig = map(.x = colors_orig, .f = hexNames),
         colors_deutan = map(.x = colors_orig, .f = deutan),
         colors_protan = map(.x = colors_orig, .f = protan),
         colors_tritan = map(.x = colors_orig, .f = tritan),
         min_dE00_orig = map_dbl(.x = colors_orig, .f = ~min(pal_dE00(.x))),
         min_dE00_deutan = map_dbl(.x = colors_deutan, .f = ~min(pal_dE00(.x))),
         min_dE00_protan = map_dbl(.x = colors_protan, .f = ~min(pal_dE00(.x))),
         min_dE00_tritan = map_dbl(.x = colors_tritan, .f = ~min(pal_dE00(.x))),
         universalAccess = pmap_lgl(.l = list(..1 = min_dE00_orig, ..2 = min_dE00_deutan,
                                              ..3 = min_dE00_protan, ..4 = min_dE00_tritan),
                                    .f = ~all(c(..1, ..2, ..3, ..4) > threshold)))
palette_access

# What percentage of palettes are 'universally accessible'?
100 * sum(palette_access$universalAccess) / nrow(palette_access)

#################################################-
## Human eye test ----
## (your mileage may vary)
#################################################-
# check a 'universally accessible' palette
palette_plot(paletteer_d("ggsci", "default_jama"))  # checks out for my moderate deuteranopia

# check an 'inaccessible' palette
palette_plot(paletteer_d("ggthemes", "excel_Gallery"))  # for me, colors 4 & 5 are indistingishable