Democratic & Republican Votes as Percentage of Voting Eligible Population [USA]

chart_usa_elections_president_percentage_eligible_d_r.r

# Required libraries
library(ggplot2)
library(dplyr)
library(tsibble)
library(fable)
library(feasts)
library(readr)

sf <- 2
width <- 600 * sf
height <- 335 * sf

options(vsc.dev.args = list(width = width, height = height, res = 72 * sf))

# Original data (1976-2020)
votes_data <- data.frame(
  year = c(
    1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012, 2016, 2020
  ),
  dem_votes = c(
    40831881, 35480115, 37577352, 41809074,
    44909806, 47401185, 50999897, 59028444,
    69498516, 65915795, 65853514, 81283501
  ),
  rep_votes = c(
    39241665, 43643801, 54255263, 48746241,
    39446724, 39445724, 50456002, 62039788,
    59694844, 60377809, 62984344, 74216440
  )
)

# Add 2024 estimates
el_data <- read_csv("https://election.lab.ufl.edu/data-downloads/turnoutdata/Turnout_1980_2022_v1.1.csv") |>
  filter(STATE == "United States", YEAR %in% votes_data$year) |>
  select(YEAR, VEP) |>
  setNames(c("year", "eligible_population"))

df <- votes_data |>
  inner_join(el_data, by = join_by(year)) |>
  add_row(
    year = 2024,
    dem_votes = 74335753,
    rep_votes = 78068902,
    eligible_population = 245741673
  ) |>
  mutate(
    dem_votes_pct = dem_votes / eligible_population,
    rep_votes_pct = rep_votes / eligible_population,
    votes_pct = (dem_votes + rep_votes) / eligible_population
  )


# Plot normalized votes

# Convert to tsibble for forecasting
ts <- df |> as_tsibble(index = year)

# Fit models with trend component
fit <- ts |>
  filter(year < 2020) |>
  model(TSLM(votes_pct ~ trend()))

# Forecast for 2020 and 2024 with 95% prediction intervals
fc <- fit |>
  forecast(h = 2) |>
  fabletools::hilo(95) |>
  fabletools::unpack_hilo(cols = "95%") |>
  mutate(party = "D+R") |>
  as_tibble()

# Plot normalized votes with forecast and ribbon
chart <- ggplot(ts, aes(x = year)) +
  # Historical data
  geom_line(aes(y = votes_pct), size = 1.2) +
  geom_point(aes(y = votes_pct), size = 3) +
  # Forecast ribbons
  geom_ribbon(
    data = fc,
    aes(ymin = `95%_lower`, ymax = `95%_upper`),
    alpha = 0.2
  ) +
  # Forecasted lines
  geom_line(
    data = fc,
    aes(y = .mean),
    linetype = "dashed", size = 1.2
  ) +
  labs(
    title = "Democratic & Republican Votes as Percentage of Voting Eligible Population",
    subtitle = "95% Prediction Interval of 1976-2016",
    x = "Year", y = "Percentage of Voting Eligible Population"
  ) +
  scale_y_continuous(labels = scales::percent) +
  theme_bw()

ggsave(
  filename = "chart1.png", plot = chart, width = width, height = height,
  units = "px", dpi = 72 * sf, device = grDevices::png, type = "cairo"
)