Fantasy Football Player Rankings

Predictions

The code to generate the predictions is a little tricky, since it uses dplyr’s non standard evaluation (it’s generates them within the do() function). You’ll notice within the if else block of code I’ve removed the return function. The code builds separate models for rushing attempts, passing attempts, receiving yards, etc. for a total of 12 models. The first three metrics, rushing attempts, receiving targets, and passing attempts are the “opportunity” metrics and are modeled using a k-nearest neighbors algorithm. The justification for this that Sean provides is that penalized linear models used for other 9 rate metics would “shrink” the predictions too much (push them toward the average). The ultimate projections for player performance are heavily influenced by the opportunity projections, so it’s very important to get them right.

mySummary <- function(data, lev = NULL, model = NULL) {
    out <- c(mean(abs(data$obs - data$pred)), 
                     Evaluation.NDCG(order(data$pred), data$obs))
    names(out) <- c('MAE', 'NDCG')
    out
}
ctrl <- trainControl(method = 'cv',
                                         number = 10,
                                         summaryFunction = mySummary)

config <- data_frame(metric = c('ra', 'trg', 'pa', 'rec_trg', 'ry_ra', 'tdr_ra', 'tdrec_trg', 'recy_trg', 'py_pa', 'tdp_pa', 'ints_pa', 'fuml_ratrg'),
                                         method = c('kknn', 'kknn', 'kknn', rep('glmnet', 9)),
                                         outcome.metric = c('NDCG', 'NDCG', 'NDCG', rep('RMSE', 9)),
                                         maximize = c(TRUE, TRUE, TRUE, rep(FALSE, 9)),
                                         key = 1)


positions <- data_frame(pos1 = c('WR', 'TE', 'RB', 'QB'), key = 1)
cutoffs <- data_frame(cutoff = 2016:2017, key = 1)


preds <- config %>%
    inner_join(positions) %>%
    inner_join(cutoffs) %>%
    group_by(metric, pos1, cutoff) %>% do({
        my.metric <- first(.$metric)
        my.pos <- first(.$pos1)
        my.cutoff <- first(.$cutoff)
        for.reg <- season.metrics %>%
            filter(metric == my.metric) %>%
            dplyr::select(player, seas, value) %>%
            inner_join(features, by = c('player', 'seas')) %>%
            filter(pos1 == my.pos) %>%
            ungroup()
        if (str_detect(my.metric, 'pa') & my.pos != 'QB') {
            for.reg$yhat <- 0
            for.reg %>% select(player, seas, yhat = yhat)
        } else if (str_detect(my.metric, 'trg') & my.pos == 'QB') {
            for.reg$yhat <- 0
            for.reg %>% select(player, seas, yhat = yhat)
        } else if (str_detect(my.metric, 'ra') & my.pos %in% c('TE', 'WR')) {
            for.reg$yhat <- 0
            for.reg %>% select(player, seas, yhat = yhat)
        } else {
        X <- model.matrix( ~ 0 + ., for.reg %>% dplyr::select(-player, -value, -pos1))
        nzv <- nearZeroVar(X)
        X <- X[, -nzv]
        y <- with(for.reg, value)
        trainable <- !is.na(y) & (for.reg$seas <= my.cutoff)
        fit <- train(X[trainable,],y[trainable],
                                 metric = first(.$outcome.metric),
                                 method = first(.$method),
                                 maximize = first(.$maximize),
                                 trControl = ctrl,
                                 preProcess = c("center", "scale"))
        for.reg$yhat <- predict(fit, X)
        for.reg %>% dplyr::select(player, seas, yhat = yhat)
        }
    })

Rankings based on Predictions

rnks <- preds %>%
    spread(metric, yhat) %>%
    mutate(py = pa * py_pa,
                 tdp = pa * tdp_pa,
                 ints = pa * ints_pa,
                 rec = trg * rec_trg,
                 recy = trg * recy_trg,
                 ry = ra * ry_ra,
                 td = trg * tdrec_trg+ ra * tdr_ra,
                 fuml = fuml_ratrg * (ra + pa + trg),
                 fpts = py / 25 
                 + recy / 15 
                 + ry / 10 
                 + rec * 0.5 
                 + (td + tdp) * 6 
                 + ints * -2 
                 + fuml * -2) %>%
    left_join(player %>% select(player, pos1, fname, lname)) %>%
    dplyr::select(seas, player, fname, lname, pos1, fpts) %>%
    group_by(cutoff, seas, pos1) %>%
    arrange(-fpts) %>%
    mutate(rnk = row_number())

## Joining, by = c("pos1", "player")

## Adding missing grouping variables: `cutoff`

rnks %>% filter(pos1 == 'RB', seas == 2018, cutoff == 2017) %>% 
  dplyr::select(player,fname,lname,pos1,fpts,rnk) %>%
  .[1:20,] %>% knitr::kable()

## Warning: package 'bindrcpp' was built under R version 3.4.4

## Adding missing grouping variables: `cutoff`, `seas`

rnks %>% filter(pos1 == 'WR', seas == 2018, cutoff == 2017) %>% 
  dplyr::select(player,fname,lname,pos1,fpts,rnk) %>%
  .[1:20,] %>% knitr::kable()

## Adding missing grouping variables: `cutoff`, `seas`

rnks %>% filter(pos1 == 'QB', seas == 2018, cutoff == 2017) %>%
  dplyr::select(player,fname,lname,pos1,fpts,rnk) %>%
  .[1:20,] %>% knitr::kable()

## Adding missing grouping variables: `cutoff`, `seas`

rnks %>% filter(pos1 == 'TE', seas == 2018, cutoff == 2017) %>% 
  dplyr::select(player,fname,lname,pos1,fpts,rnk) %>%
  .[1:20,] %>% knitr::kable()

## Adding missing grouping variables: `cutoff`, `seas`

Model Performance Plots

truth <- season.metrics %>%
    filter(seas == 2017) %>%
    dplyr::select(-career.year, -lst, -avg) %>%
    spread(metric, value) %>%
    mutate(fpts = py / 25 
                 + recy / 15 
                 + ry / 10 
                 + rec * 0.5 
                 + (tdr + tdrec + tdp) * 6 
                 + ints * -2 
                 + fuml * -2) %>%
    arrange(-fpts) %>%
    mutate(rnk = row_number())

rnks %>%
    filter(cutoff == 2016, seas == 2017) %>%
    inner_join(truth %>% dplyr::select(player, seas, fpts.true = fpts)) %>%
    ggplot(aes(x = fpts, y = fpts.true)) + 
    geom_point() +
    facet_wrap('pos1', scales = 'free') +
    theme_bw() +
    geom_abline() +
    xlab('Projected Points') +
    ylab('Actual Points')

## Joining, by = c("seas", "player")

Comments

These predictions do not seem very good at all to me. Looking at the last plot you can see the immense variability about the 45 degree line, some of the estimates are off by very large amounts. This is maybe not surprising when you consider the very limited basis on which the “opportunity” (rushing attempts, etc) projections are made. There is a lot of information that is not captured by previous data. Allowing for smooth functions of the predictors in the rate models would probably improve the performance as well.

Ultimately, in my opinion a better approach to fantasy football player projection is something like what is done at Fantasy Football Analytics. The approach they take is to combine the projections of lots of analysts via some weighting scheme. This would allow the incorporation of a lot more information than the models above, as well as averaging over particular analyst biases.