Week 6 Fantasy Football Optimizations

Setup

library(data.table)
library(dtplyr)
library(tidyverse)
library(rPref)
library(kableExtra)

week <- 6

proj <- readRDS(paste0('week_', week, '_proj.RDS'))

sal <- read_csv(paste0('DKSalaries_wk_', week, '.csv'))

I’ll start with the optimized lineups pulled for week 4, with the same details as last time: 10,000 lineups, using the standard deviation of projections, completely individually based (still working on that).

sim_lu <- readRDS(paste0('sim_lineups_week_', week, '.RDS')) %>%
  rename(pts_base=points) %>%
  select(lineup, Name, team, position, pts_base, pts_pred, sd_pts, Salary)

glimpse(sim_lu)

## Observations: 90,000
## Variables: 8
## Groups: Name [134]
## $ lineup   <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2,...
## $ Name     <chr> "Jets", "Julio Jones", "Robert Woods", "Kenyan Drake"...
## $ team     <chr> "NYJ", "ATL", "LAR", "MIA", "CLE", "NOS", "LAR", "BAL...
## $ position <chr> "DST", "WR", "WR", "RB", "WR", "RB", "WR", "QB", "TE"...
## $ pts_base <dbl> 6.074374, 19.892882, 15.482340, 12.329817, 6.553271, ...
## $ pts_pred <dbl> 6.158088, 23.390689, 16.572083, 14.064840, 12.617719,...
## $ sd_pts   <dbl> 0.9960531, 1.1954801, 1.0171230, 1.5419781, 2.7852936...
## $ Salary   <dbl> 1500, 8000, 5600, 4400, 3700, 8000, 7100, 6900, 4800,...

sim_lu %>%
  filter(lineup<=3) %>%
  arrange(lineup, position, desc(pts_pred)) %>%
  mutate_at(vars(pts_base, pts_pred, sd_pts), function(x) round(x, 2)) %>%
  knitr::kable() %>%
  kable_styling() %>%
  column_spec(1, bold=TRUE) %>%
  collapse_rows(columns = 1, valign = 'top') %>%
  scroll_box(height = '600px', width = '100%')

Who is in Optimal Lineups?

sim_lu %>%
  group_by(Name, position, Salary) %>%
  dplyr::summarize(lu=n_distinct(lineup)) %>%
  ungroup() %>%
  group_by(position) %>%
  top_n(10, lu) %>%
  ungroup() %>%
  arrange(position, desc(lu)) %>%
  mutate(Name=factor(Name),
         Name=fct_reorder(Name, lu)) %>%
  ggplot(aes(x=Name, y=lu/1000, fill=Salary)) +
  geom_bar(stat='identity') +
  facet_wrap(~position, ncol = 3, scales='free') +
  coord_flip() +
  scale_y_continuous(labels = scales::comma) +
  scale_fill_viridis_c() +
  xlab('') +
  ylab('Lineups (Thousands)') +
  ggtitle('Top 10 Players Present by Position') 

Some of my observations:

• More favorites this week at QB, with Lamar Jackson being in almost 40% of lineups. Patrick Mahomes comes in next at around 20%. DeShaun Watson is the only other QB in at least 10% of lineups.

• Le’Veon Bell is a heavy favorite at RB, showing up in almost 60% of lineups. Kenyan Drake appears to be the value play.

• Cooper Kupp is the biggest play at WR, with Robert Woods in 2nd (which I resent as a Niners fan). Sanu, Sutton, Crowder, and Parker are all value plays, at relatively low salaries

• It’s the usual suspects at TE, with Kelce being the only one you potentially have to pay up for.

• Jets are a strong favorite at D this week, most likely due to their price. Over the last few weeks, the model has selected the D with the lowest price.

Who is getting placed in Lineups?

DraftKings provides scoring for 347 players this week, but only 134 make it into optimized lineups. Why is that? To determine, I’ll plot projected points vs salary, colored by whether or not they make it into optimized lineups, and sized by their projection standard deviation

