In 18kimn/ggdubois: Graphics In The Style Of W.E.B. Du Bois

library(devtools)
library(tidyverse)
library(showtext)
library(sf)

knitr::opts_knit$set(root.dir = here::here())
load_all()
data(demographics)
data(georgia)

dta <- georgia %>%
  group_by(year) %>%
  st_drop_geometry() %>%
  summarize(
    across(c(march_employees, owner, median_income), mean),
    across(c(
      black, white, asian, other
    ), ~ sum((total * .), na.rm = TRUE) / sum(total)),
    total_payroll = sum(payroll, na.rm = TRUE),
  ) %>%
  mutate(owner = owner - 0.4, heights = cumsum(owner), ) # scaling issue

font_add_google("Montserrat")
showtext_auto()
showtext_opts(dpi = 300)

Due to a time crunch I will be running all of these examples here and moving them to the associated scripts when I have time

fulton_county <- filter(georgia, fips == "13121")
scaledmap <- ggplot(fulton_county, aes(x = edu)) +
  geom_scaledmap() +
  facet_wrap(~year) +
  labs(
    title = "College graduation rate in Fulton County, Georgia",
    subtitle = "Size is proportional to graduation rate. "
  ) +
  theme_dubois(base_size = 10)

ggsave("data-raw/example-plots/scaledmap.png",
  scaledmap,
  width = 7, height = 8
)

spikes <- map(1:3, function(i) {
  ymin <- 0
  ymax <- dta$heights[i + 1]

  xmin <- c(-0.3, -0.1, 0.225)[i]
  xmax <- c(-0.225, -0.025, 0.3)[i]
  trace_rect(xmin, xmax, ymin, ymax)
})

spikeplot <- ggplot() +
  geom_col(
    data = dta, aes(x = 0, y = owner, fill = year),
    position = position_stack(reverse = TRUE)
  ) +
  geom_polygon(
    data = spikes[[1]], aes(x = x, y = y),
    fill = "#4682b4", color = "grey80",
    size = 1
  ) +
  geom_polygon(
    data = spikes[[2]], aes(x = x, y = y), fill = "#ffd700", color = "grey80",
    size = 1
  ) +
  geom_polygon(
    data = spikes[[3]], aes(x = x, y = y), fill = "#dc143c", color = "grey80",
    size = 1
  ) +
  coord_polar() +
  scale_fill_manual(values = c("black", "#4682b4", "#ffd700", "#dc143c")) +
  labs(
    title = "Homeownership in Georgia steadily increases", # nolint
  ) +
  theme_dubois()
ggsave("data-raw/example-plots/spikeplots.png",
  spikeplot,
  width = 8, height = 8
)

spiralplot <- ggplot(dta) +
  geom_spiral(aes(x = year, y = median_income, color = year), size = 5) +
  labs(title = "Median income in Georgia, 1980-2000.") +
  coord_polar() +
  theme_dubois() +
  scale_color_dubois()

ggsave("data-raw/example-plots/spiral.png", spiralplot, width = 8, height = 8)

rects <- tribble(
  ~xmin, ~xmax, ~ymin, ~ymax, ~year,
  1970, 1975, 0, 10000, 1970,
  1980, 1985, 0, 12784, 1980,
  1990, 1995, 0, 23354, 1990,
  2000, 2005, 0, 25000, 2000,
  2000, 2012, 22000, 25000, 2000, # connector segment
  2007, 2012, 25000 - (34563 - 25000), 25000, 2000
) %>% mutate(year = as.factor(year))

wrappedbar <- ggplot(rects) +
  ggplot2::geom_rect(aes(
    xmin = xmin, xmax = xmax,
    ymin = ymin, ymax = ymax,
    fill = year
  )) +
  labs(
    title = "Median income in Georgia, 1970 - 2000"
  ) +
  theme_dubois() +
  scale_fill_dubois()
ggsave("data-raw/example-plots/wrappedbar.png", wrappedbar,
  width = 8, height = 8
)

income <- tribble(
  ~xmin, ~xmax, ~ymax,
  1970, 1975, 10000,
  1980, 1985, 12784,
  1990, 1995, 23354,
  2000, 2005, 34563,
) %>% mutate(
  variable = "income", ymin = 0,
  across(c(xmin, xmax), ~ (. - 2.5))
)

rescaler <- function(x, newMin, newMax) {
  (newMax - newMin) / (max(x) - min(x)) * (x - min(x)) + newMin
}

