Olympic Medal Standings
The Milan-Cortina 2026 Winter Olympics are now complete and medal counts are a thing.
The official web site shows the medal counts as a table. It might be nice to show the results graphically.
The official web site is challenging to scrape, but an alternative is available:
https://en.wikipedia.org/wiki/2026_Winter_Olympics_medal_table
The Wikipedia page on 2026-02-24 contains the standings data in a form that is easy to scrape.
Using the rvest and xml2 packages we can
extract the table from the page:
library(rvest)
## URL <- "https://en.wikipedia.org/wiki/2026_Winter_Olympics_medal_table"
## Use permanent link in case the page changes:
URL <- "https://en.wikipedia.org/w/index.php?title=2026_Winter_Olympics_medal_table&oldid=1340005726"
page <- read_html(URL)
page_tables <- html_table(page, fill = TRUE)
length(page_tables)
## [1] 6
mtable <- page_tables[[3]]The table is unusually clean:
head(mtable)
## # A tibble: 6 × 6
## Rank .mw-parser-output .tooltip-dotted{border-bot…¹ Gold Silver Bronze Total
## <chr> <chr> <int> <int> <int> <int>
## 1 1 Norway 18 12 11 41
## 2 2 United States 12 12 9 33
## 3 3 Netherlands 10 7 3 20
## 4 4 Italy* 10 6 14 30
## 5 5 Germany 8 10 8 26
## 6 6 France 8 9 6 23
## # ℹ abbreviated name:
## # ¹`.mw-parser-output .tooltip-dotted{border-bottom:1px dotted;cursor:help}NOC`
tail(mtable)
## # A tibble: 6 × 6
## Rank .mw-parser-output .tooltip-dot…¹ Gold Silver Bronze Total
## <chr> <chr> <int> <int> <int> <int>
## 1 25 Estonia 0 1 0 1
## 2 25 Georgia 0 1 0 1
## 3 – Individual Neutral Athletes[A][… 0 1 0 1
## 4 28 Bulgaria 0 0 2 2
## 5 29 Belgium 0 0 1 1
## 6 Totals (29 entries) Totals (29 entries) 116 118 115 349
## # ℹ abbreviated name:
## # ¹`.mw-parser-output .tooltip-dotted{border-bottom:1px dotted;cursor:help}NOC`Only Rank might need adjusting (or could be dropped), the name of the second column needs fixing, and the final Totals row can be dropped:
library(dplyr)
mtable <- filter(mtable, ! grepl("^Totals", Rank)) |>
mutate(Rank = as.numeric(Rank))
## Warning: There was 1 warning in `mutate()`.
## ℹ In argument: `Rank = as.numeric(Rank)`.
## Caused by warning:
## ! NAs introduced by coercion
colnames(mtable)[[2]] <- "NOC"
tail(mtable)
## # A tibble: 6 × 6
## Rank NOC Gold Silver Bronze Total
## <dbl> <chr> <int> <int> <int> <int>
## 1 25 Denmark 0 1 0 1
## 2 25 Estonia 0 1 0 1
## 3 25 Georgia 0 1 0 1
## 4 NA Individual Neutral Athletes[A][B] 0 1 0 1
## 5 28 Bulgaria 0 0 2 2
## 6 29 Belgium 0 0 1 1For plotting it is useful to have a longer form with a variable for
medal type and medal count:
library(tidyr)
mtable_long <- pivot_longer(mtable, Gold : Bronze,
names_to = "medal",
values_to = "count")
head(mtable_long)
## # A tibble: 6 × 5
## Rank NOC Total medal count
## <dbl> <chr> <int> <chr> <int>
## 1 1 Norway 41 Gold 18
## 2 1 Norway 41 Silver 12
## 3 1 Norway 41 Bronze 11
## 4 2 United States 33 Gold 12
## 5 2 United States 33 Silver 12
## 6 2 United States 33 Bronze 9A first graph:
library(ggplot2)
ggplot(mtable_long) +
geom_col(aes(y = NOC, x = count, fill = medal))
One way to match the country order on the web site:
ggplot(mutate(mtable_long, NOC = factor(NOC, rev(mtable$NOC)))) +
geom_col(aes(y = NOC, x = count, fill = medal))
Reordering the medal type levels makes the reason for the country ordering easier to see:
p <- ggplot(mutate(mtable_long,
NOC = factor(NOC, rev(mtable$NOC)),
medal = factor(medal, c("Bronze", "Silver", "Gold")))) +
geom_col(aes(y = NOC, x = count, fill = medal))
p
We can choose more reasonable colors. The Hex code for
Bronze, for example, is from https://www.99colors.net/name/bronze:
p <- p + scale_fill_manual(values = c("Gold" = "#D4AF37",
"Silver" = "#C0C0C0",
"Bronze" = "#CD7F32"))
p
Finally some theme adjustments:
p + theme_minimal() +
theme(legend.position = "top",
panel.grid.major.y = element_blank()) +
guides(fill = guide_legend(reverse = TRUE)) +
scale_x_continuous(expand = c(0, 0)) +
labs(y=NULL, x = "Count", fill = "Medal")