fpl.analytics:

title: "Exploring FPL Bonus Points" author: "Jonathan Phelps" date: "6 August 2018" output: prettydoc::html_pretty: keep_md: true toc: true theme: cayman highlight: vignette

In this post, I am going to look at predicting the number of bonus points that a player will accrue throughout the 2017 FPL season. In each Fixture, bonus points of (3,2,1) are given out to the best 3 performing players. It is rule based with the current version found at https://www.premierleague.com/news/106533.

From the FPL website I can only find information about existing players and their history. Some challenges I face:

Can only see a player's current team e.g. Xherdan Shaqiri will be presented as a Liverpool player in the 2017/18 data, despite playing for Stoke
By not having old FPL players, each previous season will have less valuable information as we have less players available
Don't have in depth fixture data, which makes inference more challenging
Bonus points system is position dependent, so any model would need to account for this. Unfortunately not all the metrics that make up the bonus points is available in the data. Will need to make some assumptions about the underlying distribution of bonus points.

Data is stored in my Github repo fpl-analytics. This can be installed below

library(devtools)
install_github("jphelps13/fpl.analytics")

For this tutorial please make sure you have installed the following packages. I will be using data.table for managing the data.

# Github
library(fpl.analytics)

# CRAN
library(DT) # html tables
library(data.table) # data management
library(MASS) # negative binomial glm
library(ggplot2) # plotting tool
library(stringi) # removing special characters from names
library(pscl) # zero inflated glms
library(rvest) # pluck
library(psych) # headTails

Some manipulation is required from the stored raw data to get a view of all previous seasons for existing players. Function to create is stored in the github package.

# collects the data from fpl.analytics for the vignette
# special characters in player names have been translated to english for ease of use
dt <- extractBpsData(fpl_player_hist, fpl_season_json) 
head(dt, 3)

##    player_key season_name start_cost end_cost total_points minutes
## 1:          1     2006/07         65       64           98    1714
## 2:          1     2007/08         65       65          120    2313
## 3:          1     2008/09         60       60          171    3150
##    goals_scored assists clean_sheets goals_conceded own_goals
## 1:            0       0            0              9         0
## 2:            0       0            0             17         0
## 3:            0       0            0             24         0
##    penalties_saved penalties_missed yellow_cards red_cards saves bonus bps
## 1:               0                0            1         0    58     1   0
## 2:               0                0            0         0    60     2   0
## 3:               1                0            0         0    87     7   0
##    influence creativity threat ict_index ea_index player_name    team
## 1:       0.0        0.0    0.0       0.0        0   Petr Cech Arsenal
## 2:       0.0        0.0    0.0       0.0        0   Petr Cech Arsenal
## 3:       0.0        0.0    0.0       0.0        0   Petr Cech Arsenal
##    position
## 1:      GKP
## 2:      GKP
## 3:      GKP

# Some seasons don't have any "bps" data, so I will remove this and inactive rows
dt <- dt[bps > 0,]
dt <- dt[minutes > 90] # at least one game
# remove newly promoted teams
check_time <- dt[, .(minutes = sum(minutes)), keyby = team]
print(check_time[minutes < 11*90*38, team])

## [1] "Cardiff" "Fulham"  "Wolves"

check_time <- check_time[minutes > 11*90*38,]
dt <- dt[team %in% check_time$team,]

# Currently working with minutes, going to change this to number of games, and make
# some standardised variables
dt[, num_matches := minutes/90]
dt[, bps_match := bps/num_matches]
dt[, start_cost := start_cost/10] # price reported as 10* game value
dt[, end_cost := end_cost/10]

# check by season - can see that 2013/14 is an anomaly, and so, remove
qu <- quantile(dt$bps_match, 0.995)
ggplot() + geom_density(data=dt, aes(x=bps_match, group=season_name, fill=season_name),
               alpha=0.5, adjust=2) + theme_minimal() + scale_x_continuous(0, qu)

dt <- dt[season_name != "2013/14",]

# check by position - the distribution for Goalkeepers is much tighter than
# that for the others. The variance for Forwards is the greatest 
ggplot() + geom_density(data=dt, aes(x=bps_match, group=position, fill=position),
               alpha=0.5, adjust=2) + theme_minimal() + scale_x_continuous(0, qu)

For count data, a Poisson distribution is usually appropriate. The challenge we have is that we don't have individual bps results for each game, which means we can't see the underlying distribution of the data. The sum of independent poisson distributions is also Poisson (source), with equal mean and variance.