# payroll axes need to be interpolated to match the income y-axis
dta$total_payroll[1] <- 10649388000
width <- diff(range(income$ymax)) / 10
payroll <- tibble(
  xmin = min(income$xmin),
  xmax = rescaler(
    dta$total_payroll, min(income$xmin) + 4,
    max(income$xmax)
  ) + 5, # force some intersections as an example
  ymin = rescaler(
    income$xmin, min(income$ymin),
    max(income$ymax - 2.5 * width)
  ),
  ymax = rescaler(
    income$xmax, min(income$ymin),
    max(income$ymax - 2.5 * width)
  ) + width,
  variable = "payroll"
) %>% mutate(xmax = pmin(xmax, max(income$xmax + 2)))

intersects <- tribble(
  ~xmin, ~xmax, ~ymin, ~ymax, ~variable,
  1967.25, 1972.5, min(payroll$ymax), min(income$ymax), "income",
  1997.5, 2002.5, min(income$ymin), max(income$ymax), "income"
)
wovenbar_data <- bind_rows(income, payroll, intersects)
wovenbar <- ggplot(wovenbar_data, aes(
  xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = variable
)) +
  geom_rect(color = "grey80", size = 1) +
  scale_fill_dubois() +
  labs(
    title = "Income and payroll in Georgia, 1970 - 2000",
    subtitle = "Length of bars is proportional to value",
    fill = NULL
  ) +
  scale_y_continuous(
    breaks = c(width / 2, 10000, 20000, 30000),
    labels = c(1970, 1980, 1990, 2000)
  ) +
  theme_dubois(base_size = 16, style = "regular")

ggsave("data-raw/example-plots/wovenbar.png", wovenbar,
  width = 8, height = 8
)

geom_straight <- function(mapping = NULL, data = NULL,
                          stat = "identity", position = "identity",
                          ...,
                          lineend = "butt",
                          linejoin = "round",
                          linemitre = 10,
                          arrow = NULL,
                          na.rm = FALSE,
                          show.legend = NA,
                          inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomStraight,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      lineend = lineend,
      linejoin = linejoin,
      linemitre = linemitre,
      arrow = arrow,
      na.rm = na.rm,
      ...
    )
  )
}

GeomStraight <- ggproto("GeomStraight", GeomPath,
  draw_panel = function(data, panel_params, coord, arrow = NULL,
                        lineend = "butt", linejoin = "round", linemitre = 10,
                        na.rm = FALSE) {
    if (!anyDuplicated(data$group)) {
      ggplot2:::message_wrap(
        "geom_path: Each group consists of only one observation. ",
        "Do you need to adjust the group aesthetic?"
      )
    }
    # must be sorted on group
    data <- data[order(data$group), , drop = FALSE]
    munched <- coord$transform(data, panel_params)

    # Silently drop lines with less than two points, preserving order
    rows <- stats::ave(seq_len(nrow(munched)), munched$group, FUN = length)
    munched <- munched[rows >= 2, ]
    if (nrow(munched) < 2) {
      return(zeroGrob())
    }

    # Work out whether we should use lines or segments
    attr <- ggplot2:::dapply(munched, "group", function(df) {
      linetype <- unique(df$linetype)
      ggplot2:::new_data_frame(list(
        solid = identical(linetype, 1) || identical(linetype, "solid"),
        constant = nrow(unique(df[, c("alpha", "colour", "size", "linetype")])) == 1
      ), n = 1)
    })
    solid_lines <- all(attr$solid)
    constant <- all(attr$constant)

    # Work out grouping variables for grobs
    n <- nrow(munched)
    group_diff <- munched$group[-1] != munched$group[-n]
    start <- c(TRUE, group_diff)
    end <- c(group_diff, TRUE)

    if (!constant) {
      grid::segmentsGrob(
        munched$x[!end], munched$y[!end], munched$x[!start], munched$y[!start],
        default.units = "native", arrow = arrow,
        gp = grid::gpar(
          col = alpha(munched$colour, munched$alpha)[!end],
          fill = alpha(munched$colour, munched$alpha)[!end],
          lwd = munched$size[!end] * .pt,
          lty = munched$linetype[!end],
          lineend = lineend,
          linejoin = linejoin,
          linemitre = linemitre
        )
      )
    } else {
      id <- match(munched$group, unique(munched$group))
      grid::polylineGrob(
        munched$x, munched$y,
        id = id,
        default.units = "native", arrow = arrow,
        gp = grid::gpar(
          col = alpha(munched$colour, munched$alpha)[start],
          fill = alpha(munched$colour, munched$alpha)[start],
          lwd = munched$size[start] * .pt,
          lty = munched$linetype[start],
          lineend = lineend,
          linejoin = linejoin,
          linemitre = linemitre
        )
      )
    }
  },
  draw_key = draw_key_path
)

