The New York Times had a [tragic] story on Covid deaths today and one of their plots really stuck with me for how well it told that part of the story.
NOTE: The red panel highlights are off a bit as I manually typed the data in (I only did the recreation to keep {ggplot2} muscle memory as I hadn’t doe a major customization like this in quite some time).
Only one {grid} hack (for the faceted X axis labels) too!
Hopefully, I’ll have more real-world opportunity to build some detailed, properly-annotated {ggplot2} plots this year.
Shout out to @ClausWilke for {ggtext} and all the folks who’ve made {ggplot2} such a powerful data visualization tool.
library(grid)
library(gtable)
library(hrbrthemes)
library(tidyverse)
gtable_filter_remove <- function (x, name, trim = FALSE) {
# https://stackoverflow.com/a/36780639
matches <- !(x$layout$name %in% name)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
if (trim)
x <- gtable_trim(x)
x
}
read.csv(text="race,age_group,before,after,cause
White,Under 25,1,3,Covid-19 deaths increased as a share of deaths from all cause
White,25-44,3,10,Covid-19 deaths increased as a share of deaths from all cause
White,45-64,8,15,Covid-19 deaths increased as a share of deaths from all cause
White,65-84,13,11,NA
White,85+,14,6,NA
Hispanic,Under 25,3,4,Covid-19 deaths increased as a share of deaths from all cause
Hispanic,25-44,17,21,Covid-19 deaths increased as a share of deaths from all cause
Hispanic,45-64,33,26,NA
Hispanic,65-84,33,17,NA
Hispanic,85+,21,9,NA
Black,Under 25,1,3,Covid-19 deaths increased as a share of deaths from all cause
Black,25-44,7,13,Covid-19 deaths increased as a share of deaths from all cause
Black,45-64,15,17,Covid-19 deaths increased as a share of deaths from all cause
Black,65-84,20,12,Covid-19 deaths increased as a share of deaths from all cause
Black,85+,17,8,NA
Asian,Under 25,2,4,Covid-19 deaths increased as a share of deaths from all cause
Asian,25-44,12,14,Covid-19 deaths increased as a share of deaths from all cause
Asian,45-64,21,13,NA
Asian,65-84,23,8,NA
Asian,85+,17,4,NA") -> xdf
xdf %>%
mutate(
before = before/100,
after = after/100,
age_group = fct_inorder(age_group),
race = factor(race, levels = rev(c("Asian", "Black", "Hispanic", "White")))
) -> xdf
{
ggplot( data = xdf) +
geom_rect(
data = xdf,
aes(
xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf,
fill = cause
),
alpha = 1/6, color = NA
) +
geom_rect(
data = xdf %>%
filter(
(race == "White" & age_group %in% c("65-84", "85+")) |
(race == "Hispanic" & age_group %in% c("45-64", "65-84", "85+")) |
(race == "Black" & age_group %in% c("85+")) |
(race == "Asian" & age_group %in% c("45-64", "65-84", "85+"))
),
aes(
xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf
),
fill = "#999999", alpha = 1/6, color = NA
) +
geom_segment(
aes(-Inf, xend = Inf, -Inf, yend= -Inf),
size = 0.25, color = "black"
) +
geom_segment(
data = xdf, aes("1", before, xend="2", yend=after),
size = 0.25
) +
geom_point(
data = xdf, aes("1", before),
fill = "#999999", color = "white", size = 2, stroke = 0.5, shape = 21
) +
geom_point(
data = xdf, aes("2", after),
fill = "#bb271a", color = "white", size = 2, stroke = 0.5, shape = 21
) +
geom_text(
data = xdf,
aes("1", before+0.05, label = scales::percent(before, 1)),
color = "#999999", family = font_es_bold, fontface = "bold", size = 3
) +
geom_text(
data = xdf,
aes("2", after+0.05, label = scales::percent(after, 1)),
color = "#bb271a", family = font_es_bold, fontface = "bold", size = 3
) +
scale_x_discrete(
expand = c(0, 0),
labels = c("<span style='color:#999999'>BEFORE</span>", "<span style='color:#bb271a'>AFTER</a>")
) +
scale_y_percent(
limits = c(-0.005, 0.405),
breaks = c(-0.005, 0.1, 0.2, 0.3, 0.405),
labels = c("", "", "", "", "40%\nof deaths from\nall causes for\nthis group")
) +
scale_fill_manual(
name = NULL,
values = c("#bb271a"),
na.translate = FALSE
) +
coord_cartesian(clip = "off") +
facet_wrap(
facets = race~age_group,
scales = "free_x",
labeller = \(labels, multi_line = TRUE){
labels <- lapply(labels, as.character)
labels[["race"]][c(1,2,4,5,6,7,9,10,11,12,14,15,16,17,19,20)] <- ""
labels[["age_group"]] <- sprintf("<span style='font-style:normal;font-weight:normal;'>%s</span>", labels[["age_group"]])
labels[["race"]][c(3,8,13,18)] <- sprintf("<span style='font-size:12pt;'>**%s**</span>", labels[["race"]][c(3,8,13,18)])
labels
}
) +
labs(
x = NULL, y = NULL,
title = "Covid-19 deaths <span style='color:#999999'>before</span> and <span style='color:#bb271a'>after</span> universal adult vaccine eligibility",
caption = "Source: Provisional weekly death data from the C.D.C. through Nov. 27. Note: Only the four largest racial and ethnic groups are included. Universal vaccine eligibility was April 19, the date when all adults in the United States were eligible for vaccination."
) +
theme_ipsum_es(grid="Y", plot_title_size = 16) +
theme(
plot.title.position = "plot",
plot.title = ggtext::element_markdown(hjust = 0.5),
plot.caption = ggtext::element_textbox_simple(
hjust = 0, size = 8.5, family = font_es, color = "#999999",
margin = margin(t = 14)
),
axis.ticks.x.bottom = ell(size = 0.25) ,
axis.line.x.bottom = ell(lineend = "square", size = 0.25),
axis.text.x.bottom = ggtext::element_markdown(size = 8, margin = margin(t = 6)),
axis.text.y.left = elt(size = 8, vjust = 1, lineheight = 0.875, color = "#999999"),
strip.text.x = ggtext::element_markdown(hjust = 0.5, size = 10, family = font_es),
strip.text = ggtext::element_markdown(hjust = 0.5, size = 10, family = font_es),
panel.spacing.x = unit("40", "pt"),
panel.spacing.y = unit(6, "pt"),
panel.border = elb(),
legend.position = "top"
) -> gg
grid.newpage()
grid.draw(
gtable_filter_remove(
x = ggplotGrob(gg),
name = c(sprintf("axis-b-%d-1", 2:5), sprintf("axis-b-%d-2", 2:5), sprintf("axis-b-%d-3", 2:5), sprintf("axis-b-%d-4", 2:5))
)
)
}