Some other models/variations that may be appropriate: Negative binomial regression - if data is overdispersed ie Variance is greater than the mean, then this distribution is more suitable. more information Zero-inflation model - As bonus points are only given to 3 players per match, and the rule base system is weighted in favour of certain events e.g. scoring a goal or saving a penalty, we could expect a class of players to be less likely to get any points.

# check mean & variance, within position
check_poisson <- dt[, .(mu = mean(bps_match), var = var(bps_match)),
                    by = position]
check_poisson[]

##    position       mu      var
## 1:      GKP 17.59105 10.28901
## 2:      DEF 19.01638 12.72020
## 3:      MID 17.37272 17.82786
## 4:      FWD 16.92351 36.00356

# check zero's in the final bonus metric. There are quite a lot
check_zeros <- dt[, .N, keyby = bonus]
ggplot(check_zeros, aes(x = bonus, y = N))+ geom_line() + theme_minimal()

# look at overall bps v final bonus score. Can see that its a lot more linear
# for Forwards, than for other players e.g. goalkeepers.
ggplot(dt, aes(x = bps, y = bonus, size = num_matches)) + facet_wrap(~position) + geom_point() +
   scale_size_continuous(range = c(0,2)) + theme_minimal()

ggplot(dt, aes(x = bps, y = log(bonus), size = num_matches)) + facet_wrap(~position) + geom_point() +
   scale_size_continuous(range = c(0,2)) + theme_minimal()

# visualise distributions of bps_match by position and team. 
ggplot() + geom_density(data=dt, aes(x=bps_match, group=position, fill=position),
               alpha=0.5, adjust=2) + theme_minimal() + facet_wrap(~team) + 
  coord_cartesian(xlim = c(0, qu), ylim = c(0, 0.25))

We can see some interesting differences in the average bps per match for some of the teams above. E.g. Man City and Spurs (Tottenham Hotspurs) have Forwards that get a lot more of their teams share of bonus points, whils they have done poorly at Everton, Huddersfield and Watford.

# visualise distributions of final bonus points by position and team. 
ggplot() + geom_density(data=dt, aes(x=bonus, group=position, fill=position),
                        alpha=0.5, adjust=2) + theme_minimal() + facet_wrap(~team) + 
  coord_cartesian(ylim = c(0, 0.125))

When we look at the final bonus points though, it doesn't always correlate. The key strikers at the clubs tend to get more bonus points, as can be seen by the green right tails. For Man Utd, Defenders receive slightly more bps than players in other positions, but in terms of bonus points, Midfielders and Strikers receive more. Looking at the bps scoring system, the highest two valued are "Forwards scoring a goal" & "Midfielders" scoring a goal at 24 & 18 respectively. Distribution of goals per match are below, scaled and weighted. We would expect that when a Forward scores, the likelihood of receiving bonus points goes up a lot, compared to matches where they don't score.

dt[, goals_matches := goals_scored/num_matches]

ggplot() + geom_density(data=dt[position != "GKP",], 
                        aes(x=goals_matches, fill = position, colour = position,
                            weight = num_matches, y = ..scaled..),
                        alpha=0.5, adjust=2) + theme_minimal() + facet_wrap(~position)

We don't have all the teams, fixture and bonus point data e.g. we are missing variables like pass completion rates and defensive contributions. If we did, we could try simulating the matches, using Poisson distributions for each event e.g goal, assist. For teams like Man City, they have a lot of high scoring players, so the threshold of bps required to receive any bonus points is higher than e.g. for Huddersfield. We could assume that the bps follow their own distribution, but we know the variance for Forwards is much higher than that for Goalkeepers.

A complete model would consider: Fixtures & Home/Away effect e.g.quality of play in different circumstances Quality of the team e.g. threshold required for receiving bonus points Style of play e.g. Defensive or attacking; Formation Exposure i.e. amount of game time per match; number of starts Position. bps point system is positional dependent Transfers, team roster, injuries etc. understanding when a player has low exposure

With the data at hand, I think anything complicated is not appropriate. I've tried some basic Poisson glm's with linear and non-linear effects for bps on bonus, by position, and the results aren't too bad.

# - not using an offset, as the relationship between bonus and bps isn't strictly
#   linear and has an interaction with position
# - can see in plots above, that there is a stronger linear effect for Forwards,
#   whilst more non-linear for the other positions. The log(bps) variable will 
#   capture the linear part.
m_pois <- glm(bonus ~ log(bps):position + bps:position, 
              data = dt, 
              family = poisson(link = "log"))

