semifinals.Rmd

---
title: "EURO 2024 knockout predictions: Semifinals"
author: "Leonardo Egidi - Giulio Fantuzzi | University of Trieste"
date: "09th July 2024"
output:
  pdf_document:
    highlight: tango
    keep_tex: yes
    toc: yes
  html_document:
    df_print: paged
    toc: yes
  include: null
  ioslides_presentation:
    highlight: tango
  prettydoc::html_pretty:
    css: style.css
    theme: leonids
    toc: yes
  beamer_presentation:
    highlight: tango
  slide_level: 2
  slidy_presentation:
    fig.height: 3
    fig.width: 4
    highlight: tango
graphics: yes
header-includes:
- \usepackage{color}
- \usepackage{bm}
institute: University of Trieste
fontsize: 10pt
---

```{r global_options, include=FALSE}
knitr::opts_chunk$set(fig.align = 'center', warning=FALSE, message=FALSE, fig.asp=0.725, 
# fig.height =10, fig.width = 8,
out.width='850px', dpi=300, 
  dev='png', global.par = TRUE, dev.args=list(pointsize=10), fig.path = 'figs/')
library(MASS)
```
```{r setup, include=FALSE}
library(knitr)
local({
  hook_plot = knit_hooks$get('plot')
  knit_hooks$set(plot = function(x, options) {
    paste0('\n\n----\n\n', hook_plot(x, options))
  })
})
```

# The statistical model (in brief)

We use a **diagonal-inflated Bivariate-Poisson model with dynamic team-specific abilities** for the attack and the defence. Let $(X_{i}, Y_{i})$ denote the random number of goals scored by the home and the away team in the $i$-th game, $i=1,\ldots,n$, respectively. $\mathsf{ranking}$ denotes the Coca-Cola FIFA ranking at April 4th, 2024, whereas att and def denote the attack and the defence abilities, respectively.


\begin{align}
(X_i, Y_i) &\ \sim \ \begin{cases} (1-p) \text{BP}(x_i, y_i |\lambda_1, \lambda_2, \lambda_3) \ \ \ & \text{if} \    x \ne y \\ (1-p) \text{BP}(x_i, y_i | \lambda_1, \lambda_2, \lambda_3) + pD(x, \eta) \ \ \ & \text{if} \   x = y, \end{cases}, \\
\log(\lambda_{1i}) &=\    \text{att}_{h_i, t}+ \text{def}_{a_i,t} + \frac{\gamma}{2}(\mathsf{ranking}_{h_i}-\mathsf{ranking}_{a_i}) \\
\log(\lambda_{2i}) & =\    \text{att}_{a_i,t} + \text{def}_{h_i,t} - \frac{\gamma}{2}(\mathsf{ranking}_{h_i}-\mathsf{ranking}_{a_i}), \ \ i=1,\ldots,n\ (\text{matches}), \\
\log(\lambda_{3i}) & =\ \rho,\\
\text{att}_{k, t}&  \sim \ \mathcal{N}(\text{att}_{k, t-1}, \sigma^2), \\
\text{def}_{k, t} & \sim \  \mathcal{N}(\text{def}_{k, t-1}, \sigma^2),\\
\rho, \ \gamma & \sim \mathcal{N}(0,1) \\
p & \sim \text{Uniform}(0,1)\\
& \sum_{k=1}^{n_t} \text{att}_{k, }=0, \  \sum_{k=1}^{n_t}\text{def}_{k, }=0, \ \ k=1,\ldots n_t \ (\text{teams}), \  t=1,\ldots, T \ (\text{times}).
\label{eq:scoring_rue}
\end{align}

Lines (1) displays the likelihood's equations (diagonal inflated bivariate Poisson); lines (2)-(4) display the log-linear models for the scoring rates $\lambda_{1}, \lambda_{2}$ and the covariance parameter $\lambda_3$; lines (5)-(6) display the dynamic prior distributions for the attack and the defence parameters, respectively; lines (7)-(8) display prior distributions for the other model parameters; line (9) displays the sum-to-zero identifiability constraints. Model fitting has been obtained through the Hamiltonian Monte Carlo sampling, 2000 iterations, 4 chains using the ```footBayes``` \texttt{R} package (with the underlying ```rstan``` package). The historical data used to fit the models come from *all the international matches played during the years' range 2020-2024*.

The idea is to provide a dynamic predictive scenario: at the end of each match-day, the model will be refitted  to predict the remaining matches.

# Knockout predictions: Semifinals (09th July - 10th July)

