The 2028 Los Angeles Summer Olympics are coming, and with them comes a massive commercial opportunity. Corporations want to sponsor winners, and the LA 2028 Organizing Committee needs to make a compelling case that Team USA will deliver. This report builds a data-driven model to forecast how many gold medals Team USA is likely to win in 2028, using historical Olympic data scraped from Olympedia.
The model accounts for three primary effects:
The model also incorporates a fourth factor: GDP per capita, which captures the relationship between national wealth and Olympic success.
This report was first published on September 29, 2026. It was republished on October 9, 2026 after an audit found data and modeling errors that changed the headline forecast. The first published forecast was 123 golds (95% interval 72 to 181). The main corrections:
Olympedia is a volunteer-run resource, so we cache every page locally after the first download. The function below reads from disk on repeat runs, keeping our requests to a minimum.
library(tidyverse)
library(rvest)
library(stringr)
library(fs)
library(purrr)
library(infer)
library(rnaturalearth)
library(rnaturalearthdata)
library(countrycode)
library(sf)
library(gt)
library(scales)
library(glue)
library(broom)
library(ggrepel)
library(httr2)
set.seed(9750)slow_download <- purrr::slowly(download.file, purrr::rate_delay(pause = 5))
read_olympedia <- function(url, ...) {
if (stringr::str_starts(url, "/")) url <- stringr::str_remove(url, "/")
cache_dir <- fs::path("data", "mp04", "olympedia_cache")
if (!fs::dir_exists(cache_dir)) fs::dir_create(cache_dir, recurse = TRUE)
cache_path <- fs::path(
cache_dir,
url |> as.character() |> stringr::str_replace_all("/", "_")
)
if (!fs::file_exists(cache_path)) {
src_url <- paste0("https://www.olympedia.org/", url)
slow_download(src_url, cache_path, mode = "wb")
}
rvest::read_html(cache_path)
}We scrape the editions page to get every Summer and Winter Olympiad since 1896, extracting the year, season, olympiad number, edition ID, and host country code from each row’s flag image URL.
parse_editions <- function() {
page <- read_olympedia("editions")
parse_one_table <- function(tbl_node, season) {
rows <- tbl_node |> html_elements("tr")
map_dfr(rows, function(row) {
links <- row |> html_elements("a") |> html_attr("href")
ed_lnk <- links |> str_subset("/editions/\\d+$") |> dplyr::first()
if (length(ed_lnk) == 0 || is.na(ed_lnk)) return(tibble())
edition_id <- str_extract(ed_lnk, "\\d+$") |> as.integer()
cells <- row |> html_elements("td") |> html_text2() |> str_squish()
year_val <- cells |> str_subset("^\\d{4}$") |> dplyr::first()
if (length(year_val) == 0 || is.na(year_val)) return(tibble())
olympiad_num <- suppressWarnings(as.integer(as.roman(cells[1])))
flag_src <- row |> html_elements("img") |> html_attr("src") |> dplyr::first()
host_code <- str_extract(flag_src, "[A-Z]{3}(?=\\.(png|svg))")
tibble(edition_id, year = as.integer(year_val), season,
olympiad_num, host_code)
})
}
all_nodes <- page |> html_elements("h3, table")
current_season <- NA_character_
results <- list()
for (node in all_nodes) {
tag <- html_name(node)
if (tag == "h3") {
txt <- node |> html_text2() |> str_squish()
current_season <- case_when(
str_detect(txt, regex("^summer$", ignore_case = TRUE)) ~ "Summer",
str_detect(txt, regex("^winter$", ignore_case = TRUE)) ~ "Winter",
TRUE ~ NA_character_
)
} else if (tag == "table" && !is.na(current_season)) {
tbl_data <- parse_one_table(node, current_season)
if (nrow(tbl_data) > 0) results <- c(results, list(tbl_data))
}
}
bind_rows(results) |>
filter(!is.na(year), year >= 1896) |>
distinct(edition_id, .keep_all = TRUE)
}
editions <- parse_editions()
# Olympedia's "Summer" list also includes the Youth Olympic Games (2010, 2014,
# 2018) and the 1906 Intercalated Games. Summer Olympics fall in years
# divisible by four, so drop everything else.
editions <- editions |>
filter(!(season == "Summer" & year %% 4 != 0))The scraper returned 69 editions covering both Summer and Winter Games. The table below summarizes coverage by season.
editions |>
filter((season == "Summer" & year <= 2024) | (season == "Winter" & year <= 2022)) |>
group_by(season) |>
summarise(
Games = n(),
`First Year` = min(year),
`Last Year` = max(year),
`Unique Hosts` = n_distinct(host_code),
.groups = "drop"
) |>
gt() |>
tab_header(
title = "Olympic Editions Scraped from Olympedia",
subtitle = "Summer Games through 2024, Winter Games through 2022"
) |>
cols_label(season = "Season") |>
tab_style(
style = cell_fill(color = "#f7f5ee"),
locations = cells_body(rows = season == "Summer")
) |>
fmt_integer(columns = c(Games, `Unique Hosts`)) |>
fmt_integer(columns = c(`First Year`, `Last Year`), use_seps = FALSE)| Olympic Editions Scraped from Olympedia | ||||
| Summer Games through 2024, Winter Games through 2022 | ||||
| Season | Games | First Year | Last Year | Unique Hosts |
|---|---|---|---|---|
| Summer | 33 | 1896 | 2024 | 20 |
| Winter | 29 | 1924 | 2022 | 13 |
For each edition page, we extract the list of medal disciplines and their Olympedia URLs. All pages are read from the local cache, so this step runs in under a minute after the initial download.
parse_sports_for_edition <- function(eid) {
page <- read_olympedia(glue("editions/{eid}"))
sport_links <- page |>
html_elements("a[href*='/sports/']") |>
html_attr("href") |>
str_subset(glue("editions/{eid}/sports/"))
sport_names <- page |>
html_elements(glue("a[href*='editions/{eid}/sports/']")) |>
html_text2() |> str_squish()
n <- min(length(sport_links), length(sport_names))
if (n == 0) return(tibble())
tibble(sport_name = sport_names[seq_len(n)],
sport_url = sport_links[seq_len(n)]) |>
distinct(sport_url, .keep_all = TRUE)
}
if (file.exists("data/mp04/sports_by_edition.rds")) {
sports_by_edition <- readRDS("data/mp04/sports_by_edition.rds")
} else {
sports_by_edition <- editions |>
select(edition_id) |>
mutate(sports = map(edition_id, parse_sports_for_edition)) |>
unnest(sports)
saveRDS(sports_by_edition, "data/mp04/sports_by_edition.rds")
}
# Cached files may pre-date these fixes, so clean them on load. Athletics can
# be listed twice on an edition page, which would double-count its medals.
sports_by_edition <- sports_by_edition |>
filter(edition_id %in% editions$edition_id) |>
distinct(edition_id, sport_url, .keep_all = TRUE)The scraper found 1,299 sport-edition combinations. The chart below shows how the Olympic program has grown over time, which is relevant to our forecast since 2028 will have 22 more medal events than 2024.
sports_by_edition |>
left_join(editions |> select(edition_id, year, season), by = "edition_id") |>
filter(season == "Summer", !is.na(year), year <= 2024) |>
group_by(year) |>
summarise(n_sports = n(), .groups = "drop") |>
ggplot(aes(x = year, y = n_sports)) +
geom_col(fill = "#1a1a2e", alpha = 0.85) +
geom_smooth(method = "loess", se = FALSE, colour = "#c9a84c",
linewidth = 1.2) +
annotate("text", x = 1916, y = 15,
label = "WWI\n(1916\ncancelled)",
colour = "grey50", size = 2.5, hjust = 0.5) +
annotate("text", x = 1942, y = 15,
label = "WWII\n(1940 & 1944\ncancelled)",
colour = "grey50", size = 2.5, hjust = 0.5) +
labs(
title = "Number of Medal Disciplines at Each Summer Olympics",
x = "Year", y = "Number of Disciplines",
caption = "Source: Olympedia. 1904 excluded due to data quality issues."
) +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"))
For each sport-edition page, we extract the country-level medal summary table. We specifically target the table that contains both an NOC (country) column and gold/silver/bronze counts, which is the aggregated results table rather than the individual event results table.
parse_medals_for_sport <- function(sport_url) {
url_clean <- str_remove(sport_url, "^/")
page <- read_olympedia(url_clean)
tables <- page |> html_elements("table")
medal_table_node <- NULL
for (tbl in tables) {
col_names <- tbl |> html_table(fill = TRUE) |> names() |> str_to_lower()
if (any(str_detect(col_names, "^noc$")) && any(str_detect(col_names, "gold"))) {
medal_table_node <- tbl
break
}
}
if (is.null(medal_table_node)) return(tibble())
medal_tbl <- medal_table_node |> html_table(fill = TRUE)
names(medal_tbl) <- names(medal_tbl) |> str_to_lower() |> str_squish()
country_codes <- medal_table_node |>
html_elements("img") |> html_attr("src") |>
str_extract("[A-Z]{3}(?=\\.(png|svg))")
medal_tbl <- medal_tbl |>
select(any_of(c("gold", "silver", "bronze", "total"))) |>
filter(if_any(everything(), ~ !is.na(.x))) |>
mutate(across(everything(), ~ suppressWarnings(as.integer(.x))))
n_rows <- nrow(medal_tbl)
medal_tbl |> mutate(country_code = country_codes[seq_len(n_rows)])
}
if (file.exists("data/mp04/medals_full.rds")) {
medals_full <- readRDS("data/mp04/medals_full.rds")
} else {
medals_raw <- sports_by_edition |>
mutate(medals = map(sport_url, parse_medals_for_sport)) |>
unnest(medals)
medals_full <- medals_raw |>
left_join(editions, by = "edition_id") |>
filter(!is.na(country_code), !is.na(gold))
saveRDS(medals_full, "data/mp04/medals_full.rds")
}
medals_full <- medals_full |>
filter(edition_id %in% editions$edition_id) |>
distinct(edition_id, sport_url, country_code, .keep_all = TRUE)The full dataset has 8,915 records. The table below shows coverage for the most recent ten Summer Olympics.
medals_full |>
filter(season == "Summer") |>
group_by(year) |>
summarise(
Countries = n_distinct(country_code),
Disciplines = n_distinct(sport_name),
.groups = "drop"
) |>
arrange(desc(year)) |>
slice_head(n = 10) |>
arrange(year) |>
gt() |>
tab_header(
title = "Medal Data Coverage: Most Recent 10 Summer Olympics",
subtitle = glue(
"Full dataset: {comma(nrow(medals_full))} records across ",
"{n_distinct(medals_full$edition_id)} editions"
)
) |>
cols_label(
year = "Year",
Countries = "Countries",
Disciplines = "Disciplines"
) |>
fmt_integer(columns = year, use_seps = FALSE) |>
fmt_integer(columns = c(Countries, Disciplines)) |>
data_color(
columns = Disciplines,
palette = c("#f7f7f7", "#1a1a2e")
)| Medal Data Coverage: Most Recent 10 Summer Olympics | ||
| Full dataset: 8,915 records across 59 editions | ||
| Year | Countries | Disciplines |
|---|---|---|
| 1988 | 52 | 30 |
| 1992 | 64 | 33 |
| 1996 | 79 | 36 |
| 2000 | 80 | 39 |
| 2004 | 74 | 39 |
| 2008 | 87 | 41 |
| 2012 | 86 | 39 |
| 2016 | 86 | 41 |
| 2020 | 93 | 49 |
| 2024 | 92 | 47 |
Olympedia uses IOC country codes that sometimes differ from ISO 3166-1 alpha-3. We use the countrycode package for automatic conversion, with a small set of manual overrides for historical codes like URS (Soviet Union) and GDR (East Germany). Per course instructions, URS is mapped to RUS to ensure continuity.
world <- rnaturalearth::ne_countries(scale = "medium", returnclass = "sf")
manual_fixes <- c(
"URS" = "RUS", "TCH" = "CZE", "YUG" = "SRB", "SCG" = "SRB",
"OAR" = NA, "ROC" = "RUS", "ANZ" = "AUS", "BOH" = "CZE",
"EUN" = "RUS", "FRG" = "DEU", "GDR" = "DEU", "TPE" = "TWN"
)
medals_clean <- medals_full |>
mutate(
iso_code = countrycode::countrycode(
sourcevar = country_code,
origin = "ioc",
destination = "iso3c",
custom_match = manual_fixes,
warn = FALSE
)
) |>
filter(!is.na(iso_code))
dropped_codes <- medals_full |>
mutate(
iso_code = countrycode::countrycode(
country_code, "ioc", "iso3c",
custom_match = manual_fixes, warn = FALSE
)
) |>
filter(is.na(iso_code)) |>
count(country_code, sort = TRUE)dropped_codes |>
gt() |>
tab_header(
title = "Country Codes Dropped During Standardization",
subtitle = "These IOC codes could not be mapped to a current ISO-3 country"
) |>
cols_label(country_code = "IOC Code", n = "Rows Affected") |>
fmt_integer(columns = n) |>
cols_width(
country_code ~ px(150),
n ~ px(150)
) |>
tab_options(table.width = px(350)) |>
tab_footnote(
footnote = paste(
"MIX = Mixed teams; IOA/AIN/EOR = Individual Olympic Athletes;",
"WIF = West Indies Federation; UAR = United Arab Republic;",
"AHO = Netherlands Antilles; KOS = Kosovo (not in ISO standard)."
),
locations = cells_title(groups = "subtitle")
)| Country Codes Dropped During Standardization | |
| These IOC codes could not be mapped to a current ISO-3 country1 | |
| IOC Code | Rows Affected |
|---|---|
| MIX | 19 |
| AIN | 5 |
| KOS | 3 |
| IOA | 2 |
| UAR | 2 |
| AHO | 1 |
| EOR | 1 |
| WIF | 1 |
| 1 MIX = Mixed teams; IOA/AIN/EOR = Individual Olympic Athletes; WIF = West Indies Federation; UAR = United Arab Republic; AHO = Netherlands Antilles; KOS = Kosovo (not in ISO standard). | |
After standardization, 8,881 records remain (down from 8,915). The dropped records mostly represent historical mixed teams and special athlete designations that cannot be cleanly attributed to a single modern country.
total_golds <- medals_clean |>
filter(season == "Summer") |>
group_by(iso_code) |>
summarise(total_gold = sum(gold, na.rm = TRUE), .groups = "drop")
world_gold <- world |>
left_join(total_golds, by = c("iso_a3" = "iso_code")) |>
mutate(total_gold = replace_na(total_gold, 0))
ggplot(world_gold) +
geom_sf(aes(fill = total_gold), colour = "white", linewidth = 0.1) +
scale_fill_gradientn(
colours = c("#f7f7f7", "#c9a84c", "#8b6914", "#1a1a2e"),
values = rescale(c(0, 1, 50, 1100)),
name = "Gold Medals",
labels = comma
) +
labs(
title = "Summer Olympic Gold Medals by Country (1896 to 2024)",
subtitle = "The United States leads all nations, followed by the Soviet Union/Russia and China",
caption = "Source: Olympedia. URS coded as RUS per course instructions."
) +
theme_void() +
theme(
plot.title = element_text(face = "bold", size = 14),
plot.subtitle = element_text(size = 10, colour = "grey40"),
legend.position = "bottom",
legend.key.width = unit(2, "cm")
)
us_summer <- medals_clean |>
filter(country_code == "USA", season == "Summer") |>
group_by(year) |>
summarise(
gold = sum(gold, na.rm = TRUE),
silver = sum(silver, na.rm = TRUE),
bronze = sum(bronze, na.rm = TRUE),
total = sum(total, na.rm = TRUE),
.groups = "drop"
)
best_year <- us_summer |> filter(year != 1904) |> slice_max(gold, n = 1)
avg_gold_us <- us_summer |> filter(year >= 1960) |> pull(gold) |> mean()Finding 1: Setting aside the anomalous 1904 St. Louis Games, Team USA’s best modern performance was in 1984 with 83 gold medals. Since 1960 the period most relevant to predicting 2028 the US has averaged 41.5 gold medals per Games, more than any other nation by a wide margin.
Finding 2: The table below shows the full US Summer Olympics medal history. The US did not compete in 1980 because of the Moscow boycott, and the 1984 spike reflects the Soviet-led boycott of Los Angeles. Both years are excluded from the inference in Task 4.
us_summer |>
arrange(desc(year)) |>
mutate(
note = case_when(
year == 1980 ~ "US boycott of Moscow",
year == 1984 ~ "Soviet bloc boycott of LA",
year == 1904 ~ "Inflated: US club teams",
TRUE ~ ""
)
) |>
gt() |>
tab_header(
title = "Team USA Summer Olympic Medal Totals",
subtitle = "All modern Summer Olympics, 1896 to 2024"
) |>
cols_label(
year = "Year", gold = "Gold", silver = "Silver",
bronze = "Bronze", total = "Total", note = "Note"
) |>
data_color(columns = gold, palette = c("white", "#c9a84c")) |>
fmt_integer(columns = year, use_seps = FALSE) |>
fmt_integer(columns = c(gold, silver, bronze, total)) |>
tab_style(
style = cell_text(color = "grey50", style = "italic"),
locations = cells_body(columns = note)
) |>
tab_style(
style = cell_fill(color = "#fff8e1"),
locations = cells_body(rows = year %in% c(1980, 1984, 1904))
)| Team USA Summer Olympic Medal Totals | |||||
| All modern Summer Olympics, 1896 to 2024 | |||||
| Year | Gold | Silver | Bronze | Total | Note |
|---|---|---|---|---|---|
| 2024 | 40 | 44 | 42 | 126 | |
| 2020 | 39 | 41 | 33 | 113 | |
| 2016 | 46 | 37 | 38 | 121 | |
| 2012 | 48 | 26 | 31 | 105 | |
| 2008 | 36 | 39 | 37 | 112 | |
| 2004 | 36 | 39 | 26 | 101 | |
| 2000 | 37 | 24 | 32 | 93 | |
| 1996 | 44 | 32 | 25 | 101 | |
| 1992 | 37 | 34 | 37 | 108 | |
| 1988 | 36 | 31 | 27 | 94 | |
| 1984 | 83 | 61 | 30 | 174 | Soviet bloc boycott of LA |
| 1976 | 34 | 35 | 25 | 94 | |
| 1972 | 33 | 31 | 30 | 94 | |
| 1968 | 45 | 28 | 34 | 107 | |
| 1964 | 36 | 26 | 28 | 90 | |
| 1960 | 34 | 21 | 16 | 71 | |
| 1956 | 32 | 25 | 17 | 74 | |
| 1952 | 40 | 19 | 17 | 76 | |
| 1948 | 38 | 27 | 19 | 84 | |
| 1936 | 24 | 21 | 12 | 57 | |
| 1932 | 44 | 36 | 30 | 110 | |
| 1928 | 22 | 18 | 16 | 56 | |
| 1924 | 45 | 27 | 27 | 99 | |
| 1920 | 41 | 27 | 27 | 95 | |
| 1912 | 26 | 19 | 19 | 64 | |
| 1908 | 23 | 12 | 12 | 47 | |
| 1904 | 80 | 85 | 83 | 248 | Inflated: US club teams |
| 1900 | 20 | 13 | 15 | 48 | |
| 1896 | 11 | 7 | 2 | 20 | |
Finding 3: The visualization below shows the raw time series with context. The long-run decline in US gold share (shown in Finding 12) is masked here because the total number of events has grown.
us_summer |>
mutate(
flag = case_when(
year == 1980 ~ "Boycott year",
year == 1984 ~ "Boycott year",
year == 1904 ~ "1904 anomaly",
gold > avg_gold_us ~ "Above average",
TRUE ~ "Below average"
)
) |>
ggplot(aes(x = year, y = gold)) +
geom_line(colour = "#1a1a2e", linewidth = 1) +
geom_point(aes(colour = flag, size = flag == "1904 anomaly")) +
geom_hline(yintercept = avg_gold_us, linetype = "dashed",
colour = "grey50", linewidth = 0.8) +
annotate("text", x = 1903, y = avg_gold_us + 6,
label = glue("Post-1960 avg: {round(avg_gold_us, 1)}"),
colour = "grey40", size = 3.5) +
scale_colour_manual(
values = c(
"Above average" = "#c9a84c", "Below average" = "#1a1a2e",
"Boycott year" = "orange", "1904 anomaly" = "grey60"
),
name = NULL
) +
scale_size_manual(values = c("TRUE" = 5, "FALSE" = 3), guide = "none") +
scale_x_continuous(breaks = seq(1896, 2024, by = 8)) +
labs(
title = "Team USA Gold Medals at Summer Olympics (1896 to 2024)",
subtitle = "Dashed line = post-1960 average",
x = "Year", y = "Gold Medals",
caption = "Source: Olympedia"
) +
theme_minimal(base_size = 12) +
theme(
plot.title = element_text(face = "bold"),
axis.text.x = element_text(angle = 45, hjust = 1),
legend.position = "top"
)
summer_totals <- medals_clean |>
filter(season == "Summer") |>
group_by(year, country_code) |>
summarise(
gold = sum(gold, na.rm = TRUE),
silver = sum(silver, na.rm = TRUE),
bronze = sum(bronze, na.rm = TRUE),
total = gold + silver + bronze,
.groups = "drop"
)
summer_hosts <- editions |>
filter(season == "Summer") |>
arrange(year) |>
select(year, host_code)
# Hosts that already won at least this many golds at their previous Games are
# treated as established medal powers (Team USA is one).
LARGE_HOST_MIN_GOLD <- 10
host_effect <- summer_hosts |>
left_join(summer_totals, by = c("year", "host_code" = "country_code")) |>
rename(host_gold_hosting = gold, host_silver_hosting = silver,
host_bronze_hosting = bronze, host_total_hosting = total) |>
mutate(prior_year = lag(summer_hosts$year)) |>
left_join(
summer_totals |> rename(prior_gold = gold, prior_silver = silver,
prior_bronze = bronze, prior_total = total),
by = c("prior_year" = "year", "host_code" = "country_code")
) |>
filter(!is.na(prior_gold), !is.na(host_gold_hosting)) |>
mutate(
pct_increase_gold = (host_gold_hosting - prior_gold) / (prior_gold + 0.5) * 100,
pct_increase_silver = (host_silver_hosting - prior_silver) / (prior_silver + 0.5) * 100,
pct_increase_bronze = (host_bronze_hosting - prior_bronze) / (prior_bronze + 0.5) * 100,
pct_increase_total = (host_total_hosting - prior_total) / (prior_total + 0.5) * 100,
host_size = if_else(prior_gold >= LARGE_HOST_MIN_GOLD, "Large", "Small")
)
avg_host_increase <- host_effect |>
filter(year >= 1960) |>
pull(pct_increase_gold) |>
mean(na.rm = TRUE)
host_recent_noboycott <- host_effect |>
filter(year >= 1960, !year %in% c(1980, 1984))
avg_host_increase_large <- host_recent_noboycott |>
filter(host_size == "Large") |>
pull(pct_increase_gold) |>
mean(na.rm = TRUE)
avg_host_increase_small <- host_recent_noboycott |>
filter(host_size == "Small") |>
pull(pct_increase_gold) |>
mean(na.rm = TRUE)
n_host_large <- sum(host_recent_noboycott$host_size == "Large")
esp_1992 <- host_effect |>
filter(year == 1992, host_code == "ESP") |>
pull(pct_increase_gold)
gbr_2012 <- host_effect |>
filter(year == 2012, host_code == "GBR") |>
pull(pct_increase_gold)Finding 4: Since 1960, host nations have won an average of 159.7% more gold medals when hosting compared to their previous Summer Olympics performance. The effect is real but noisy; a few dramatic cases like Spain 1992 (+800%) and Great Britain 2012 (+51%) pull the average up considerably. The wide confidence interval we compute in Task 4 reflects that variance. The effect also depends on size: hosts that already won at least 10 golds at their previous Games gained an average of 59% (n = 5), compared with 220% for smaller hosts. Team USA is in the first group, so the forecast uses that number.
Finding 5: The table below details each host nation comparison. Percent changes add 0.5 to the prior-Games count in the denominator, so hosts with zero prior golds can be included without dividing by zero.
host_effect |>
select(year, host_code, prior_gold, host_gold_hosting, pct_increase_gold) |>
arrange(year) |>
gt() |>
tab_header(
title = "Host Nation Gold Medal Performance",
subtitle = "Comparison to the prior Summer Olympics for the same country"
) |>
cols_label(
year = "Year",
host_code = "Host",
prior_gold = "Prior Games",
host_gold_hosting = "Host Year",
pct_increase_gold = "% Change"
) |>
fmt_integer(columns = year, use_seps = FALSE) |>
fmt_number(columns = pct_increase_gold, decimals = 1) |>
fmt_integer(columns = c(prior_gold, host_gold_hosting)) |>
data_color(
columns = pct_increase_gold,
palette = c("#c9a84c", "#f7f7f7", "#1a1a2e")
)| Host Nation Gold Medal Performance | ||||
| Comparison to the prior Summer Olympics for the same country | ||||
| Year | Host | Prior Games | Host Year | % Change |
|---|---|---|---|---|
| 1900 | FRA | 5 | 31 | 472.7 |
| 1904 | USA | 20 | 80 | 292.7 |
| 1908 | GBR | 1 | 56 | 3,666.7 |
| 1912 | SWE | 8 | 23 | 176.5 |
| 1924 | FRA | 9 | 14 | 52.6 |
| 1928 | NED | 4 | 8 | 88.9 |
| 1932 | USA | 22 | 44 | 97.8 |
| 1936 | GER | 5 | 38 | 600.0 |
| 1952 | FIN | 10 | 6 | −38.1 |
| 1956 | AUS | 6 | 13 | 107.7 |
| 1960 | ITA | 8 | 13 | 58.8 |
| 1964 | JPN | 4 | 16 | 266.7 |
| 1968 | MEX | 0 | 3 | 600.0 |
| 1972 | FRG | 5 | 13 | 145.5 |
| 1976 | CAN | 0 | 0 | 0.0 |
| 1980 | URS | 49 | 80 | 62.6 |
| 1988 | KOR | 6 | 12 | 92.3 |
| 1992 | ESP | 1 | 13 | 800.0 |
| 1996 | USA | 37 | 44 | 18.7 |
| 2000 | AUS | 9 | 16 | 73.7 |
| 2004 | GRE | 4 | 6 | 44.4 |
| 2008 | CHN | 32 | 48 | 49.2 |
| 2012 | GBR | 19 | 29 | 51.3 |
| 2016 | BRA | 3 | 7 | 114.3 |
| 2020 | JPN | 12 | 27 | 120.0 |
| 2024 | FRA | 10 | 16 | 57.1 |
Finding 6: Most hosts improve when competing at home. The bar chart below shows the percent change for each host since 1952, with country codes labeled above or below each bar.
host_effect |>
filter(year >= 1952) |>
ggplot(aes(x = factor(year), y = pct_increase_gold,
fill = pct_increase_gold > 0)) +
geom_col() +
geom_hline(yintercept = 0, linewidth = 0.8) +
geom_text(
aes(label = host_code,
vjust = if_else(pct_increase_gold >= 0, -0.3, 1.3)),
size = 2.8, fontface = "bold"
) +
scale_fill_manual(values = c("TRUE" = "#1a1a2e", "FALSE" = "#c9a84c"),
guide = "none") +
scale_y_continuous(labels = percent_format(scale = 1)) +
labs(
title = "Host Nation Gold Medal Change vs. Prior Olympics (1952 to 2024)",
x = "Olympic Year",
y = "% Change in Gold Medals",
caption = "Source: Olympedia. Country codes above/below each bar."
) +
theme_minimal(base_size = 11) +
theme(
plot.title = element_text(face = "bold"),
axis.text.x = element_text(angle = 45, hjust = 1)
)
A “new sport” is defined as one that did not appear in the immediately preceding Summer Olympics. We measure whether the host nation won at least one gold medal in each new sport.
summer_sports <- medals_clean |>
filter(season == "Summer") |>
distinct(year, sport_name)
summer_years <- sort(unique(summer_sports$year))
new_sports_df <- map_dfr(summer_years, function(yr) {
prior_yr <- summer_years[which(summer_years == yr) - 1]
sports_now <- summer_sports |> filter(year == yr) |> pull(sport_name)
if (is.na(prior_yr) || length(prior_yr) == 0) {
return(tibble(year = yr, sport_name = sports_now, is_new = TRUE))
}
sports_prev <- summer_sports |> filter(year == prior_yr) |> pull(sport_name)
tibble(year = yr, sport_name = sports_now, is_new = !(sports_now %in% sports_prev))
})
new_sport_medals <- new_sports_df |>
filter(is_new) |>
left_join(summer_hosts, by = "year") |>
left_join(
medals_clean |> filter(season == "Summer") |>
select(year, sport_name, country_code, gold),
by = c("year", "sport_name")
) |>
filter(!is.na(host_code)) |>
group_by(year, sport_name, host_code) |>
summarise(
host_won_gold = any(country_code == host_code & gold > 0, na.rm = TRUE),
.groups = "drop"
)
host_new_sport_rate <- mean(new_sport_medals$host_won_gold, na.rm = TRUE)Finding 7: Across all Summer Olympics, host nations won at least one gold medal in 48% of the new sport disciplines they introduced. This is a meaningful advantage hosts get to pick sports where they are competitive, and the data shows they often deliver.
Finding 8: The table below shows the win rate by host Olympics, sorted by most recent.
new_sport_medals |>
group_by(year, host_code) |>
summarise(
`New Sports` = n(),
`Golds Won` = sum(host_won_gold),
`Win Rate` = `Golds Won` / `New Sports`,
.groups = "drop"
) |>
arrange(desc(year)) |>
gt() |>
tab_header(
title = "Host Nation Gold Medal Success in New Sports",
subtitle = "Each row represents one host Summer Olympics"
) |>
cols_label(year = "Year", host_code = "Host") |>
fmt_integer(columns = year, use_seps = FALSE) |>
fmt_percent(columns = `Win Rate`, decimals = 0) |>
fmt_integer(columns = c(`New Sports`, `Golds Won`)) |>
data_color(columns = `Win Rate`, palette = c("#f7f7f7", "#c9a84c"))| Host Nation Gold Medal Success in New Sports | ||||
| Each row represents one host Summer Olympics | ||||
| Year | Host | New Sports | Golds Won | Win Rate |
|---|---|---|---|---|
| 2024 | FRA | 1 | 0 | 0% |
| 2020 | JPN | 8 | 4 | 50% |
| 2016 | BRA | 2 | 0 | 0% |
| 2008 | CHN | 2 | 0 | 0% |
| 2000 | AUS | 3 | 1 | 33% |
| 1996 | USA | 3 | 2 | 67% |
| 1992 | ESP | 3 | 0 | 0% |
| 1988 | KOR | 2 | 1 | 50% |
| 1984 | USA | 2 | 1 | 50% |
| 1972 | FRG | 4 | 0 | 0% |
| 1964 | JPN | 2 | 2 | 100% |
| 1960 | ITA | 3 | 1 | 33% |
| 1956 | AUS | 1 | 0 | 0% |
| 1952 | FIN | 2 | 1 | 50% |
| 1948 | GBR | 2 | 0 | 0% |
| 1936 | GER | 7 | 3 | 43% |
| 1932 | USA | 3 | 1 | 33% |
| 1928 | NED | 3 | 0 | 0% |
| 1920 | BEL | 10 | 4 | 40% |
| 1912 | SWE | 10 | 5 | 50% |
| 1908 | GBR | 10 | 8 | 80% |
| 1904 | USA | 8 | 7 | 88% |
| 1900 | FRA | 18 | 10 | 56% |
| 1896 | GRE | 10 | 6 | 60% |
Finding 9: The chart below compares host nation gold win rates in new versus established sports. The gap is notable and consistent.
established_sport_medals <- medals_clean |>
filter(season == "Summer") |>
left_join(new_sports_df, by = c("year", "sport_name")) |>
mutate(is_new = replace_na(is_new, FALSE)) |>
group_by(year, sport_name, is_new, host_code) |>
summarise(
host_won_gold = any(country_code == host_code & gold > 0, na.rm = TRUE),
.groups = "drop"
) |>
filter(!is.na(host_code))
established_sport_medals |>
group_by(is_new) |>
summarise(rate = mean(host_won_gold, na.rm = TRUE),
n = n(), .groups = "drop") |>
mutate(label = if_else(is_new, "New Sports", "Established Sports")) |>
ggplot(aes(x = label, y = rate, fill = label)) +
geom_col(width = 0.5) +
geom_text(aes(label = percent(rate, accuracy = 1)),
vjust = -0.5, size = 5.5, fontface = "bold") +
geom_text(aes(label = glue("n = {comma(n)} disciplines")),
vjust = -2.3, size = 3.5, colour = "grey40") +
scale_y_continuous(labels = percent_format(), limits = c(0, 0.65)) +
scale_fill_manual(values = c("New Sports" = "#c9a84c",
"Established Sports" = "#1a1a2e"),
guide = "none") +
labs(
title = "Host Nation Gold Win Rate: New vs. Established Sports",
x = NULL,
y = "Share of Disciplines with at Least One Host Gold",
caption = "Source: Olympedia"
) +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"))
Finding 10 (Inline): The Olympic program has expanded dramatically. The 2024 Paris Olympics featured 47 medal disciplines, compared to just 10 in 1896. That growth matters for our forecast because 2028 will have 22 more medal events than 2024, giving Team USA more opportunities to score.
Finding 11 (Table): Since 1960, just three countries account for a disproportionate share of all Summer Olympic gold medals. Team USA leads by a comfortable margin.
medals_clean |>
filter(season == "Summer", year >= 1960) |>
group_by(country_code) |>
summarise(gold = sum(gold, na.rm = TRUE), .groups = "drop") |>
slice_max(gold, n = 10) |>
mutate(Rank = row_number()) |>
select(Rank, country_code, gold) |>
gt() |>
tab_header(title = "Top 10 Countries: Summer Olympic Golds (1960 to 2024)") |>
cols_label(Rank = "#", country_code = "Country", gold = "Gold Medals") |>
fmt_integer(columns = c(Rank, gold)) |>
data_color(columns = gold, palette = c("white", "#c9a84c"))| Top 10 Countries: Summer Olympic Golds (1960 to 2024) | ||
| # | Country | Gold Medals |
|---|---|---|
| 1 | USA | 664 |
| 2 | URS | 336 |
| 3 | CHN | 303 |
| 4 | GBR | 170 |
| 5 | JPN | 169 |
| 6 | GER | 167 |
| 7 | GDR | 153 |
| 8 | AUS | 150 |
| 9 | ITA | 149 |
| 10 | RUS | 147 |
Finding 12 (Visualization): Despite winning more raw medals as the program has expanded, the US share of all gold medals has declined steadily since its early dominance. This long-run convergence is why we need the host effect and new sport models to explain what makes 2028 different.
total_gold_by_year <- medals_clean |>
filter(season == "Summer") |>
group_by(year) |>
summarise(total_gold_all = sum(gold, na.rm = TRUE), .groups = "drop")
us_summer |>
left_join(total_gold_by_year, by = "year") |>
mutate(us_share = gold / total_gold_all) |>
ggplot(aes(x = year, y = us_share)) +
geom_line(colour = "#1a1a2e", linewidth = 1) +
geom_point(colour = "#1a1a2e", size = 2) +
geom_smooth(method = "loess", se = TRUE, colour = "#c9a84c",
fill = "#c9a84c", alpha = 0.15) +
scale_y_continuous(labels = percent_format(accuracy = 1)) +
labs(
title = "USA Share of Summer Olympic Gold Medals Over Time",
subtitle = "Gold LOESS trend shows the long-run decline in US dominance",
x = "Year", y = "US Share of All Gold Medals",
caption = "Source: Olympedia"
) +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"))
We use the infer package to construct 95% confidence intervals for all three factors, restricting the sample to Summer Olympics from 1960 onward to keep the analysis relevant to 2028 conditions.
CUTOFF_YEAR <- 1960
BOYCOTT_YEARS <- c(1980, 1984)
us_summer_recent <- us_summer |>
filter(year >= CUTOFF_YEAR, !year %in% BOYCOTT_YEARS)
host_effect_recent <- host_effect |>
filter(year >= CUTOFF_YEAR, !year %in% BOYCOTT_YEARS)
new_sport_recent <- new_sport_medalsci_us_gold <- us_summer_recent |>
t_test(response = gold) |>
select(estimate, lower_ci, upper_ci)medal_types <- c("gold", "silver", "bronze", "total")
us_cis <- map_dfr(medal_types, function(m) {
result <- us_summer_recent |>
rename(response = all_of(m)) |>
t_test(response = response)
tibble(
Medal = str_to_title(m),
Mean = result$estimate,
Lower_CI = result$lower_ci,
Upper_CI = result$upper_ci
)
})
us_cis |>
gt() |>
tab_header(
title = "Team USA: 95% Confidence Intervals for Medal Counts",
subtitle = glue("Based on Summer Olympics from 1960 to 2024 (n = {nrow(us_summer_recent)} Games)")
) |>
cols_label(
Medal = "Medal Type",
Mean = "Mean per Games",
Lower_CI = "Lower 95% CI",
Upper_CI = "Upper 95% CI"
) |>
fmt_number(columns = c(Mean, Lower_CI, Upper_CI), decimals = 1) |>
data_color(columns = Mean, palette = c("white", "#c9a84c"))| Team USA: 95% Confidence Intervals for Medal Counts | |||
| Based on Summer Olympics from 1960 to 2024 (n = 15 Games) | |||
| Medal Type | Mean per Games | Lower 95% CI | Upper 95% CI |
|---|---|---|---|
| Gold | 38.7 | 36.1 | 41.4 |
| Silver | 32.5 | 28.8 | 36.3 |
| Bronze | 30.7 | 27.1 | 34.4 |
| Total | 102.0 | 94.4 | 109.6 |
host_effect_recent_all <- host_effect |> filter(year >= CUTOFF_YEAR, !year %in% BOYCOTT_YEARS)
ci_host <- host_effect_recent_all |>
t_test(response = pct_increase_gold) |>
select(estimate, lower_ci, upper_ci)
host_cis <- map_dfr(
c("pct_increase_gold", "pct_increase_silver",
"pct_increase_bronze", "pct_increase_total"),
function(col) {
result <- host_effect_recent_all |>
rename(response = all_of(col)) |>
drop_na(response) |>
t_test(response = response)
tibble(
Medal = str_to_title(str_remove(col, "pct_increase_")),
Mean = result$estimate,
Lower_CI = result$lower_ci,
Upper_CI = result$upper_ci
)
}
)
host_cis |>
gt() |>
tab_header(
title = "Host Nation Effect: 95% CIs for % Medal Increase",
subtitle = glue("Based on {nrow(host_effect_recent_all)} host nations from 1960 to 2024")
) |>
cols_label(
Medal = "Medal Type",
Mean = "Mean % Increase",
Lower_CI = "Lower 95% CI",
Upper_CI = "Upper 95% CI"
) |>
fmt_number(columns = c(Mean, Lower_CI, Upper_CI), decimals = 1, suffix = "%") |>
data_color(columns = Mean, palette = c("#c9a84c", "#f7f7f7", "#1a1a2e"))| Host Nation Effect: 95% CIs for % Medal Increase | |||
| Based on 15 host nations from 1960 to 2024 | |||
| Medal Type | Mean % Increase | Lower 95% CI | Upper 95% CI |
|---|---|---|---|
| Gold | 166.1 | 39.4 | 292.9 |
| Silver | 109.7 | 14.9 | 204.5 |
| Bronze | 34.9 | 4.6 | 65.2 |
| Total | 105.1 | 21.0 | 189.2 |
The confidence interval for gold medals is wide (roughly 39% to 293%) because the host effect varies a lot from one country to another. Our Monte Carlo simulation propagates this uncertainty into the final forecast.
The all-host average is driven by small and mid-sized countries that jumped from a low base. Team USA already wins dozens of golds, so we also estimate the effect for hosts that won at least 10 golds at their previous Games. The cutoff is a judgment call and this group is small, so its interval is wide.
host_large_recent <- host_effect_recent_all |> filter(host_size == "Large")
ci_host_large <- host_large_recent |>
t_test(response = pct_increase_gold) |>
select(estimate, lower_ci, upper_ci)
tibble(
Group = c("All hosts", glue("Large hosts ({LARGE_HOST_MIN_GOLD}+ prior golds)")),
Hosts = c(nrow(host_effect_recent_all), nrow(host_large_recent)),
Mean = c(host_cis$Mean[1], ci_host_large$estimate),
Lower_CI = c(host_cis$Lower_CI[1], ci_host_large$lower_ci),
Upper_CI = c(host_cis$Upper_CI[1], ci_host_large$upper_ci)
) |>
gt() |>
tab_header(
title = "Host Effect on Gold Medals: All Hosts vs. Large Hosts",
subtitle = "95% CIs for the mean % increase over the previous Games"
) |>
cols_label(
Group = "Host Group",
Hosts = "Hosts",
Mean = "Mean % Increase",
Lower_CI = "Lower 95% CI",
Upper_CI = "Upper 95% CI"
) |>
fmt_integer(columns = Hosts) |>
fmt_number(columns = c(Mean, Lower_CI, Upper_CI), decimals = 1, suffix = "%") |>
data_color(columns = Mean, palette = c("#c9a84c", "#f7f7f7", "#1a1a2e"))| Host Effect on Gold Medals: All Hosts vs. Large Hosts | ||||
| 95% CIs for the mean % increase over the previous Games | ||||
| Host Group | Hosts | Mean % Increase | Lower 95% CI | Upper 95% CI |
|---|---|---|---|---|
| All hosts | 15 | 166.1 | 39.4 | 292.9 |
| Large hosts (10+ prior golds) | 5 | 59.3 | 13.2 | 105.3 |
ci_new_sport <- new_sport_recent |>
mutate(host_won_gold = as.logical(host_won_gold)) |>
prop_test(host_won_gold ~ NULL) |>
select(lower_ci, upper_ci)
prop_estimate <- mean(new_sport_recent$host_won_gold, na.rm = TRUE)The estimated probability that a host nation wins gold in a new sport is 48% (95% CI: 39% to 57%). This is based on 119 new sport-edition combinations across all Summer Olympics.
The t-test and proportion test above rely on normality assumptions. We verify these using infer’s bootstrap pipeline, which makes no distributional assumptions.
set.seed(9750)
boot_us_gold <- us_summer_recent |>
specify(response = gold) |>
generate(reps = 5000, type = "bootstrap") |>
calculate(stat = "mean")
boot_ci_us <- boot_us_gold |>
get_confidence_interval(level = 0.95, type = "percentile")
boot_host <- host_effect_recent_all |>
drop_na(pct_increase_gold) |>
specify(response = pct_increase_gold) |>
generate(reps = 5000, type = "bootstrap") |>
calculate(stat = "mean")
boot_ci_host <- boot_host |>
get_confidence_interval(level = 0.95, type = "percentile")
boot_new <- new_sport_recent |>
mutate(host_won_gold = as.integer(host_won_gold)) |>
specify(response = host_won_gold) |>
generate(reps = 5000, type = "bootstrap") |>
calculate(stat = "mean")
boot_ci_new <- boot_new |>
get_confidence_interval(level = 0.95, type = "percentile")
boot_host_large <- host_effect_recent_all |>
filter(host_size == "Large") |>
drop_na(pct_increase_gold) |>
specify(response = pct_increase_gold) |>
generate(reps = 5000, type = "bootstrap") |>
calculate(stat = "mean")
boot_ci_host_large <- boot_host_large |>
get_confidence_interval(level = 0.95, type = "percentile")tribble(
~Factor, ~`Param. Lower`, ~`Param. Upper`,
~`Boot. Lower`, ~`Boot. Upper`,
"US Baseline (golds)", round(ci_us_gold$lower_ci, 1),
round(ci_us_gold$upper_ci, 1),
round(boot_ci_us$lower_ci, 1),
round(boot_ci_us$upper_ci, 1),
"Host Effect (% change)", round(ci_host$lower_ci, 1),
round(ci_host$upper_ci, 1),
round(boot_ci_host$lower_ci, 1),
round(boot_ci_host$upper_ci, 1),
"Host Effect, large hosts (% change)", round(ci_host_large$lower_ci, 1),
round(ci_host_large$upper_ci, 1),
round(boot_ci_host_large$lower_ci, 1),
round(boot_ci_host_large$upper_ci, 1),
"New Sport P(gold)", round(ci_new_sport$lower_ci, 3),
round(ci_new_sport$upper_ci, 3),
round(boot_ci_new$lower_ci, 3),
round(boot_ci_new$upper_ci, 3)
) |>
gt() |>
tab_header(
title = "Parametric vs. Bootstrap 95% Confidence Intervals",
subtitle = "Bootstrap uses 5,000 resamples via the infer package"
) |>
tab_spanner(label = "Parametric (t-test / prop-test)",
columns = c(`Param. Lower`, `Param. Upper`)) |>
tab_spanner(label = "Bootstrap (percentile method)",
columns = c(`Boot. Lower`, `Boot. Upper`)) |>
cols_label(
`Param. Lower` = "Lower", `Param. Upper` = "Upper",
`Boot. Lower` = "Lower", `Boot. Upper` = "Upper"
)| Parametric vs. Bootstrap 95% Confidence Intervals | ||||
| Bootstrap uses 5,000 resamples via the infer package | ||||
| Factor |
Parametric (t-test / prop-test)
|
Bootstrap (percentile method)
|
||
|---|---|---|---|---|
| Lower | Upper | Lower | Upper | |
| US Baseline (golds) | 36.100 | 41.400 | 36.600 | 41.100 |
| Host Effect (% change) | 39.400 | 292.900 | 70.100 | 287.600 |
| Host Effect, large hosts (% change) | 13.200 | 105.300 | 32.500 | 92.500 |
| New Sport P(gold) | 0.387 | 0.572 | 0.395 | 0.571 |
The bootstrap and parametric intervals are very close for the US baseline and the new sport probability, suggesting normality is a reasonable assumption for those quantities. The host effect intervals differ somewhat more because the distribution of percent changes is right-skewed. For robustness, we use the bootstrap interval for the large-host effect in the final forecast, because Team USA is a large host.
visualize(boot_us_gold) +
shade_confidence_interval(boot_ci_us, color = "#c9a84c", fill = "#c9a84c",
alpha = 0.2) +
geom_vline(xintercept = ci_us_gold$estimate, colour = "#1a1a2e",
linewidth = 1.2, linetype = "dashed") +
labs(
title = "Bootstrap Distribution: US Average Gold Medals per Games",
subtitle = glue(
"95% CI: [{round(boot_ci_us$lower_ci, 1)}, {round(boot_ci_us$upper_ci, 1)}] golds | ",
"5,000 bootstrap resamples"
),
x = "Bootstrap Mean (gold medals)", y = "Count"
) +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"))
Richer nations invest more in athlete development, training infrastructure, and sports science. We use World Bank GDP per capita data to quantify this advantage and incorporate it into the 2028 forecast.
gdp_cache <- "data/mp04/gdp_per_capita.rds"
if (file.exists(gdp_cache)) {
gdp_raw <- readRDS(gdp_cache)
} else {
gdp_url <- paste0(
"https://api.worldbank.org/v2/country/all/indicator/NY.GDP.PCAP.CD",
"?format=json&per_page=20000&mrv=60"
)
resp <- httr2::request(gdp_url) |> httr2::req_perform()
raw <- httr2::resp_body_json(resp, simplifyVector = TRUE)
gdp_raw <- raw[[2]] |>
as_tibble() |>
select(iso3c = countryiso3code, year = date, gdp_pc = value) |>
mutate(year = as.integer(year),
gdp_pc = as.numeric(gdp_pc)) |>
filter(!is.na(gdp_pc), iso3c != "")
saveRDS(gdp_raw, gdp_cache)
}olympic_years <- medals_clean |>
filter(season == "Summer", year >= 1960) |>
distinct(year, country_code, iso_code)
gdp_matched <- olympic_years |>
left_join(gdp_raw, by = c("iso_code" = "iso3c", "year")) |>
arrange(iso_code, year) |>
group_by(iso_code) |>
fill(gdp_pc, .direction = "down") |>
ungroup()
medals_with_gdp <- medals_clean |>
filter(season == "Summer", year >= 1960) |>
group_by(year, country_code, iso_code) |>
summarise(gold = sum(gold, na.rm = TRUE), .groups = "drop") |>
left_join(gdp_matched, by = c("year", "country_code", "iso_code")) |>
filter(!is.na(gdp_pc), gold > 0)medals_with_gdp |>
group_by(iso_code, country_code) |>
summarise(
avg_gold = mean(gold, na.rm = TRUE),
avg_gdp_pc = mean(gdp_pc, na.rm = TRUE),
.groups = "drop"
) |>
ggplot(aes(x = avg_gdp_pc, y = avg_gold)) +
geom_point(alpha = 0.5, colour = "#1a1a2e") +
geom_smooth(method = "loess", colour = "#c9a84c", se = TRUE,
fill = "#c9a84c", alpha = 0.15) +
geom_text_repel(
data = ~ filter(.x, avg_gold > 15 | avg_gdp_pc > 60000),
aes(label = country_code), size = 3
) +
scale_x_continuous(labels = dollar_format(scale = 1/1000, suffix = "k")) +
scale_y_log10() +
labs(
title = "GDP Per Capita vs. Average Gold Medals (1960 to 2024)",
x = "Average GDP Per Capita (USD)",
y = "Average Golds per Games (log scale)",
caption = "Source: Olympedia, World Bank"
) +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"))
gdp_model <- lm(log1p(gold) ~ log(gdp_pc), data = medals_with_gdp)
gdp_summary <- broom::tidy(gdp_model, conf.int = TRUE)
gdp_summary |>
gt() |>
tab_header(
title = "Regression: Log Gold Medals ~ Log GDP Per Capita",
subtitle = glue(
"n = {comma(nrow(medals_with_gdp))} country-year observations | ",
"R-squared = {round(summary(gdp_model)$r.squared, 3)}"
)
) |>
cols_label(
term = "Term", estimate = "Estimate", std.error = "Std. Error",
statistic = "t-statistic", p.value = "p-value",
conf.low = "Lower CI", conf.high = "Upper CI"
) |>
fmt_number(columns = c(estimate, std.error, statistic, conf.low, conf.high),
decimals = 3) |>
fmt_scientific(columns = p.value)| Regression: Log Gold Medals ~ Log GDP Per Capita | ||||||
| n = 611 country-year observations | R-squared = 0.053 | ||||||
| Term | Estimate | Std. Error | t-statistic | p-value | Lower CI | Upper CI |
|---|---|---|---|---|---|---|
| (Intercept) | 0.310 | 0.203 | 1.526 | 1.28 × 10−1 | −0.089 | 0.710 |
| log(gdp_pc) | 0.131 | 0.022 | 5.850 | 8.03 × 10−9 | 0.087 | 0.175 |
The coefficient on log GDP per capita is positive and highly significant. An R-squared of 0.05 means GDP per capita alone explains only a small share of the variation in gold medal counts. The relationship is real but weak, which is why the forecast treats it as a small, capped adjustment.
us_gdp_pc <- gdp_raw |>
filter(iso3c == "USA") |>
slice_max(year, n = 1) |>
pull(gdp_pc)
avg_gdp_pc <- medals_with_gdp |>
filter(year >= 1960) |>
group_by(iso_code) |>
summarise(avg = mean(gdp_pc, na.rm = TRUE), .groups = "drop") |>
pull(avg) |>
mean(na.rm = TRUE)
gdp_coef <- gdp_summary |> filter(term == "log(gdp_pc)") |> pull(estimate)
host_iso <- medals_clean |>
filter(season == "Summer") |>
distinct(country_code, iso_code)
past_hosts <- summer_hosts |>
filter(year >= 1984) |>
left_join(host_iso, by = c("host_code" = "country_code")) |>
left_join(
gdp_matched |> select(year, iso_code, gdp_pc),
by = c("year", "iso_code")
) |>
filter(!is.na(gdp_pc))
median_host_gdp_pc <- median(past_hosts$gdp_pc, na.rm = TRUE)
gdp_multiplier <- min(1.10,
exp(gdp_coef * (log(us_gdp_pc) - log(median_host_gdp_pc))))With a GDP per capita of $85,000 versus the median past host nation GDP of $21,000, the model estimates a 10% GDP advantage boost for Team USA. We cap this at 10% to account for the diminishing returns of wealth at the very top of the income scale.
We combine all four factors using 1,000,000 Monte Carlo draws. The forecast equation is:
\[ \widehat{\text{Golds}}_{2028} = \underbrace{\mu_{\text{USA}}}_{\text{baseline}} \times \underbrace{(1 + \delta_{\text{host}})}_{\text{host effect}} \times \underbrace{\gamma_{\text{GDP}}}_{\text{GDP factor}} + \underbrace{n_{\text{new}} \times p_{\text{new}}}_{\text{new sport bonus}} \]
N_SIM <- 1e6
N_NEW_EVENTS <- 10
ci_to_normal <- function(lower, upper, conf = 0.95) {
mu <- (lower + upper) / 2
sd <- (upper - mu) / qnorm(1 - (1 - conf) / 2)
list(mu = mu, sd = sd)
}
us_baseline <- ci_to_normal(boot_ci_us$lower_ci, boot_ci_us$upper_ci)
host_eff <- ci_to_normal(boot_ci_host_large$lower_ci, boot_ci_host_large$upper_ci)
new_sport_params <- ci_to_normal(boot_ci_new$lower_ci, boot_ci_new$upper_ci)
gdp_params <- list(mu = gdp_multiplier, sd = (gdp_multiplier - 1) * 0.25)
set.seed(9750)
baseline_draws <- rnorm(N_SIM, us_baseline$mu, us_baseline$sd)
host_eff_draws <- rnorm(N_SIM, host_eff$mu / 100, host_eff$sd / 100)
new_sport_draws <- pmax(0, pmin(1,
rnorm(N_SIM, new_sport_params$mu, new_sport_params$sd)))
gdp_draws <- pmax(1, rnorm(N_SIM, gdp_params$mu, gdp_params$sd))
predicted_gold_draws <-
baseline_draws * (1 + host_eff_draws) * gdp_draws +
N_NEW_EVENTS * new_sport_draws
gold_ci <- quantile(predicted_gold_draws, c(0.025, 0.50, 0.975))The median forecast is 74 gold medals for Team USA at LA 2028, with a 95% confidence interval of 61 to 88.
tibble(golds = predicted_gold_draws) |>
ggplot(aes(x = golds)) +
geom_histogram(binwidth = 2, fill = "#1a1a2e", colour = "white", alpha = 0.85) +
geom_vline(xintercept = gold_ci[2], colour = "#c9a84c", linewidth = 1.2) +
geom_vline(xintercept = c(gold_ci[1], gold_ci[3]),
colour = "#c9a84c", linewidth = 0.8, linetype = "dashed") +
annotate("label", x = gold_ci[2] + 6, y = Inf, vjust = 1.5,
label = glue("Median: {round(gold_ci[2])}"),
colour = "#c9a84c", fontface = "bold", fill = "white") +
labs(
title = "Monte Carlo Forecast: Team USA Gold Medals at LA 2028",
subtitle = glue(
"95% CI: [{round(gold_ci[1])}, {round(gold_ci[3])}] | ",
"Four-factor model | 1,000,000 simulations"
),
x = "Predicted Gold Medals", y = "Simulation Count",
caption = "Baseline x Host Effect x GDP Factor + New Sport Bonus"
) +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"))
To understand how reliable the model is, we apply it to past host nations and compare predictions to what actually happened. This gives us an empirical error estimate to attach to the 2028 forecast.
validation_hosts <- host_effect |>
filter(year >= 1984) |>
left_join(
gdp_matched |> select(year, country_code, gdp_pc),
by = c("year", "host_code" = "country_code")
) |>
filter(!is.na(gdp_pc)) |>
mutate(
predicted = prior_gold * (1 + if_else(host_size == "Large",
avg_host_increase_large,
avg_host_increase_small) / 100),
actual = host_gold_hosting,
abs_error = abs(predicted - actual),
pct_error = abs_error / (actual + 0.5) * 100
) |>
select(year, host_code, prior_gold, actual, predicted, abs_error, pct_error) |>
arrange(year)mae <- mean(validation_hosts$abs_error, na.rm = TRUE)
mpe <- mean(validation_hosts$pct_error, na.rm = TRUE)
validation_hosts |>
gt() |>
tab_header(
title = "Retrospective Validation: Predicted vs. Actual (1984 to 2024)",
subtitle = glue(
"Mean absolute error: {round(mae, 1)} golds | ",
"Mean % error: {round(mpe, 1)}%"
)
) |>
cols_label(
year = "Year",
host_code = "Host",
prior_gold = "Prior Golds",
actual = "Actual",
predicted = "Predicted",
abs_error = "Abs. Error",
pct_error = "% Error"
) |>
fmt_integer(columns = year, use_seps = FALSE) |>
fmt_integer(columns = c(prior_gold, actual)) |>
fmt_number(columns = c(predicted, abs_error), decimals = 1) |>
fmt_number(columns = pct_error, decimals = 1, suffix = "%") |>
data_color(columns = abs_error, palette = c("#1a1a2e", "#f7f7f7", "#c9a84c"))| Retrospective Validation: Predicted vs. Actual (1984 to 2024) | ||||||
| Mean absolute error: 6.6 golds | Mean % error: 41.9% | ||||||
| Year | Host | Prior Golds | Actual | Predicted | Abs. Error | % Error |
|---|---|---|---|---|---|---|
| 1988 | KOR | 6 | 12 | 19.2 | 7.2 | 57.4 |
| 1992 | ESP | 1 | 13 | 3.2 | 9.8 | 72.6 |
| 1996 | USA | 37 | 44 | 58.9 | 14.9 | 33.5 |
| 2000 | AUS | 9 | 16 | 28.8 | 12.8 | 77.3 |
| 2004 | GRE | 4 | 6 | 12.8 | 6.8 | 104.3 |
| 2008 | CHN | 32 | 48 | 51.0 | 3.0 | 6.1 |
| 2012 | GBR | 19 | 29 | 30.3 | 1.3 | 4.3 |
| 2016 | BRA | 3 | 7 | 9.6 | 2.6 | 34.5 |
| 2020 | JPN | 12 | 27 | 19.1 | 7.9 | 28.7 |
| 2024 | FRA | 10 | 16 | 15.9 | 0.1 | 0.4 |
validation_hosts |>
ggplot(aes(x = predicted, y = actual,
label = glue("{host_code} {year}"))) +
geom_abline(linetype = "dashed", colour = "grey60", linewidth = 1) +
geom_point(aes(colour = abs_error), size = 4) +
geom_text_repel(size = 3.2, max.overlaps = 15) +
scale_colour_gradientn(
colours = c("#1a1a2e", "#f7f7f7", "#c9a84c"),
name = "Abs. Error"
) +
labs(
title = "Model Validation: Predicted vs. Actual Host Nation Gold Medals",
x = "Predicted Gold Medals", y = "Actual Gold Medals",
caption = "Source: Olympedia, World Bank"
) +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"))
adjusted_lower <- max(0, round(gold_ci[1]) - round(mae))
adjusted_upper <- round(gold_ci[3]) + round(mae)The model’s mean absolute error across 10 past host nations is 6.6 gold medals (mean % error: 41.9%). The host effect is estimated from these same hosts, so this check is in-sample and error for a new host would likely be larger. Adding this empirical margin to the Monte Carlo confidence interval gives an adjusted 2028 forecast of 54 to 95 gold medals.
tibble(
Factor = c(
"US Baseline (post-1960 average)",
"Home Nation Boost",
"GDP Per Capita Advantage",
"New Sport Bonus (5 sports, ~10 events)",
"Total Forecast"
),
Impact = c(
glue("~{round(us_baseline$mu)} golds per Games"),
glue("+{round(us_baseline$mu * host_eff$mu / 100)} golds expected"),
glue("+{round((gdp_multiplier - 1) * 100, 1)}% GDP boost"),
glue("+{round(N_NEW_EVENTS * new_sport_params$mu)} golds expected"),
glue("~{round(gold_ci[2])} golds (central estimate)")
),
`95% Interval` = c(
glue("[{round(boot_ci_us$lower_ci)}, {round(boot_ci_us$upper_ci)}]"),
glue("[{round(us_baseline$mu * boot_ci_host_large$lower_ci / 100)}, {round(us_baseline$mu * boot_ci_host_large$upper_ci / 100)}]"),
glue("[+{round((gdp_multiplier - 1) * 100 * 0.5, 1)}%, +{round((gdp_multiplier - 1) * 100, 1)}%]"),
glue("[{round(N_NEW_EVENTS * boot_ci_new$lower_ci)}, {round(N_NEW_EVENTS * boot_ci_new$upper_ci)}]"),
glue("[{round(gold_ci[1])}, {round(gold_ci[3])}]")
)
) |>
gt() |>
tab_header(
title = md("**Team USA at LA 2028: Gold Medal Forecast**"),
subtitle = "Four-factor model using historical Olympic data (1960 to 2024)"
) |>
cols_label(Factor = "Factor", Impact = "Expected Impact") |>
tab_style(
style = list(cell_fill(color = "#c9a84c"), cell_text(weight = "bold")),
locations = cells_body(rows = 5)
) |>
tab_style(
style = cell_fill(color = "#f7f5ee"),
locations = cells_body(rows = c(1, 3))
)| Team USA at LA 2028: Gold Medal Forecast | ||
| Four-factor model using historical Olympic data (1960 to 2024) | ||
| Factor | Expected Impact | 95% Interval |
|---|---|---|
| US Baseline (post-1960 average) | ~39 golds per Games | [37, 41] |
| Home Nation Boost | +24 golds expected | [13, 36] |
| GDP Per Capita Advantage | +10% GDP boost | [+5%, +10%] |
| New Sport Bonus (5 sports, ~10 events) | +5 golds expected | [4, 6] |
| Total Forecast | ~74 golds (central estimate) | [61, 88] |
The data makes a strong case. Team USA enters the 2028 Los Angeles Games with four structural advantages stacking on top of each other.
The baseline is already elite. Since 1960, Team USA has averaged 39 gold medals per Summer Olympics more than any other nation. The floor is high: even in tough Olympics, the US rarely falls below 30 golds.
Home soil matters. Our analysis of hosts since 1960 that were already established medal powers shows an average gold medal increase of 62% when competing at home. Crowd support, host-country entries in many events, and years of national investment leading up to the event all contribute. For Team USA, that translates to roughly 24 additional golds beyond the baseline.
The new sports add extra chances. Baseball/softball, flag football, lacrosse, squash, and cricket join the program in 2028. Historical data shows host nations win gold in 48% of new disciplines they introduce. With an estimated 10 gold-medal events across these sports, Team USA has a modest but real cluster of additional wins available.
The economic advantage is real. With a GDP per capita of roughly $85,000 well above the Olympic average of $15,000 the US investment in athlete development reflects structural wealth that is associated with medal performance. Our regression confirms the relationship is statistically significant (p < 0.001) but weak (R-squared of 0.05), so we cap the adjustment at 10%.
Putting it all together, the central estimate is 74 gold medals for Team USA at LA 2028 (95% CI: 61 to 88). Adjusted for empirical model error based on 10 past host nations, the range is 54 to 95 golds. The range is wide, so sponsors should plan around it rather than around a single number. The case for sponsoring rests on the US baseline and its structural advantages, which hold even if the home boost comes in at the low end.
I used Claude (an AI assistant by Anthropic) to help structure and write the R code for this project, including the web scraping pipeline in Task 1, the Monte Carlo simulation in Task 5, and the bootstrap and GDP extra credit sections. I reviewed all code outputs and interpreted the results throughout. The written narrative, analysis framing, and conclusions are my own. No AI was used to write or edit non-code text, in accordance with course policy.