plyr_lu <- sim_lu %>%
  group_by(Name, position) %>%
  dplyr::summarize(lu=n_distinct(lineup)) %>%
  ungroup() 

proj %>% 
  filter(avg_type=='weighted') %>%
  mutate(Name = ifelse(pos=="DST", last_name, paste(first_name, last_name))) %>%
  inner_join(sal, by=c("Name")) %>%
  select(Name, team, position, points, Salary, sd_pts) %>%
  left_join(plyr_lu, by='Name') %>%
  replace_na(list(lu=0)) %>%
  mutate(lu_bin=ifelse(lu==0, '0 Lineups', '>=1 Lineups'),
         lu_5=cut(lu,5, labels = FALSE)) %>%
  ggplot(aes(x=Salary, y=points, color=lu_bin, size=sd_pts)) +
  geom_point() +
  scale_color_manual(values = c('red', 'blue'), name="") +
  geom_smooth(inherit.aes = FALSE, aes(x=Salary, y=points), method = 'lm', se=FALSE) +
  ylab('Projected Points') +
  xlab('Salary') +
  ggtitle('Who makes it into Optimized Lineups?') +
  scale_x_continuous(labels=scales::dollar)

Interestingly, we see some players below the fitted line make it into optimal lineups, but we can see that these are due to high player uncertainty, so these are players with high potential to blow up, even though their average prediction is fairly low.

Flex Configurations

In DFS lineups, you have an extra spot to use on an RB, WR, and TE of your chosing

sim_lu %>%
  group_by(lineup) %>%
  mutate(lineup_pts=sum(pts_pred)) %>%
  group_by(lineup, position) %>%
  mutate(n=n()) %>%
  select(lineup, position, n, lineup_pts) %>%
  distinct() %>%
  spread(key=position, value=n) %>%
  filter(RB>=2, TE>=1, WR>=3) %>%
  mutate(flex=case_when(RB==3 ~ 'RB',
                        TE==2 ~ 'TE',
                        WR==4 ~ 'WR')) %>%
  group_by(flex) %>%
  dplyr::summarize(pts=median(lineup_pts),
                   cases=n()) %>%
  knitr::kable() %>%
  kable_styling(full_width = FALSE)

In contrast to previous weeks, where WRs were the most popular optimal configuration, RB’s are the most popular this week, taking the flex spot in 45% of lineups!

Pareto Lineups

lu_df <- sim_lu %>%
  group_by(lineup) %>%
  dplyr::summarize(lineup_pts=sum(pts_pred),
                   lineup_sd=sum(sd_pts)) %>%
  ungroup()

pto <- psel(lu_df, low(lineup_sd) * high(lineup_pts))


ggplot(lu_df, aes(y=lineup_pts, x=lineup_sd)) +
  geom_point() +
  geom_point(data=pto, size=5) +
  ylab('Lineup Points') +
  xlab('Lineup Points St Dev') +
  ggtitle('Lineup Points vs Uncertainty',
          subtitle = 'Pareto Lineups Bolded')

Here’s a look at the pareto lineups.

psel(lu_df, low(lineup_sd) * high(lineup_pts)) %>%
  left_join(sim_lu, by='lineup') %>%
  group_by(lineup) %>%
  arrange(lineup_pts, position, desc(pts_pred)) %>%
  select(lineup, lineup_pts, lineup_sd, Name, team, position, pts_pred, sd_pts, Salary) %>%
  mutate_at(vars(lineup_pts, lineup_sd, pts_pred, sd_pts), function(x) round(x, 2)) %>%
  knitr::kable() %>%
  kable_styling(fixed_thead = T) %>%
  column_spec(1:3, bold=TRUE) %>%
  collapse_rows(columns = 1:3, valign = 'top') %>%
  scroll_box(height = '500px', width = '100%')

Week 6 optimal lineups can be found here