US Presidential Elections: Seven Major Polling-Based Forecasts

chart_usa_election_forecast_models.r

# Load required libraries
library(ggplot2)
library(ggrepel)
library(grid)
library(dplyr)
library(magick)
library(gridExtra)

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

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

# Create the data frame with absolute forecast differences
data <- tibble(
  Model = c(
    "538",
    "Economist",
    "Princeton",
    "270toWin",
    "RCP",
    "RaceToWH",
    "SilverBulletin"
  ),
  Difference = c(
    49 - 50,
    ((262 / 276) - 1) * 100,
    (((538 - 265) / 265) - 1) * 100,
    ((268 / 251) - 1) * 100,
    ((287 / 251) - 1) * 100,
    ((262.6 / 275.4) - 1) * 100,
    49.6 - 50.0
  )
) |>
  mutate(Favor = ifelse(Difference > 0, "Trump", "Harris"))

# Calculate the average absolute difference
avg_difference <- median(data$Difference)

# Create the lollipop chart
p <- ggplot(data, aes(x = Model, y = Difference)) +
  geom_segment(aes(x = Model, xend = Model, y = 0, yend = Difference),
    color = "gray", size = 1
  ) +
  geom_hline(
    yintercept = avg_difference, linetype = "dashed",
    color = "gray", size = 0.5
  ) +
  geom_hline(
    yintercept = 0, linetype = "solid",
    color = "black", size = 0.5
  ) +
  geom_point(aes(color = Favor), size = 8) +
  geom_text(aes(label = abs(round(Difference, 1))),
    color = "white", size = 3.5
  ) +
  scale_color_manual(
    values = c("Harris" = "#00ba38", "Trump" = "#f8766d"),
    guide = "none"
  ) +
  annotate(
    "text",
    x = 8, y = avg_difference,
    label = paste0("Median: ", abs(round(avg_difference, 1)), "%"),
    color = "black", hjust = -.2, vjust = 2
  ) +
  labs(
    title = "US Presidential Elections: Seven Major Polling-Based Forecasts",
    subtitle = paste(
      "Absolute forecast differences",
      "Updated: 11/5/2024 10:00 AM EDT",
      "@USMortality",
      sep = " · "
    ),
    y = "Lead"
  ) +
  scale_y_continuous(labels = scales::percent_format(scale = 1)) +
  coord_flip() +
  theme_minimal()

# Load and resize the images using magick
img_trump <- image_read(
  "https://www.economist.com/interactive/us-2024-election/Donald%20Trump.png"
)
img_harris <- image_read(
  "https://www.economist.com/interactive/us-2024-election/Kamala%20Harris.png"
)

# Convert the images to grobs
grob_trump <- rasterGrob(as.raster(img_trump))
grob_harris <- rasterGrob(as.raster(img_harris))

png("chart1.png", width, height, res = 72 * sf)
grid.arrange(
  grob_harris, p, grob_trump,
  ncol = 3, widths = c(1, 5, 1)
)
dev.off()

# Betting Markets
# Create the data frame with absolute forecast differences
data <- tibble(
  Model = c(
    "Smarkets",
    "Polymarket",
    "PredictIt",
    "Kalshi"
  ),
  Difference = c(
    60.24 - 39.68,
    62.8 - 37.3,
    57 - 50,
    58 - 42
  )
) |>
  mutate(Favor = ifelse(Difference > 0, "Trump", "Harris"))

# Calculate the average absolute difference
avg_difference <- median(data$Difference)

# Create the lollipop chart
p <- ggplot(data, aes(x = Model, y = Difference)) +
  geom_segment(aes(x = Model, xend = Model, y = 0, yend = Difference),
    color = "gray", size = 1
  ) +
  geom_hline(
    yintercept = avg_difference, linetype = "dashed",
    color = "gray", size = 0.5
  ) +
  geom_hline(
    yintercept = 0, linetype = "solid",
    color = "black", size = 0.5
  ) +
  geom_point(aes(color = Favor), size = 8) +
  geom_text(aes(label = abs(round(Difference, 0))),
    color = "white", size = 3.5
  ) +
  scale_color_manual(
    values = c("Harris" = "#00ba38", "Trump" = "#f8766d"),
    guide = "none"
  ) +
  annotate(
    "text",
    x = 5, y = avg_difference,
    label = paste0("Median: ", abs(round(avg_difference, 1)), "%"),
    color = "black", hjust = -.1, vjust = 2
  ) +
  labs(
    title = "US Presidential Elections: Four Major Betting-Based Odds",
    subtitle = paste(
      "Absolute forecast differences",
      "Updated: 11/5/2024 10:00 AM EDT",
      "@USMortality",
      sep = " · "
    ),
    y = "Lead"
  ) +
  scale_y_continuous(labels = scales::percent_format(scale = 1)) +
  coord_flip() +
  theme_minimal()

# Load and resize the images using magick
img_trump <- image_read(
  "https://www.economist.com/interactive/us-2024-election/Donald%20Trump.png"
)
img_harris <- image_read(
  "https://www.economist.com/interactive/us-2024-election/Kamala%20Harris.png"
)

# Convert the images to grobs
grob_trump <- rasterGrob(as.raster(img_trump))
grob_harris <- rasterGrob(as.raster(img_harris))

png("chart2.png", width, height, res = 72 * sf)
grid.arrange(
  grob_harris, p, grob_trump,
  ncol = 3, widths = c(1, 5, 1)
)
dev.off()