Posterior  matches probabilities from the posterior predictive distribution of the model above are displayed in the table below. **mlo** denotes the *most likely exact outcome* (in parenthesis, the corresponding posterior probability). Darker regions in the plots below denote more likely outcomes: on the $x$-axis the home goals, on the $y$-axis the away goals. 

```{r semifinals, echo = FALSE, out.width="80%", fig.width=11, eval = TRUE, fig.height=16,warning=FALSE, message=FALSE}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Libraries 
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
library(tidyverse)
library(dplyr)
library(footBayes)
library(loo)
library(ggplot2)
library(patchwork)
library(stringi)
library(rstan)

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Global variables
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
DATA_PATH="data/"
IMG_PATH="imgs/"
TABLES_PATH="tables/"
MODELS_PATH="models/"
STAN_ITERS=2000
STAN_CORES=4
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Data preparation
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#-------------------------------------------------------------------------------
# Rankings dataset
#-------------------------------------------------------------------------------
fifa_ranking<-  read.csv2(paste0(DATA_PATH, "fifa_ranking.csv"),
                         sep=",",
                         header=TRUE)
fifa_ranking$total_points <- as.numeric(as.vector(fifa_ranking$total_points))/(10^3)

fifa_ranking_2024<- fifa_ranking %>% 
  filter(rank_date == "2024-04-04") %>% 
  select(country_full, total_points)
  # %>%
#arrange(desc(total_points)) %>%
  #slice(1:150)
colnames(fifa_ranking_2024) <- c("team_name", "ranking")

fifa_ranking_2024<- fifa_ranking_2024 %>%
  mutate(team_name=ifelse(team_name=="Czechia", "Czech Republic", team_name))

#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# Results dataset
#-------------------------------------------------------------------------------
euro_data <- read.csv2(paste0(DATA_PATH, "results.csv"),
                       sep = ",",
                       header = TRUE)
euro_data_train <- euro_data  %>%
  select(date, home_team, away_team, home_score, away_score, tournament) %>%
  filter(year(as.Date(euro_data$date)) >= 2020 ) # keep only last 4 years
# Se vogliamo togliere le amichevoli basta un filter(tournament != "Friendly")

times <- substr(euro_data_train$date, 1, 4) # Così considero annualmente...valutare se prendere anche il mese
times <- as.factor(times)
levels(times) <- c(1:length(levels(times)))
euro_data_train$date <- as.numeric(as.vector(times))
euro_data_train <- arrange(euro_data_train, date)

# Remove rows with missing values
euro_data_train <- euro_data_train %>%
  filter(!is.na(euro_data_train$home_score) & !is.na(euro_data_train$away_score) )

low_teams <- c("Faroe Islands", "Latvia",  "Malta",
"San Marino", "Liechtenstein", "Gibraltar","Andorra",
"Haiti","Sint Maarten",
"Grenada","Cuba","Turks and Caicos Islands",
"Jersey", "Hitra", "Isle of Man",
"Yorkshire", "Panjab", "Somaliland",
"Kernow", "Barawa", "Chagos Islands",
"Cascadia", "Parishes of Jersey", "Alderney",
"Yoruba Nation",   "Matabeleland", "Biafra",
"Mapuche", "Maule Sur", "Aymara", "Saint Helena",
"Shetland","Orkney", "Guernsey", "Western Isles","Timor-Leste","Antigua and Barbuda")
# 
# Keep only matches where teams are not in low_teams
euro_data_train <- euro_data_train %>%
   filter(!(home_team %in% low_teams) & !(away_team %in% low_teams))

# Guarantee the teams are in the ranking
euro_data_train <- euro_data_train %>%
  filter((home_team %in% fifa_ranking_2024$team_name) & (away_team %in% fifa_ranking_2024$team_name) )

#-------------------------------------------------------------------------------
# Prepare stan parameters
#-------------------------------------------------------------------------------
euro_train_teams <- unique(euro_data_train$home_team)
euro_ranking <- fifa_ranking_2024 %>% filter( team_name %in% euro_train_teams)
ngames_prev <- 12
#-------------------------------------------------------------------------------
# Groupstage 1 results
#-------------------------------------------------------------------------------
results_groupstage_1 <- data.frame(
  date = rep(length(levels(times))+1, ngames_prev),
  
  home_team = c("Germany","Hungary","Spain","Italy",
                "Poland","Slovenia","Serbia","Romania",
                "Belgium","Austria","Turkey","Portugal"),
  
  away_team = c("Scotland","Switzerland","Croatia","Albania",
                "Netherlands","Denmark","England","Ukraine",
                "Slovakia","France","Georgia","Czech Republic"),
  
  home_score = c(5,1,3,2,1,1,0,3,0,0,3,2), 
  away_score = c(1,3,0,1,2,1,1,0,1,1,1,1),
  tournament = rep("UEFA Euro", ngames_prev))
#-------------------------------------------------------------------------------
# Groupstage 2 results
#-------------------------------------------------------------------------------
results_groupstage_2 <- data.frame(
  date = rep(length(levels(times))+2, ngames_prev),
  
  home_team = c("Croatia","Germany","Scotland","Slovenia",
                "Denmark","Spain","Slovakia","Poland",
                "Netherlands","Georgia","Turkey","Belgium"),
  
  away_team = c("Albania","Hungary","Switzerland","Serbia",
                "England","Italy","Ukraine","Austria",
                "France","Czech Republic","Portugal","Romania"),
  
  home_score = c(2,2,1,1,1,1,1,1,0,1,0,2),
  away_score = c(2,0,1,1,1,0,2,3,0,1,3,0),
  tournament = rep("UEFA Euro", ngames_prev))
#-------------------------------------------------------------------------------
# Groupstage 3 results
#-------------------------------------------------------------------------------
results_groupstage_3 <- data.frame(
  date = rep(length(levels(times))+3, ngames_prev),
  
  home_team = c("Switzerland","Scotland","Albania","Croatia",
                "France","Netherlands","Denmark","England",
                "Slovakia","Ukraine","Georgia","Czech Republic"),
  
  away_team = c("Germany","Hungary","Spain","Italy",
                "Poland","Austria","Serbia","Slovenia",
                "Romania","Belgium","Portugal","Turkey"),
  
  home_score = c(1,0,0,1,1,2,0,0,1,0,2,1),
  away_score = c(1,1,1,1,1,3,0,0,1,0,0,2),
  tournament = rep("UEFA Euro", ngames_prev))

#-------------------------------------------------------------------------------
# Round of 16 results
#-------------------------------------------------------------------------------
ngames_prev <- 8
results_round_of_16<- data.frame(
  date = rep(length(levels(times))+4, ngames_prev),
  
  home_team = c("Switzerland","Germany","England","Spain",
                "France","Portugal","Romania","Austria"),
  
  away_team = c("Italy","Denmark","Slovakia","Georgia",
                "Belgium","Slovenia","Netherlands","Turkey"),
  
  home_score = c(2,2,1,4,1,0,0,1),
  away_score = c(0,0,1,1,1,0,3,2),
  tournament = rep("UEFA Euro", ngames_prev))

#-------------------------------------------------------------------------------
# Quarter-final results
#-------------------------------------------------------------------------------
ngames_prev <- 4
results_quarter_final<- data.frame(
  date = rep(length(levels(times))+5, ngames_prev),
  
  home_team = c("Spain","Portugal","England","Netherlands"),
  
  away_team = c("Germany","France","Switzerland","Turkey"),
  
  home_score = c(1,0,1,2),
  away_score = c(1,0,1,1),
  tournament = rep("UEFA Euro",ngames_prev)
  )
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# Semifinals matches
#-------------------------------------------------------------------------------
ngames_prev <- 2
euro_data_test<- data.frame(
  date = rep(length(levels(times))+6, ngames_prev),
  
  home_team = c("Spain","Netherlands"),
  
  away_team = c("France","England"),
  
  home_score = rep(NA,ngames_prev),
  away_score = rep(NA,ngames_prev),
  tournament = rep(NA,ngames_prev)
  )
#-------------------------------------------------------------------------------
euro_data_stan <-rbind(euro_data_train,
                       results_groupstage_1,
                       results_groupstage_2,
                       results_groupstage_3,
                       results_round_of_16,
                       results_quarter_final,
                       euro_data_test)

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Model Training
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

fit <- stan_foot(data = euro_data_stan[,-6],
                 model="diag_infl_biv_pois",
                 iter = STAN_ITERS, cores = STAN_CORES,
                 predict= ngames_prev,
                 ranking = euro_ranking,
                 dynamic_type = "seasonal",
                 ind_home = "FALSE")
pars=extract(fit)
save(pars, file = paste0(MODELS_PATH,"semifinals_pars.RData"))

prob <- foot_prob(fit, euro_data_stan[,-6])
colnames(prob$prob_table) <- c("home", "away",
                               "home win", "draw", "away win", "mlo")
knitr::kable(prob$prob_table)
write.csv(prob$prob_table, paste0(TABLES_PATH,"semifinals.csv"), row.names = FALSE)
prob$prob_plot
```