# glm summary
summary(m_pois)

## 
## Call:
## glm(formula = bonus ~ log(bps):position + bps:position, family = poisson(link = "log"), 
##     data = dt)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -4.6094  -1.2139  -0.2302   0.9099   4.2059  
## 
## Coefficients:
##                        Estimate Std. Error z value Pr(>|z|)    
## (Intercept)          -5.5508906  0.4398979 -12.619  < 2e-16 ***
## log(bps):positionDEF  1.1563687  0.0883255  13.092  < 2e-16 ***
## log(bps):positionFWD  1.3940967  0.0899821  15.493  < 2e-16 ***
## log(bps):positionGKP  1.1228186  0.0968740  11.591  < 2e-16 ***
## log(bps):positionMID  1.1246359  0.0869822  12.929  < 2e-16 ***
## positionDEF:bps       0.0007720  0.0002447   3.154  0.00161 ** 
## positionFWD:bps      -0.0004710  0.0002571  -1.832  0.06695 .  
## positionGKP:bps       0.0006421  0.0004475   1.435  0.15128    
## positionMID:bps       0.0015489  0.0002202   7.033 2.03e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 6450.1  on 974  degrees of freedom
## Residual deviance: 2015.5  on 966  degrees of freedom
## AIC: 4955.4
## 
## Number of Fisher Scoring iterations: 5

# predict
dt$fit_pois <- round(predict(m_pois, type = "response"), 2)
dt$res_pois <- round(dt$bonus - dt$fit_pois, 2)

# visualise bps v bonus, with fit in black
ggplot(dt, aes(x = bps, y = bonus)) + facet_wrap(~position, scales = "free_y") + 
  geom_point(col = "darkgrey") +
  scale_size_continuous(range = c(0,2)) + theme_minimal() +
  geom_line(aes(x = bps, y = fit_pois))

# visualise bonus vs fit, with perfect fit line added in
ggplot(dt, aes(x = bonus, y = fit_pois)) + facet_wrap(~position, scales = "free") + 
  geom_point(col = "darkgrey") +
  scale_size_continuous(range = c(0,2)) + theme_minimal() + 
  geom_abline(intercept = 0, slope = 1)

As expected, there are some issues with the fit:

Assumes each observation is iid
Doesn't take in to account the number of matches played

Below, we can analyse the residuals

check_dt <- dt[order(-res_pois), 
                .(season_name, team, position, player_name, 
                  num_matches, bps, bps_match, bonus, fit_pois, res_pois)]
check_dt[, num_matches := round(num_matches, 1)]
check_dt[, bps_match := round(bps_match, 1)]

DT::datatable(check_dt)

<\/th>\n	season_name<\/th>\n	team<\/th>\n	position<\/th>\n	player_name<\/th>\n	num_matches<\/th>\n	bps<\/th>\n	bps_match<\/th>\n	bonus<\/th>\n	fit_pois<\/th>\n	res_pois<\/th>\n <\/tr>\n <\/thead>\n<\/table>","options":{"columnDefs":[{"className":"dt-right","targets":[5,6,7,8,9,10]},{"orderable":false,"targets":0}],"order":[],"autoWidth":false,"orderClasses":false}},"evals":[],"jsHooks":[]} jphelps13/fpl.analytics documentation built on May 31, 2019, 11:43 p.m. R Package Documentation rdrr.io home R language documentation Run R code online Browse R Packages CRAN packages Bioconductor packages R-Forge packages GitHub packages We want your feedback! Note that we can't provide technical support on individual packages. You should contact the package authors for that. Tweet to @rdrrHQ GitHub issue tracker ian@mutexlabs.com Personal blog What can we improve? Extra info (optional) Embedding an R snippet on your website Add the following code to your website. REMOVE THIS For more information on customizing the embed code, read Embedding Snippets. Close

jphelps13/fpl.analytics

vignettes/bps_tutorial.md
In jphelps13/fpl.analytics:

Overview

Data Exploration

Setup

Get Data

Poisson assumptions

Variables of interest

Modelling

R Package Documentation

Browse R Packages

We want your feedback!

jphelps13/fpl.analytics

vignettes/bps_tutorial.md In jphelps13/fpl.analytics:

Overview

Data Exploration

Setup

Get Data

Poisson assumptions

Variables of interest

Modelling

R Package Documentation

Browse R Packages

We want your feedback!

vignettes/bps_tutorial.md
In jphelps13/fpl.analytics: