40_make-color-scheme.R

#' ---
#' date: "`r format(Sys.Date())`"
#' output: github_document
#' ---

library(here)
library(gapminder)
library(RColorBrewer)
library(tidyverse)
library(forcats)

#' map continent and country into colors

by_continent <- gapminder %>% 
  group_by(continent) %>% 
  nest() %>% 
  arrange(continent)

f <- function(x) {
  x[["country"]] %>% 
    fct_drop() %>% 
    fct_reorder(x[["pop"]], fun = max) %>% 
    levels() %>% 
    rev()
}

by_continent <- by_continent %>% 
  mutate(country = map(data, f)) %>% 
  select(-data)  %>% 
  mutate(n_cty = lengths(country))

#' choose a range of colors for each continent
display.brewer.all(type = "div")

color_anchors_by_continent <-
  list(Africa = brewer.pal(n = 11, 'PuOr')[1:5],          # orange/brown/gold
       Americas = brewer.pal(n = 11, 'RdYlBu')[1:5],      # red
       Asia = brewer.pal(n = 11, 'PRGn')[1:5],            # purple
       Europe = brewer.pal(n = 11, 'PiYG')[11:7],         # green
       Oceania = brewer.pal(n = 11, 'RdYlBu')[11:10]) %>% # blue
  enframe(name = "continent", value = "anchors")

by_continent <- by_continent %>% 
  left_join(color_anchors_by_continent)

f <- function(anchors, n) {
  color_fun <- colorRampPalette(anchors)
  color_fun(n)
}

by_continent <- by_continent %>% 
  mutate(color = map2(anchors, n_cty, f)) %>% 
  select(-anchors)

#' color scheme and country count for continents
(continent_colors_df <- by_continent %>%
    select(-country) %>% 
    mutate(color = map_chr(color, 1)))
write_tsv(
  continent_colors_df,
  here("data-raw", "40_continent-colors.tsv")
)
file.copy(
  from = here("data-raw", "40_continent-colors.tsv"),
  to = here("inst", "extdata", "continent-colors.tsv"),
  overwrite = TRUE
)

country_colors_df <- by_continent %>% 
  unnest() %>% 
  select(country, color, continent)
  
write_tsv(
  country_colors_df,
  here("data-raw", "40_country-colors.tsv")
)
file.copy(
  from =  here("data-raw", "40_country-colors.tsv"),
  to = here("inst", "extdata", "country-colors.tsv"),
  overwrite = TRUE
)

#' convert country and continent colors into named character vectors
country_colors <- country_colors_df %>% 
  select(-continent) %>% 
  deframe()

continent_colors <- continent_colors_df %>% 
  select(-n_cty) %>% 
  deframe()

## save for the package
save(
  country_colors,
  file = here("data", "country_colors.rdata")
)
save(
  continent_colors,
  file = here("data", "continent_colors.rdata")
)

#' make a nice figure of my color scheme. try to use as few packages as possible
#' here so can repurpose as example
#' 
#' prep work
char_limit <- 12  # truncate country names
j_cex <- 4        # cex for ggplot2
y_boundaries <- map(
  continent_colors_df$n_cty,
  ~ seq(0, 1, length.out = .x + 1)
)

df <- tibble( # utility data.frame with rectangle boundaries
  xmax = rep(seq_len(length(continent_colors)),
             sapply(y_boundaries, length) - 1),
  xmin = xmax - 1,
  ymin = unlist(lapply(y_boundaries, function(y) head(y, -1))),
  ymax = unlist(lapply(y_boundaries, function(y) y[-1])),
  ymid = (ymin + ymax)/2
)
df <- df %>%
  bind_cols(country_colors_df) %>% 
  mutate(cex = j_cex,
         continent = factor(continent))
df$cex[df$continent == "Africa"] <- j_cex * 0.75

#' base R graphics

#' control printing of country names
base_cex <- 0.75

op <- par(mar = c(1, 4, 1, 1) + 0.1)
plot(c(0, length(continent_colors)), c(0, 1), type = "n",
     xlab = "", ylab="", xaxt = "n", yaxt = "n", bty = "n")
with(df,
     rect(xleft = xmin,
          ybottom = ymin,
          xright = xmax,
          ytop = ymax,
          col = color, border = NA))
with(df,
     text(x = xmin + 0.5,
          y = ymid,
          labels = substr(country, 1, char_limit),
          cex = base_cex * cex/j_cex))
mtext(continent_colors_df$continent, side = 1,
      line = -0.5, at = seq_len(length(continent_colors)) - 0.5)
mtext(c("smallest\npop", "largest\npop"),
      side = 2, at = c(0.9, 0.1), las = 1)
par(op)

dev.print(
  pdf,
  here("data-raw", "gapminder-color-scheme-base.pdf"),
  width = 7, height = 10
)
file.copy(
  from = here("data-raw", "gapminder-color-scheme-base.pdf"),
  to = here("man", "figures", "gapminder-color-scheme-base.pdf"),
  overwrite = TRUE
)

#' ggplot2
p <- ggplot(df, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax)) +
  geom_rect(fill = df$color) +
  annotate("text",
           x = unclass(df$continent) - 0.5,
           y = df$ymid,
           label = df$country %>% substr(1, char_limit),
           cex = df$cex) + 
  scale_x_continuous(breaks = seq_len(length(continent_colors)) - 0.5,
                     labels = levels(df$continent)) +
  scale_y_continuous(breaks = c(0.9, 0.1),
                     labels = c("smallest\npop", "largest\npop")) +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.border = element_blank(),
        axis.text = element_text(size = rel(1.5)),
        axis.ticks = element_blank(),
        axis.title = element_blank())
p

ggsave(
  here("data-raw", "gapminder-color-scheme-ggplot2.png"),
  p,
  height = 10, width = 7
)
file.copy(
  from = here("data-raw", "gapminder-color-scheme-ggplot2.png"),
  to = here("man", "figures", "gapminder-color-scheme-ggplot2.png"),
  overwrite = TRUE
)