Skip to content

Instantly share code, notes, and snippets.

@jonspring

jonspring/World Cup 2023 - group stage probabilities

Created July 18, 2023 20:11
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save jonspring/5a733a61fa1107d49a241d60967ab6c8 to your computer and use it in GitHub Desktop.
Save jonspring/5a733a61fa1107d49a241d60967ab6c8 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
World Cup 2023 - group stage probabilities
library(tidyverse)
library(lubridate)
# library(fitzRoy)
ranks <- tibble::tribble(
~RK, ~Team, ~PTS, ~chg,
1L, "USA", 2090.03, -1.35,
2L, "GER", 2061.56, -6.56,
3L, "SWE", 2049.71, -14.96,
4L, "ENG", 2040.76, -15.06,
5L, "FRA", 2026.65, 5.63,
6L, "ESP", 2002.28, 4.63,
7L, "CAN", 1996.34, -5.22,
8L, "BRA", 1995.3, 22.31,
9L, "NED", 1980.47, -10.98,
10L, "AUS", 1919.69, 1.78,
11L, "JPN", 1916.68, -0.65,
12L, "NOR", 1908.25, 2.67,
13L, "DEN", 1866.25, 15,
14L, "CHN", 1854.49, -2.49,
15L, "ISL", 1854.4, 2.63,
16L, "ITA", 1846.5, 0.57,
17L, "KOR", 1840.27, -0.41,
18L, "AUT", 1813.56, 4.87,
19L, "BEL", 1795.67, -8.35,
20L, "SUI", 1765.9, -6.37,
21L, "POR", 1745.13, -7.4,
22L, "IRL", 1743.59, 1.34,
23L, "SCO", 1735.87, 11.7,
24L, "RUS", 1717.06, 0,
25L, "COL", 1702.64, -0.97,
26L, "NZL", 1699.7, -7.26,
27L, "CZE", 1690.16, -2.31,
28L, "ARG", 1682.45, 0,
29L, "FIN", 1676.76, 9.43,
30L, "WAL", 1665.82, 6.06,
31L, "POL", 1662.26, 1.35,
32L, "VIE", 1648.89, 5.23,
33L, "UKR", 1644.63, -0.34,
34L, "SRB", 1622.42, 2.07,
35L, "MEX", 1621.8, 0,
36L, "CRC", 1596.94, -4.53,
37L, "TPE", 1578.28, 4.63,
38L, "ROU", 1564.03, 1.6,
39L, "SVN", 1556.25, 4,
40L, "NGA", 1554.94, 13.98,
41L, "CHI", 1553.22, 0,
42L, "HUN", 1544.83, 2.39,
43L, "JAM", 1536.81, 0,
44L, "THA", 1530.56, 3.17,
45L, "NIR", 1523.83, -2.38,
46L, "PHI", 1512.97, 16.74,
47L, "SVK", 1512.7, -9.43,
48L, "PAR", 1505.2, 1.76,
49L, "UZB", 1498.55, 7.18,
50L, "MYA", 1487.58, -31.46,
51L, "VEN", 1486.32, 0,
52L, "PAN", 1482.51, 0,
53L, "HAI", 1475.33, -2.97,
54L, "RSA", 1471.52, -0.32,
55L, "PNG", 1469.52, 0,
56L, "CMR", 1445.75, 0,
57L, "BLR", 1443.08, 0,
58L, "GHA", 1419.63, 2.86,
59L, "CRO", 1416.26, -1.52,
60L, "IND", 1413.52, 22.22,
61L, "IRN", 1409.89, 40.87,
62L, "GRE", 1405.82, 1.51,
63L, "TUR", 1388.37, 5.13,
64L, "URU", 1385.45, 7.71,
65L, "BIH", 1382.41, -1.74,
66L, "CIV", 1379.39, 0,
67L, "ECU", 1376.11, -1.75,
68L, "ISR", 1358.37, -2.39,
69L, "FIJ", 1345.58, 0,
70L, "EQG", 1344.47, 0,
71L, "ALB", 1342.43, 0,
72L, "MAR", 1334.08, 0.51,
73L, "JOR", 1322.78, -45.96,
74L, "PER", 1318.61, -7.72,
75L, "TRI", 1318.11, 0,
76L, "TUN", 1298.6, 0,
77L, "ZAM", 1298.31, 0.42,
78L, "HKG", 1297.87, 1.84,
79L, "AZE", 1290.24, -6.03,
80L, "ALG", 1288.27, 0,
81L, "MLI", 1273.24, 0,
82L, "SEN", 1264.44, -2.85,
83L, "GUA", 1259.69, 0,
84L, "BHR", 1254.12, 0,
85L, "GUY", 1247.77, 0,
86L, "MLT", 1245.35, 6.77,
87L, "LAO", 1240.52, -17.46,
88L, "EGY", 1229.98, 0,
89L, "MAS", 1228.66, -3.28,
90L, "BUL", 1228.25, 0,
91L, "MNE", 1224.14, 1.86,
92L, "TGA", 1221.48, 0,
93L, "GUM", 1218.07, 0,
94L, "CUB", 1217.56, 0,
95L, "LTU", 1216.59, 0,
96L, "BOL", 1213.1, 0,
97L, "SAM", 1212.01, 0,
98L, "EST", 1211.02, -6.44,
99L, "KAZ", 1205.62, 0,
100L, "FRO", 1201.16, -3.08
) %>%
left_join(DescTools::d.countries |>
mutate(Team = dplyr::case_match(
a3,
"DEU" ~ "GER",
"PHL" ~ "PHI",
"CHE" ~ "SUI",
"CRI" ~ "CRC",
"ZMB" ~ "ZAM",
"GBR" ~ "ENG",
"HTI" ~ "HAI",
"DNK" ~ "DEN",
"VNM" ~ "VIE",
"NLD" ~ "NED",
"PRT" ~ "POR",
"ZAF" ~ "RSA",
.default = a3
)),
by = "Team") |>
mutate(name = case_match(name,
"United Kingdom" ~"England",
"United States" ~ "USA",
"Viet Nam" ~ "Vietnam",
"Korea, Republic of" ~ "South Korea",
.default = name))
# view(DescTools::d.countries, "countries")
fixtures <- tibble::tribble(
~Group, ~Date, ~Match, ~Time.AEST,
"A", "July 20", "New Zealand vs. Norway", 17,
"A", "July 21", "Philippines vs. Switzerland", 15,
"A", "July 25", "New Zealand vs. Philippines", 15.5,
"A", "July 25", "Switzerland vs. Norway", 18,
"A", "July 30", "Switzerland vs. New Zealand", 17,
"A", "July 30", "Norway vs. Philippines", 17,
"B", "July 20", "Australia vs. Rep. of Ireland", 20,
"B", "July 21", "Nigeria vs. Canada", 12.5,
"B", "July 26", "Canada vs. Rep. of Ireland", 20,
"B", "July 27", "Australia vs. Nigeria", 20,
"B", "July 31", "Canada vs. Australia", 20,
"B", "July 31", "Rep. of Ireland vs. Nigeria", 20,
"C", "July 21", "Spain vs. Costa Rica", 17.5,
"C", "July 22", "Zambia vs. Japan", 17,
"C", "July 26", "Spain vs. Zambia", 17.5,
"C", "July 26", "Japan vs. Costa Rica", 15,
"C", "July 31", "Japan vs. Spain", 17,
"C", "July 31", "Costa Rica vs. Zambia", 17,
"D", "July 22", "England vs. Haiti", 19.5,
"D", "July 22", "Denmark vs. China", 20,
"D", "July 28", "England vs. Denmark", 18.5,
"D", "July 28", "China vs. Haiti", 20.5,
"D", "Aug. 1", "China vs. England", 20.5,
"D", "Aug. 1", "Haiti vs. Denmark", 19,
"E", "July 22", "USA vs. Vietnam", 11,
"E", "July 23", "Netherlands vs. Portugal", 17.5,
"E", "July 27", "USA vs. Netherlands", 11,
"E", "July 27", "Portugal vs. Vietnam", 17.5,
"E", "Aug. 1", "Portugal vs. USA", 17,
"E", "Aug. 1", "Vietnam vs. Netherlands", 17,
"F", "July 23", "France vs. Jamaica", 20,
"F", "July 24", "Brazil vs. Panama", 20.5,
"F", "July 29", "France vs. Brazil", 20,
"F", "July 29", "Panama vs. Jamaica", 18.5,
"F", "Aug. 2", "Panama vs. France", 20,
"F", "Aug. 2", "Jamaica vs. Brazil", 20,
"G", "July 23", "Sweden vs. South Africa", 15,
"G", "July 24", "Italy vs. Argentina", 16,
"G", "July 28", "Argentina vs. South Africa", 10,
"G", "July 29", "Sweden vs. Italy", 17.5,
"G", "Aug. 2", "Argentina vs. Sweden", 17,
"G", "Aug. 2", "South Africa vs. Italy", 17,
"H", "July 24", "Germany vs. Morocco", 18.5,
"H", "July 25", "Colombia vs. South Korea", 12,
"H", "July 30", "Germany vs. Colombia", 19.5,
"H", "July 30", "South Korea vs. Morocco", 14,
"H", "Aug. 3", "South Korea vs. Germany", 20,
"H", "Aug. 3", "Morocco vs. Colombia", 18
) |>
mutate(Date = lubridate::mdy(paste(Date, 2023)),
time_Oak = as.POSIXct(Date) + Time.AEST*3600 - 10*3600,
gamenum = row_number(), .before = 1) |>
separate(Match, c("Home.Team", "Away.Team"), sep = " vs. ", remove = FALSE) |>
mutate(across(ends_with("Team"), ~str_remove_all(.x, "Rep. of "))) |>
left_join(ranks |> select(Home_RK = RK, Home_PTS = PTS, Home.Team = name)) |>
left_join(ranks |> select(Away_RK = RK, Away_PTS = PTS, Away.Team = name)) |>
mutate(Home_prob = (1 / (1 + 10 ^ (( Away_PTS - Home_PTS)/400))),
Away_prob = 1 - Home_prob)
fixtures |>
mutate(end = time_Oak + 2 * 3600) |>
mutate(start_hr = hour(time_Oak) + minute(time_Oak)/60,
end_hr = start_hr + 2) |>
arrange(abs(start_hr - 13)) |>
# ggplot(aes(Date, start_hr, color = Group)) +
ggplot(aes(Date, start_hr, color = abs(0.5 - Home_prob))) +
annotate("rect", xmin = ymd(20230720), xmax = ymd(20230805),
ymin = 6, ymax = 22, alpha = 0.1) +
geom_point() +
geom_segment(aes(xend = Date, yend = end_hr), linewidth = 1) +
# geom_text(aes(y = end_hr, label = str_wrap(Match, width = 12),
# alpha = between(start_hr, 4, 22)),
# lineheight = 0.7, size = 2.8, vjust = 0, hjust = 0, angle = 90,
# check_overlap = TRUE) +
ggrepel::geom_text_repel(aes(y = end_hr, label = str_wrap(Match, width = 12)),
lineheight = 0.7, size = 2.8, angle = 90) +
scale_y_reverse(breaks = 0:25, minor_breaks = NULL,
labels = c("midnight",
paste0(1:11, "am"),
"12pm",
paste0(1:11, "pm"),
"12am", "1am")) +
scale_x_date(date_breaks = "1 day", date_labels = "%a %d", minor_breaks = NULL) +
scale_alpha_manual(values = c(0.5,1)) +
facet_wrap(~Group) +
# ggthemes::scale_color_tableau() +
guides(alpha = "none") +
coord_cartesian(clip = "off") +
theme_minimal()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment