Forecasting FPL player scores
I play in a premier league fantasy league, but I don’t watch soccer at all. So I’m interested in making a model that can predict player scores in the upcoming weeks.
Stats from fpl are accesible through the fpl package.
library(pacman)
p_load(tidyverse, magrittr, pander, fplr, goalmodel, rap, jsonlite, glue)
source('../../src/extra.R', echo = F, encoding="utf-8")
current_week <- 29
user_id <- 5367610
players <- fpl_get_player_all()
fixtures <- fpl_get_fixtures()
teams <- fpl_get_teams()
players <- full_join(players, teams %>% select(code, team_name = name), by = c("team_code" = "code"))
By summing up the previous fixtures, we can get the number of goals scored by team.
get_goals_scored <- function(week){
away_scores <- fixtures %>%
filter(event < week) %>%
group_by(team_a) %>%
summarise(score_a = sum(team_a_score, na.rm = T)) %>%
rename(team = team_a)
home_scores <- fixtures %>%
filter(event < week) %>%
group_by(team_h) %>%
summarise(score_h = sum(team_h_score, na.rm = T)) %>%
rename(team = team_h)
inner_join(home_scores, away_scores, by = "team") %>%
mutate(score = score_h + score_a, goals_per_week = score / current_week)
}
goals_scored <- get_goals_scored(current_week)
I use the goalmodel package to predict goals scored in specific matchups. A multiplier is calculated, which is the predicted number of goals divided by the average number of goals scored by the team in a gameweek.
get_predictions_gameweek <- function(week){
f <- fixtures %>% filter(event < current_week)
gm_res <- goalmodel(goals1 = f$team_h_score, goals2 = f$team_a_score,
team1 = f$team_h, team2 = f$team_a)
week <- fixtures %>% filter(event == week)
predv <- predict_expg(gm_res, team1=week$team_h, team2=week$team_a, return_df = T)
bind_rows(
predv %>% select(team = team1, exp = expg1, goals_against = expg2),
predv %>% select(team = team2, exp = expg2, goals_against = expg1)
) %>%
mutate(team = as.numeric(team)) %>%
inner_join(goals_scored, by = "team") %>%
mutate(multiplier = exp / goals_per_week)
}
f <- fixtures %>% filter(event < current_week)
Now we calculate the predicted points for a player in a specific fixture.
I make a simple model for the the upcoming fixtures based on the following principles:
Note that two important elements are ignored in this simple model: Chance to score goals for defenders, and form of players.
Defenders and goalkeepers score 4 points for a clean sheet, and get -1 for each two goals scored against them. I ignore the risk of conceding 4+ goals, and thus only 4 and -1 are modelled, using a poisson distribution based on the expected goal score against.
The estimate of the defender’s bonus points are calculated by making the simplifying assumption that it is related only to the number of clean sheets. If the player has at least three clean sheets, use an individualized bonus per clean sheet value for that player, otherwise the average is used. There is no need to make a seperate consideration for bonus points for forwards and midfielders, since this is already included in the total score.
get_mean_bonus_per_clean_sheet <- function(position){
players %>%
filter(clean_sheets >= 3, bonus > 1, element_type == position) %>%
mutate(bonus_per_clean_sheet = clean_sheets / bonus) %>%
summarise(a = mean(bonus_per_clean_sheet)) %>% pull(a)
}
mean_goalkeeper_bonus_per_clean_sheet <- get_mean_bonus_per_clean_sheet(1)
mean_defender_bonus_per_clean_sheet <- get_mean_bonus_per_clean_sheet(2)
players %<>% mutate(
bonus_per_clean_sheet = ifelse(
clean_sheets >= 3 & bonus > 1,
clean_sheets / bonus,
ifelse(element_type == 1,
mean_goalkeeper_bonus_per_clean_sheet,
mean_defender_bonus_per_clean_sheet))
)
players_get_points <- function(week){
week_predictions <- get_predictions_gameweek(week)
right_join(week_predictions, players, by = "team") %>%
mutate(multiplier = ifelse(is.na(multiplier), 0, multiplier)) %>%
filter(minutes > 500) %>%
mutate(expected_score = case_when(
element_type %in% c(3, 4) ~ points_per_game * multiplier,
element_type %in% c(1, 2) ~ 2 + ppois(0, lambda = goals_against) * (4 + bonus_per_clean_sheet) -
1 * ppois(2, lambda = goals_against, lower = F))) %>%
group_by(id, second_name) %>%
summarise(expected_score = sum(expected_score)) %>%
rename(!!quo_name(glue("gw_{week}")) := expected_score) %>%
ungroup()
}
Use the model to list the best players to get over the upcoming gameweeks
get_forecast <- function(week){
players_get_points(week) %>%
inner_join(players_get_points(week + 1), by = c("id", "second_name")) %>%
inner_join(players_get_points(week + 2), by = c("id", "second_name")) %>%
inner_join(players_get_points(week + 3), by = c("id", "second_name")) %>%
mutate(average = (!!sym(glue("gw_{week}")) + !!sym(glue("gw_{week + 1}")) +
!!sym(glue("gw_{week + 2}")) + !!sym(glue("gw_{week + 3}"))) / 4) %>%
left_join(players, by = c("id", "second_name")) %>%
mutate(position = case_when(
element_type == 1 ~ "G", element_type == 2 ~ "D",
element_type == 3 ~ "M", element_type == 4 ~ "F")) %>%
filter(chance_of_playing_next_round > 0) %>%
select(second_name, team_name, playing = chance_of_playing_next_round, position, ppg = points_per_game, !!sym(glue("gw_{week}")), !!sym(glue("gw_{week + 1}")),
!!sym(glue("gw_{week + 2}")), !!sym(glue("gw_{week + 3}")), average)
}
fcast <- get_forecast(current_week) %>%
arrange(desc(average))
fcast %>% head(30)
| second_name | team_name | playing | position | ppg | gw_29 | gw_30 | gw_31 | gw_32 | average |
|---|---|---|---|---|---|---|---|---|---|
| Aubameyang | Arsenal | 100 | F | 6 | 13.5 | 6.25 | 0 | 9.24 | 7.26 |
| Salah | Liverpool | 100 | M | 7.1 | 9.6 | 7.27 | 6.61 | 5.32 | 7.2 |
| Mané | Liverpool | 100 | M | 6.6 | 8.93 | 6.76 | 6.15 | 4.95 | 6.7 |
| Jiménez | Wolves | 100 | F | 5.2 | 6.32 | 6.11 | 7.19 | 6.95 | 6.64 |
| De Bruyne | Man City | 75 | M | 6.8 | 13.4 | 8.13 | 0 | 4.31 | 6.45 |
| Agüero | Man City | 100 | F | 5.9 | 11.6 | 7.05 | 0 | 3.74 | 5.6 |
| Vardy | Leicester | 100 | F | 6.2 | 9.73 | 6.28 | 0 | 6.32 | 5.58 |
| Mahrez | Man City | 100 | M | 5.5 | 10.8 | 6.57 | 0 | 3.49 | 5.22 |
| Traoré | Wolves | 100 | M | 4 | 4.86 | 4.7 | 5.53 | 5.35 | 5.11 |
| Alli | Spurs | 100 | M | 5.1 | 4.79 | 4.47 | 7.05 | 3.12 | 4.86 |
| Sterling | Man City | 100 | M | 5 | 9.84 | 5.98 | 0 | 3.17 | 4.75 |
| Jota | Wolves | 100 | F | 3.6 | 4.38 | 4.23 | 4.98 | 4.81 | 4.6 |
| Gomez | Liverpool | 100 | D | 4 | 5.35 | 4.43 | 5.54 | 3.04 | 4.59 |
| San Miguel del Castillo | Liverpool | 100 | G | 2.5 | 5.24 | 4.35 | 5.42 | 3 | 4.5 |
| Matip | Liverpool | 100 | D | 4.1 | 5.21 | 4.33 | 5.38 | 2.99 | 4.48 |
| Lovren | Liverpool | 100 | D | 1.9 | 5.21 | 4.33 | 5.38 | 2.99 | 4.48 |
| Lacazette | Arsenal | 100 | F | 3.7 | 8.35 | 3.86 | 0 | 5.7 | 4.48 |
| Pépé | Arsenal | 100 | M | 3.7 | 8.35 | 3.86 | 0 | 5.7 | 4.48 |
| Silva | Man City | 100 | M | 4.7 | 9.25 | 5.62 | 0 | 2.98 | 4.46 |
| van Dijk | Liverpool | 100 | D | 4.8 | 5.14 | 4.28 | 5.32 | 2.96 | 4.43 |
| Sarr | Watford | 100 | M | 4.2 | 3.34 | 3.47 | 4.07 | 6.19 | 4.27 |
| Robertson | Liverpool | 100 | D | 4.9 | 4.92 | 4.12 | 5.08 | 2.88 | 4.25 |
| Alexander-Arnold | Liverpool | 100 | D | 5.7 | 4.84 | 4.06 | 5 | 2.86 | 4.19 |
| Pulisic | Chelsea | 25 | M | 4.4 | 5.49 | 5.82 | 0 | 5.11 | 4.11 |
| Deeney | Watford | 100 | F | 4 | 3.18 | 3.31 | 3.88 | 5.9 | 4.07 |
| Saïss | Wolves | 100 | D | 2.7 | 4.33 | 3.56 | 4.61 | 3.66 | 4.04 |
| de Jesus | Man City | 100 | F | 4.2 | 8.26 | 5.02 | 0 | 2.66 | 3.99 |
| Cahill | Crystal Palace | 100 | D | 2.8 | 4.66 | 4.26 | 2.39 | 4.31 | 3.91 |
| Maddison | Leicester | 100 | M | 4.3 | 6.75 | 4.35 | 0 | 4.39 | 3.87 |
| Snodgrass | West Ham | 100 | M | 3.7 | 3.68 | 3.72 | 3.55 | 4.5 | 3.86 |
Forecast for players on my team
my_team <- players %>% inner_join(
fromJSON(glue("https://fantasy.premierleague.com/api/entry/{user_id}/event/{current_week -1}/picks/"),
simplifyVector = TRUE)$picks %>% mutate(id = element), by = "id")
fcast %>% filter(second_name %in% my_team$second_name)
| second_name | team_name | playing | position | ppg | gw_29 | gw_30 | gw_31 | gw_32 | average |
|---|---|---|---|---|---|---|---|---|---|
| Mané | Liverpool | 100 | M | 6.6 | 8.93 | 6.76 | 6.15 | 4.95 | 6.7 |
| Jiménez | Wolves | 100 | F | 5.2 | 6.32 | 6.11 | 7.19 | 6.95 | 6.64 |
| Vardy | Leicester | 100 | F | 6.2 | 9.73 | 6.28 | 0 | 6.32 | 5.58 |
| van Dijk | Liverpool | 100 | D | 4.8 | 5.14 | 4.28 | 5.32 | 2.96 | 4.43 |
| Alexander-Arnold | Liverpool | 100 | D | 5.7 | 4.84 | 4.06 | 5 | 2.86 | 4.19 |
| Maddison | Leicester | 100 | M | 4.3 | 6.75 | 4.35 | 0 | 4.39 | 3.87 |
| Doherty | Wolves | 100 | D | 4.3 | 3.91 | 3.27 | 4.14 | 3.35 | 3.67 |
| Martial | Man Utd | 100 | M | 5.2 | 4.72 | 4.77 | 0 | 5.15 | 3.66 |
| Tarkowski | Burnley | 100 | D | 3.6 | 2.96 | 1.78 | 4 | 3.86 | 3.15 |
| Ramsdale | Bournemouth | 100 | G | 3.4 | 1.65 | 3.62 | 2.31 | 3.63 | 2.8 |
| Cantwell | Norwich | 100 | M | 3.5 | 2.25 | 5.26 | 0 | 3.48 | 2.75 |
| Bednarek | Southampton | 100 | D | 2.3 | 3.99 | 3.41 | - | 3.28 | - |
Use the model to recommend the team positions for this gameweek
week_forecast <- players_get_points(current_week) %>%
rename(expected_score = !!sym(glue("gw_{current_week}")))
team_score <- inner_join(week_forecast, my_team, by = "second_name") %>%
select(second_name, element_type, expected_score)
goalkeeper <- team_score %>%
filter(element_type == 1) %>% top_n(1, expected_score)
t3_defenders <- team_score %>%
filter(element_type == 2) %>% top_n(3, expected_score)
b2_defenders <- team_score %>%
filter(element_type == 2) %>% top_n(-2, expected_score)
t3_midfielders <- team_score %>%
filter(element_type == 3) %>% top_n(3, expected_score)
b2_midfielders <- team_score %>%
filter(element_type == 3) %>% top_n(-2, expected_score)
t1_forwards <- team_score %>%
filter(element_type == 4) %>% top_n(1, expected_score)
b2_forwards <- team_score %>%
filter(element_type == 4) %>% top_n(-2, expected_score)
remaining_attack <- bind_rows(b2_midfielders, b2_forwards)
t2_attack <- remaining_attack %>% top_n(2, expected_score)
b2_attack <- remaining_attack %>% top_n(-2, expected_score)
remaining_players <- bind_rows(b2_defenders, b2_attack)
t1_remaining <- remaining_players %>% top_n(1, expected_score)
b3_remaining <- remaining_players %>% top_n(-3, expected_score) %>%
arrange(desc(expected_score)) %>%
rowid_to_column("bench_position")
picks <- bind_rows(goalkeeper, t3_defenders, t3_midfielders, t1_forwards, t2_attack, t1_remaining) %>%
full_join(team_score, by = c("second_name", "element_type", "expected_score")) %>%
full_join(b3_remaining, by = c("second_name", "element_type", "expected_score"))
picks %>% mutate(captain = case_when(
second_name == picks %>% arrange(desc(expected_score)) %>% slice(1) %>% pull(second_name) ~ "C",
second_name == picks %>% arrange(desc(expected_score)) %>% slice(2) %>% pull(second_name) ~ "VC",
T ~ NA_character_
)) %>%
arrange(element_type) %>%
mutate(position = case_when(
element_type == 1 ~ "G", element_type == 2 ~ "D",
element_type == 3 ~ "M", element_type == 4 ~ "F"
)) %>% select(player = second_name, position, expected_score, captain, bench_position)
| player | position | expected_score | captain | bench_position |
|---|---|---|---|---|
| Ramsdale | G | 1.65 | - | - |
| Alexander-Arnold | D | 4.84 | - | - |
| van Dijk | D | 5.14 | - | - |
| Bednarek | D | 3.99 | - | - |
| Tarkowski | D | 2.96 | - | 2 |
| Doherty | D | 3.91 | - | 1 |
| Maddison | M | 6.75 | - | - |
| Mané | M | 8.93 | VC | - |
| Pérez | M | 6.91 | - | - |
| Martial | M | 4.72 | - | - |
| Cantwell | M | 2.25 | - | 3 |
| Vardy | F | 9.73 | C | - |
| Ings | F | 5.96 | - | - |
| Jiménez | F | 6.32 | - | - |