total_pop <- demographics %>%
  mutate(pop_ntile = ntile(total_pop, 4)) %>%
  group_by(pop_ntile) %>%
  summarize(total_pop = sum(total_pop, na.rm = T)) %>%
  drop_na() %>%
  arrange(total_pop)

top_pop <- total_pop[4, ]


# coord_polar definitely differs from how i learned polar coords
points <- tribble(
  ~theta, ~r,
  0, 0,
  (0.1), 1e07,
)
segments <- tribble(
  ~x, ~y,
  0, 0,
  0.9, 2,
  0.05, 3,
  0.95, 4,
  0.1, 5
) %>%
  mutate(
    x = x * 1.38e08, y = y * 1e07 * 3,
    x1 = lead(x), y1 = lead(y)
  ) %>%
  drop_na()

colors <- dubois_pal()[c(
  "red", "gold", "blue", "green"
)]
geoms <- map(seq_len(nrow(segments)), function(i) {
  segment <- segments[i, ]
  path <- tibble(
    x = c(segment$x, segment$x1),
    y = c(segment$y, segment$y1),
    quartile = i
  )
  print(path)
  geom_straight(
    data = path, size = 3, color = colors[i],
    aes(x = x, y = y)
  )
})

pathspiral <- ggplot() +
  geom_spiral(
    data = top_pop, aes(x = pop_ntile, y = total_pop), size = 3,
    color = dubois_pal()[2]
  ) +
  geoms +
  coord_polar(direction = -1) +
  labs(
    title = "Population in US counties, by quartile",
    subtitle = "A work in progress",
  ) +
  theme_dubois(base_size = 7)

ggsave("data-raw/example-plots/pathspiral.png",
  pathspiral,
  height = 4, width = 4
)

# square
ggplot(georgia, aes(x = year, y = percent_population, fill = occupation)) +
  geom_wrappedbar()

black <- dta %>%
  mutate(x = as.numeric(year), y = black) %>%
  select(x, y)
black_polygon <- black %>%
  bind_rows(tibble(x = 1970, y = 0), ., tibble(x = 2000, y = 0))
asian <- black %>%
  arrange(desc(x)) %>%
  bind_rows(transmute(dta, x = as.numeric(year), y = asian + black))
white <- asian %>%
  slice_tail(n = 4) %>%
  arrange(desc(x)) %>%
  bind_rows(transmute(dta, x = as.numeric(year), y = asian + black + white))
other <- white %>%
  slice_tail(n = 4) %>%
  arrange(desc(x)) %>%
  bind_rows(transmute(dta, x = as.numeric(year), y = asian + black + white + other))
top <- black %>%
  bind_rows(tibble(x = 1970, y = 1), ., tibble(x = 2000, y = 1))
square_list <- list(black_polygon, asian, white, other)
square <- map(1:4, function(i) {
  color <- dubois_divergent[-1][i]
  geom_polygon(data = square_list[[i]], fill = color, mapping = aes(x, y))
})
square_plot <- ggplot(mapping = aes(x, y)) +
  square +
  labs(
    title = "Population of Georgia by race, 1970 - 2000"
  ) +
  theme_dubois(style = "canvas") +
  theme(axis.text.x = element_text(size = 14))
ggsave("data-raw/example-plots/square.png", square_plot, height = 8, width = 8)

# dubois_pal
dubois_pal(4)
# but can return a sequential color scale, e.g. with colors on a continuum
dubois_pal(10, type = "sequential")

# Usage:
ggplot(georgia, aes(x = median_income, y = edu)) +
  geom_point() +
  scale_color_gradientn(colors = dubois_pal(10))
# the above is equivalent to the slightly more conveient syntax of:
ggplot(georgia, aes(x = median_income, y = edu)) +
  geom_point() +
  scale_color_dubois()

pal_view <- tibble(
  colors = dubois_divergent,
  names = paste0(names(dubois_divergent), " ", colors),
) %>%
  mutate(names = factor(names, levels = names)) %>%
  ggplot(aes(fill = colors)) +
  geom_rect(xmin = 0, ymin = 0, xmax = 1, ymax = 1) +
  scale_fill_identity() +
  facet_wrap(~names) +
  labs(
    title = "`dubois_divergent`",
    subtitle = "A Du Bois-inspired divergent color palette."
  ) +
  theme_dubois() +
  theme(
    strip.text = element_text(size = 10),
    strip.background = element_rect(fill = NA),
    plot.background = element_rect(fill = "white")
  )

ggsave("data-raw/example-plots/pal_view.png",
  plot = pal_view, width = 9, height = 8
)