Data608_Story3
2026-03-11
Data 608 : Story 3
DO STRICTER FIREARM LAWS REDUCE MORTALITY?
PAL <- list(
bg = "#0F1923",
panel = "#182533",
grid = "#1E3042",
text = "#E8DCC8",
subtext = "#8A9BAD",
mortality = "#C0392B",
mortality_lo = "#E8A090",
strict = "#1ABC9C",
strict_lo = "#A8E6DC",
accent = "#F39C12",
neutral = "#4A6278"
)
# Mortality colors
MORT_BINS <- c("#F4C2B8", "#E88A7A", "#D4523C", "#B82818", "#7A0A04")
MORT_LABS <- c("Very Low", "Low", "Moderate", "High", "Very High")
# Law colors
LAW_BINS <- c("#C8F0EA", "#7ED8CC", "#35B8A6", "#1A8A7A", "#0A5248")
LAW_LABS <- c("1 · Very Lax", "2 · Lax", "3 · Moderate",
"4 · Strict", "5 · Very Strict")
FONT_TITLE <- "Georgia"
FONT_BODY <- "Courier"
theme_firearm <- function(base_size = 12) {
theme_minimal(base_size = base_size) %+replace%
theme(
plot.background = element_rect(fill = PAL$bg, color = NA),
panel.background = element_rect(fill = PAL$panel, color = NA),
panel.grid.major = element_line(color = PAL$grid, linewidth = 0.4),
panel.grid.minor = element_blank(),
plot.title = element_text(family = FONT_TITLE, face = "bold",
color = PAL$text, size = base_size * 1.5,
margin = margin(b = 6)),
plot.subtitle = element_text(family = FONT_BODY, color = PAL$subtext,
size = base_size * 0.9,
margin = margin(b = 12)),
plot.caption = element_text(family = FONT_BODY, color = PAL$subtext,
size = base_size * 0.7, hjust = 1),
axis.title = element_text(family = FONT_BODY, color = PAL$subtext,
size = base_size * 0.85),
axis.text = element_text(family = FONT_BODY, color = PAL$subtext,
size = base_size * 0.8),
legend.background = element_rect(fill = PAL$panel, color = NA),
legend.text = element_text(family = FONT_BODY, color = PAL$subtext),
legend.title = element_text(family = FONT_BODY, color = PAL$text,
face = "bold"),
legend.key = element_rect(fill = PAL$panel, color = NA),
plot.margin = margin(16, 20, 12, 16),
strip.text = element_text(family = FONT_BODY, color = PAL$text,
face = "bold")
)
}Data wrangling
firearm_raw <- read_csv("Provisional Mortality Statistics, 2018 through Last Week.csv")
firearm <- firearm_raw %>%
select(state = "Residence State", rate = "Crude Rate") %>%
mutate(state_abbr = state.abb[match(state, state.name)]) %>%
filter(!is.na(state_abbr), !is.na(rate))
gun_laws <- read_csv("state_gun_law_strictness.csv")
combined <- firearm %>%
left_join(gun_laws, by = "state") %>%
filter(!is.na(law_numeric), !is.na(rate)) %>%
mutate(
likert_label = case_when(
law_score == 1 ~ "1 · Very Lax",
law_score == 2 ~ "2 · Lax",
law_score == 3 ~ "3 · Moderate",
law_score == 4 ~ "4 · Strict",
law_score == 5 ~ "5 · Very Strict",
TRUE ~ as.character(law_score)
),
likert_label = factor(likert_label, levels = LAW_LABS),
mort_bin = cut(rate,
breaks = quantile(rate, probs = seq(0, 1, 0.2), na.rm = TRUE),
labels = MORT_LABS,
include.lowest = TRUE),
mort_bin = factor(mort_bin, levels = MORT_LABS)
)
# State label centers (base R — no maps:: prefix needed)
state_centers <- tibble(
state_abbr = state.abb,
x = state.center$x,
y = state.center$y
)Heatmap : Mortality
us_states <- map_data("state") %>% mutate(state = str_to_title(region))
map_data_full <- us_states %>% left_join(combined, by = "state")
p2 <- ggplot(map_data_full, aes(long, lat, group = group)) +
geom_polygon(aes(fill = mort_bin), color = PAL$bg, linewidth = 0.25) +
geom_text(
data = combined %>% left_join(state_centers, by = "state_abbr"),
aes(x = x, y = y, label = state_abbr, group = NULL),
color = PAL$bg, size = 2.2, fontface = "bold", family = FONT_BODY
) +
coord_map("albers", lat0 = 30, lat1 = 45) +
scale_fill_manual(
values = setNames(MORT_BINS, MORT_LABS),
name = "Mortality\nLevel",
drop = FALSE,
na.translate = FALSE
) +
labs(
title = "Firearm Deaths Cluster in the South East and North Mountain West",
subtitle = "The pattern is geographic, not random."
) +
theme_firearm(base_size = 13) +
theme(axis.text = element_blank(),
axis.title = element_blank(),
panel.grid = element_blank())
ggsave("slide2_mortality_map.png", p2,
width = 11, height = 6.5, dpi = 180, bg = PAL$bg)
message("✓ Slide 2 saved")
p2
Heatmap : Law score
p3 <- ggplot(map_data_full, aes(long, lat, group = group)) +
geom_polygon(aes(fill = likert_label), color = PAL$bg, linewidth = 0.25) +
geom_text(
data = combined %>% left_join(state_centers, by = "state_abbr"),
aes(x = x, y = y, label = state_abbr, group = NULL),
color = PAL$bg, size = 2.2, fontface = "bold", family = FONT_BODY
) +
coord_map("albers", lat0 = 30, lat1 = 45) +
scale_fill_manual(
values = setNames(LAW_BINS, LAW_LABS),
name = "Law\nStrictness",
drop = FALSE,
na.translate = FALSE
) +
labs(
title = "The Highest deaths occur where Laws Are Most Lenient",
subtitle = "Compare with the previous map — the inverse geographic pattern is striking."
) +
theme_firearm(base_size = 13) +
theme(axis.text = element_blank(),
axis.title = element_blank(),
panel.grid = element_blank())
ggsave("slide3_law_map.png", p3,
width = 11, height = 6.5, dpi = 180, bg = PAL$bg)
message("✓ Slide 3 saved")
p3
Butterfly bar
n <- 5
bottom5 <- combined %>% arrange(law_numeric) %>% slice_head(n = n)
top5 <- combined %>% arrange(desc(law_numeric)) %>% slice_head(n = n)
butterfly <- bind_rows(
bottom5 %>% mutate(group = "5 Most Lax"),
top5 %>% mutate(group = "5 Strictest")
) %>%
arrange(rate) %>%
mutate(
state = factor(state, levels = rev(unique(state))),
mort_neg = -rate,
strict_pos = rescale(law_numeric,
to = c(1, max(rate, na.rm = TRUE) * 0.6))
)
x_breaks <- seq(-25, 25, by = 5)
p4 <- ggplot(butterfly, aes(y = state)) +
geom_col(aes(x = mort_neg), fill = PAL$mortality, width = 0.65, alpha = 0.9) +
geom_col(aes(x = strict_pos), fill = PAL$strict, width = 0.65, alpha = 0.9) +
geom_vline(xintercept = 0, color = PAL$text, linewidth = 0.6) +
geom_text(aes(x = mort_neg - 0.5, label = sprintf("%.1f", rate)),
hjust = 1, size = 2.8, family = FONT_BODY, color = PAL$text) +
geom_text(aes(x = strict_pos + 0.5, label = sprintf("%.1f", law_numeric)),
hjust = 0, size = 2.8, family = FONT_BODY, color = PAL$text) +
scale_x_continuous(
breaks = x_breaks,
labels = abs(x_breaks),
limits = c(min(butterfly$mort_neg) * 1.25,
max(butterfly$strict_pos) * 1.25)
)+
annotate("text", x = -18, y = n + 1.8,
label = "← Firearm Mortality\n (per 100,000)",
hjust = 1, family = FONT_BODY,
color = PAL$mortality, size = 3.2, fontface = "bold") +
annotate("text", x = 7, y = n - 1.8,
label = "Law Strictness →\n(scaled index)",
hjust = 0, family = FONT_BODY,
color = PAL$strict, size = 3.2, fontface = "bold") +
labs(
title = "Face to Face, the Contrast Is Undeniable",
subtitle = "The 5 strictest states vs. the 5 most lax : Mortality and Law score side by side.",
y = NULL, x = NULL
) +
theme_firearm(base_size = 13) +
theme(legend.position = "none",
panel.grid.major.y = element_blank())
ggsave("slide4_butterfly.png", p4,
width = 11, height = 7.5, dpi = 180, bg = PAL$bg)
message("✓ Slide 4 saved")
p4
Scatterplot
label_states <- combined %>%
filter(
state_abbr %in% c("MA", "NY", "CT","CA", "IL","ID", "SD", "AR", "MT", "MS")
)
p1 <- ggplot(combined, aes(x = law_numeric, y = rate)) +
geom_smooth(method = "lm", se = TRUE,
color = PAL$accent,
fill = PAL$accent,
alpha = 0.15,
linewidth = 1.2) +
geom_point(shape = 21, size = 4,
fill = PAL$neutral,
color = PAL$bg,
stroke = 0.5, alpha = 0.9) +
geom_label_repel(data = label_states,
aes(label = state_abbr),
family = FONT_BODY,
size = 3,
color = PAL$text,
fill = PAL$panel,
label.padding = unit(0.2, "lines"),
label.size = 0.3,
box.padding = 0.5,
max.overlaps = 20) +
labs(
title = "A Clear Pattern: Stricter Laws, Fewer Deaths",
subtitle = "Each point is a U.S. state. The trend is consistent across the full spectrum of gun law strictness.",
x = "Gun Law Strictness (0 - 100)",
y = "Firearm Mortality Rate (per 100,000)"
) +
theme_firearm(base_size = 13)
ggsave("slide1_scatter.png", p1,
width = 10, height = 6.5, dpi = 180, bg = PAL$bg)
message("✓ Slide 1 saved")
p1
Split bars
likert_summary <- combined %>%
group_by(likert_label) %>%
summarise(avg_rate = mean(rate, na.rm = TRUE),
n_states = n(),
.groups = "drop")
combined_ord <- combined %>%
arrange(likert_label, rate) %>%
group_by(likert_label) %>%
mutate(rank_in_group = row_number()) %>%
ungroup()
p5 <- ggplot(combined_ord, aes(x = likert_label, y = rate)) +
# tinted column background — law strictness hue per column
geom_tile(data = likert_summary,
aes(x = likert_label, y = avg_rate, fill = likert_label),
width = 0.88, height = max(combined$rate) * 1.1,
alpha = 0.18, inherit.aes = FALSE) +
# individual state dots — uniform color; y-position carries the story
geom_jitter(width = 0.18, size = 3.5, alpha = 0.80, stroke = 0,
color = PAL$text) +
# group average crossbar
geom_crossbar(data = likert_summary,
aes(x = likert_label, y = avg_rate,
ymin = avg_rate, ymax = avg_rate),
color = PAL$accent, linewidth = 0.9, width = 0.55,
fatten = 0, inherit.aes = FALSE) +
# avg label
geom_label(data = likert_summary,
aes(x = likert_label, y = avg_rate,
label = sprintf("avg %.1f", avg_rate)),
nudge_x = 0.38, size = 3, family = FONT_BODY,
fill = PAL$panel, color = PAL$accent,
label.size = 0.2, inherit.aes = FALSE) +
# n = X count at bottom
geom_text(data = likert_summary,
aes(x = likert_label, y = -1.2,
label = paste0("n = ", n_states)),
size = 2.8, family = FONT_BODY,
color = PAL$subtext, inherit.aes = FALSE) +
scale_fill_manual(values = setNames(LAW_BINS, LAW_LABS), guide = "none") +
scale_y_continuous(expand = expansion(mult = c(0.08, 0.06))) +
labs(
title = "Not just at the extremes : Every step up the scale saves lives.",
subtitle = "Average mortality falls at each Likert level",
x = "Gun Law Strictness",
y = "Firearm Mortality Rate (per 100,000)"
) +
theme_firearm(base_size = 13) +
theme(legend.position = "none")
ggsave("slide5_heatmap_likert.png", p5,
width = 11, height = 6.5, dpi = 180, bg = PAL$bg)
message("✓ Slide 5 saved")
p5
Sources
Centers for Disease Control and Prevention, National Center for Health Statistics. National Vital Statistics System, Provisional Mortality on CDC WONDER Online Database. Data are from the final Multiple Cause of Death Files, 2018-2024, and from provisional data for years 2025 and later, as compiled from data provided by the 57 vital statistics jurisdictions through the Vital Statistics Cooperative Program. Accessed at http://wonder.cdc.gov/mcd-icd10-provisional.html on Mar 11, 2026 10:07:56 AM