Predicting the winner of the 2018 FIFA World Cup predictions

# Predicting the winner of the 2018 FIFA World Cup predictions
### Claus Thorn Ekstrøm<br>UCPH Biostatistics<br>.small[<a href="mailto:ekstrom@sund.ku.dk">ekstrom@sund.ku.dk</a>]
### eRum 2018, May 16th, 2018<br>.small[Slides @ <a href="www.biostatistics.dk/talks/">biostatistics.dk/talks/</a>]

---

???

This is a picture of a crazy Danish football fan.

Let us make a prediction: Who here believes that Denmark could win the 2018 World Cup.

OUT

Here we see the problem. We can all make predictions ... want to evaluate the predictions.

---

---

# Modeling a single match

ELO ratings. Two teams `$A$` and `$B$` with (external) ratings.

`$$P(\text{Team } A \text{ wins}) = \frac{1}{(1 + 10^{(\text{elo}_B - \text{elo}_A)/400})}$$`

```r
prob <- 1/(1 + 10^((elo[team2] - elo[team1])/400))
Awon <- rbinom(1, size=1, prob=prob)
```

After match: update ELO scores.

---

# Modeling a single match

Goals scored by each team simulated from two Poisson distributions.

*   Team A goals: `$\sim \text{Poiss}(\lambda_A)$`
*   Team B goals: `$\sim \text{Poiss}(\lambda_B)$`

Restrict `$\lambda_A$` and `$\lambda_B$` to use skill levels and make results realistic.

```r
Agoals <- rpois(1, lambdaA)
Bgoals <- rpois(1, normalgoals-lambdaA)
```

---

---

# What makes a good prediction?

---

---

## Evaluating a prediction

.pull-left[
*   Take **all** predictions into account. Not just the winner.
*   Penalize **confident** classifications that are **incorrect**.
]

.pull-right[
Prediction: 32 x 32 matrix
.footnotesize[
```
      [,1] [,2] [,3] [,4] 
 [1,] 0.00 0.00 0.00 0.02 
 [2,] 0.00 0.00 0.00 0.04 
 [3,] 0.01 0.01 0.00 0.07 
 [4,] 0.00 0.00 0.01 0.08
```

Rows = ranks, 
columns = countries
]

]

>    "It’s better to be somewhat wrong than emphatically wrong. 
>    Of course it’s always better to be right"

---

# Log-loss

Heavily penalises confident classifications that are incorrect.

`$$-\sum_\text{ranking}\sum_\text{country}I(\text{country c has rank r})\log(\hat{p_{rc}})$$`

**Problems**

*   No proper ordering for all but ranks 1-4
*   It *feels* most important to correctly rank the top
*   We have no real representative data to test this out on. (On July 15th we have `$N=1$`)

---

# Weighted log-loss

To put more emphasis on the top positions add weights, `$w_r$`

`$$-\sum_\text{ranking}\sum_\text{country}w_rI(\text{country c has rank r})\log(\hat{p_{rc}})$$`

Weights:

*   1 for ranks 1, 2
*   1/2 for ranks 3,4
*   1/4 for ranks 5-8
*   ...
---

# Missing ranks

We are missing ranks for all but the first 4.

**Solution** Collapse probabilities into **7** rank groups: 1, 2, 3, 4, 5-8, 9-16, 17-32.

---

# Evaluating the model

Use the European Championship 2016 data as *training* data

Representative? [24 teams, European, no 3rd place, ...]

| Rank | Country |
|----|-------------|
|1 | Portugal |
|.black[2] | .black[France] |
|3-4 | Germany, Wales |
|.black[5-8] | .black[Poland, Belgium, Iceland, Italy] |
|9-16 | .footnotesize[Croatia, England, Hungary, Spain, Switzerland, Ireland Slovakia] |

---

---

# Comparing models from UEFA 2016

| Model | Weighted log-loss |
|----|-------------|
| Grandma |  19.06 |
|.black[ELO (no update)] | .black[11.96] |
| ELO with update | 11.03 |
| .black[Skellam] |  .black[12.71] |
| Armchair supercoach | 21.22 |

Conclusions: Able to differentiate but could be room for improvement.

---

# Do it yourself

1.   Go to `github.com/ekstroem/socceR2018` and download/clone repository.
2.   Fix the `play_game` function with **your** prediction model.
3.   Create a PR before June 15th with **your** prediction model.
4.   Wait for July 15th and we will have a full R community of predictions ...
5.   ... @ eRum 2020? Declare the winner!

---

# Example `play_game`

```r
# Input: First three arguments are fixed. Default values are given
# Returns: a matrix with length(team1) rows 
# and 2 columns with goals
play_game <- function(team_data, team1, team2, ...) {
  ## Simplest version. All teams are equal in skill
  result <- cbind(rpois(length(team1), lambda=2.75/2), 
                  rpois(length(team1), lambda=2.75/2))
}

result <- simulate_tournament(1000)
```
]

---