Forecasting Fantasy Games Using Monte Carlo Simulations

1
2
3
4
5
6
7
8

# Storing the Access Token and League ID locally
# I use a yalm file to avoid hard-code them 
# or eventually version them in the GitHub :)
library(yaml)

config <- yaml.load_file("../../config/config.yml")
leagueId <- config$leagueId
authToken <- config$authToken

 1
 2
 3
 4
 5
 6
 7
 8
 9
10

# invoking the API
library(httr)
library(glue) # to easily replace vars in the url

# league/matchups url
url <- "http://api.fantasy.nfl.com/v1/league/matchups?leagueId={leagueId}&week={week}&format=json&authToken={authToken}"
week <- 5

# call the api
resp <- httr::GET(glue(url))

1
2

# Is it ok?
resp$status_code

1

## [1] 200

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18

library(jsonlite)
library(tidyverse)
library(kableExtra)

# to convert the json in a "tabular-tibble form"
resp %>% 
  httr::content(as="text") %>%
  fromJSON(simplifyDataFrame = T) %$%  
  leagues %$%
  matchups %>%
  .[[1]] %>% 
  jsonlite::flatten() %>% 
  as.tibble() -> matchups

 matchups %>% 
   select(awayTeam.id, awayTeam.name, homeTeam.name, homeTeam.id) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15

# for each teamIds in the matchup
c(matchups$awayTeam.id) %>%
  map(
    function(.teamId, .week, .leagueId, .authToken, .url) {
      # make the API call
      httr::GET(glue(.url)) %>%
        httr::content(as = "text") %>%
        fromJSON(simplifyDataFrame = T) %>% # transform response body in json
        return()
    },
    .week      = week,
    .leagueId  = leagueId,
    .authToken = authToken,
    .url       = "http://api.fantasy.nfl.com/v1/league/team/matchup?leagueId={.leagueId}&teamId={.teamId}&week={.week}&authToken={.authToken}&format=json"
  )  -> rosters.json

1
2

# this is a list with the team rosters used in this week
rosters.json[[1]]$leagues$matchup$homeTeam$name

1

## [1] "Rio Claro Pfeiferians"

1
2
3
4
5

rosters.json[[1]]$leagues$matchup$homeTeam$players[[1]] %>%
  select(id, name, position, teamAbbr) %>% 
  as.tibble() %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

# auxiliar transformation to extract team roster
extractTeam <- . %>% 
  .$players %>% 
  .[[1]] %>% 
  select( src_id=id, name, position, rosterSlot, fantasyPts ) %>%
  jsonlite::flatten() %>% 
  as.tibble() %>% 
  select(-fantasyPts.week.season, -fantasyPts.week.week ) %>% 
  rename(points = fantasyPts.week.pts) %>% 
  mutate(
    src_id = as.integer(src_id), 
    points = as.numeric(points)
  )

# extract each roster
rosters.json %>% 
  map(function(.json){
    matchup <- .json$leagues$matchup
    tibble(
      home.teamId = as.integer(matchup$homeTeam$id),
      home.name   = matchup$homeTeam$name,
      home.logo   = matchup$homeTeam$logoUrl,
      home.pts    = as.numeric(matchup$homeTeam$pts),
      home.roster = list(extractTeam(matchup$homeTeam)),
      away.teamId = as.integer(matchup$awayTeam$id),
      away.name   = matchup$awayTeam$name,
      away.logo   = matchup$awayTeam$logoUrl,
      away.pts    = as.numeric(matchup$awayTeam$pts),
      away.roster = list(extractTeam(matchup$awayTeam))
    ) %>% 
      return()
  }) %>% bind_rows() -> matchups.rosters

# check the matchups QBs for each team 
matchups.rosters %>% 
  mutate( away.qb = map(away.roster, function(roster) roster %>% filter(rosterSlot=="QB")),
          home.qb = map(home.roster, function(roster) roster %>% filter(rosterSlot=="QB")) ) %>%
  unnest(away.qb, home.qb, .sep=".") %>% 
  select(away.team = away.name, away.qb.name, home.qb.name, home.team=home.name ) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

1
2
3
4

library(ffanalytics)
scrap <- scrape_data(pos = c("QB", "RB", "WR", "TE", "K", "DST"),
                     season = 2018,
                     week = week)

1
2
3
4
5
6

# Quaterback Projection Attributes
scrap$QB %>%  
  filter(player=="Drew Brees") %>% 
  select(4:10) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

1
2
3
4
5
6

# Kickers Projection Attributes
scrap$K %>%  
  filter(player=="Justin Tucker") %>% 
  select(4:10) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16

# function to access 'source_points' directly
playerPointsProjections <- function(.scrap, .score_rules){
  source("../ffanalytics/R/calc_projections.R")
  source("../ffanalytics/R/stats_aggregation.R")
  source("../ffanalytics/R/source_classes.R")
  source("../ffanalytics/R/custom_scoring.R")
  source("../ffanalytics/R/scoring_rules.R")
  source("../ffanalytics/R/make_scoring.R")
  source("../ffanalytics/R/recode_vars.R")
  source("../ffanalytics/R/impute_funcs.R")
  source_points(.scrap, .score_rules)
}

# customized scoring rules
source("./score_settings.R") 
players.points <- playerPointsProjections(scrap, dudes.score.settings)

1
2
3
4
5
6
7

# look the presence of both ids in the projection table
scrap$WR %>% 
  filter( data_src=="NFL" ) %>% 
  select(1:4) %>% 
  head() %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10

# extracting id and src_id from all positions
scrap %>%
  map(function(dft){
    dft %>% 
      filter(data_src=="NFL") %>% 
      select(id, src_id, player, team, pos) %>% 
      return()
  }) %>% 
  bind_rows() %>%
  distinct() -> players.ids

1
2
3
4

# ID mapping
head(players.ids) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

# nest by "id" and merge with "src_id"
players.points %>% 
  select(-pos) %>% 
  group_by(id) %>% 
  nest(.key="points.range") %>%
  # merge ID with SRC_ID
  inner_join(players.ids, by = c("id")) %>%
  select(id, src_id, player, pos, team, points.range) %>% 
  # keep only "ids" at top level
  select(id, src_id, points.range) -> players.ids.points

# auxiliary function to merge roster with player points
mergePoints <- function(.roster, .points){
  .roster %>% 
    left_join(.points, by="src_id") %>% 
    return()
}

# merge points in rosters
matchups.rosters %>% 
  mutate(
    home.roster = map(home.roster, mergePoints, .points=players.ids.points),
    away.roster = map(away.roster, mergePoints, .points=players.ids.points)
  ) -> matchups.points

1
2
3

# "father" dataframe and the first nested column
matchups.points %>% 
  select( home.name, home.roster ) 

1
2
3
4
5
6
7

## # A tibble: 4 x 2
##   home.name             home.roster      
##   <chr>                 <list>           
## 1 Rio Claro Pfeiferians <tibble [15 x 7]>
## 2 Sorocaba Steelers     <tibble [15 x 7]>
## 3 Amparo Bikers         <tibble [15 x 7]>
## 4 Indaiatuba Riders     <tibble [15 x 7]>

1
2

# seeing the first nested data.frame
matchups.points[1,]$home.roster[[1]]

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18

## # A tibble: 15 x 7
##     src_id name              position rosterSlot points    id points.range     
##      <int> <chr>             <chr>    <chr>       <dbl> <int> <list>           
##  1 2558125 Patrick Mahomes   QB       QB           15.8 13116 <tibble [9 x 2]> 
##  2 2507164 Adrian Peterson   RB       RB            4.2  8658 <tibble [9 x 2]> 
##  3 2543773 James White       RB       RB           13.7 11747 <tibble [9 x 2]> 
##  4 2508061 Antonio Brown     WR       WR           22.1  9988 <tibble [9 x 2]> 
##  5 2556370 Michael Thomas    WR       WR            7.4 12652 <tibble [9 x 2]> 
##  6 2558266 George Kittle     TE       TE            8.3 13299 <tibble [9 x 2]> 
##  7 2555430 Alex Collins      RB       W/R           6.6 12628 <tibble [8 x 2]> 
##  8    1581 DeSean Jackson    WR       BN            0    9075 <tibble [4 x 2]> 
##  9 2540158 Zach Ertz         TE       BN           17   11247 <tibble [10 x 2]>
## 10 2540160 Jordan Reed       TE       BN            2.1 11248 <tibble [9 x 2]> 
## 11 2558063 Deshaun Watson    QB       BN           21   13113 <tibble [9 x 2]> 
## 12 2558865 Chris Carson      RB       BN           12.7 13364 <tibble [8 x 2]> 
## 13 2559169 Austin Ekeler     RB       BN           11.9 13404 <tibble [6 x 2]> 
## 14 2507232 Mason Crosby      K        K             3    8742 <tibble [10 x 2]>
## 15  100011 Green Bay Packers DEF      DEF           2     523 <tibble [8 x 2]>

1
2

# look the second level dataframe
matchups.points[1,]$home.roster[[1]][1,]$points.range[[1]]

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12

## # A tibble: 9 x 2
##   data_src      points
##   <chr>          <dbl>
## 1 CBS             16  
## 2 ESPN            18.7
## 3 FantasyPros     22.3
## 4 FantasySharks   19.5
## 5 FFToday         20.5
## 6 FleaFlicker     24.7
## 7 NFL             19.1
## 8 NumberFire      24.6
## 9 Yahoo           18.8

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

### Auxiliary functions

# function to generate .n possible pontuations from .points.range
# it's used to generate the .n simulations to each player
simPlayer <- function(.points.range, .n){

  # just check if the points.range isn't empty
  if(is.null(.points.range)) return( vector(mode = "numeric",.n) )
  if(nrow(.points.range)==0) return( vector(mode = "numeric",.n) )

  # generate a .n vector samples from points.range
  .points.range$points %>% 
    sample(size = .n, replace = T) %>%
    return()

}

# function to add the player pontuation to the team roster dataframe
simTeam <- function(.roster, .n){
  .roster %>% 
    mutate( sim.player = map(points.range, simPlayer, .n=.n) )  %>% 
    return()
}

# this function is in charge to sum the pontuations from 
# each player to generate the .n-size vector with team pontuation
simTeamPoints <- function(.roster){
  .roster %>% 
    filter(rosterSlot!="BN") %>%  # exclude player in bench
    pull(sim.player) %>%          # get the player pontuation simulation
    bind_cols() %>%               # binds the pontuation toghether 
    as.matrix() %>%               # now we have an matrix with # players x # .n simulations
    rowSums(na.rm = T) %>%        # sum each row (simuilation) to get a .n-vector 
    return()                      # each position in this vector is a possible team pontuation
}

### Simulation Code

# number of simulations
n <- 2000

# in the matchups dataframe
matchups.points %>% 
  mutate(
    # just team nicknames to shorter legends :)
    away.nickname = gsub("([a-zA-Z\']+ )?", "", away.name),
    home.nickname = gsub("([a-zA-Z\']+ )?", "", home.name)
  ) %>% 
  mutate(
    home.roster  = map(home.roster, simTeam, .n=n), # add players simulation points
    away.roster  = map(away.roster, simTeam, .n=n), # to each roster
    home.sim.pts = map(home.roster, simTeamPoints), # computes the team simulation
    away.sim.pts = map(away.roster, simTeamPoints)  # points
  ) %>% 
  mutate( 
    home.win    = map2(home.sim.pts, away.sim.pts, function(.x,.y) (.x > .y) ), # computes the 
    away.win    = map(home.win, function(.x) (!.x)), # number of victures of each team
    home.win.prob = map_dbl(home.win, mean, na.rm = T),  # the % of victories
    away.win.prob = map_dbl(away.win, mean, na.rm = T)   # the % of victories
  ) %>%
  mutate(
    # this calculate the difference of score points in each simulation
    score.diff    = map2(home.sim.pts, away.sim.pts, function(.x,.y){.x - .y})
  ) -> simulation

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

# return a summary as a tibble
summaryAsTibble <- . %>% summary() %>% as.list() %>% as.tibble()

# first, lets build team simulation summary
c("home","away") %>% 
  map(function(.prefix, .matchups.sim){
    .matchups.sim %>% 
      select( starts_with(.prefix)) %>% 
      set_names(gsub(pattern = paste0(.prefix,"\\."),replacement = "",x=names(.))) %>% 
      mutate( points = map(sim.pts, summaryAsTibble) ) %>% 
      select(-roster, -win) %>% 
      unnest(points, .sep=".") %>% 
      return()
  },
  .matchups.sim = simulation) %>% 
  bind_rows() -> sim.results

# visualizing the summary 
sim.results %>% 
  select(nickname, win.prob, points=points.Median) %>% 
  mutate(win.prob = win.prob * 100) %>% 
  mutate_at(2:3, round, digits=1) %>% 
  arrange(desc(points)) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16

# lets plot the points distribution from simulation
library(tidybayes) # stat_intervalh
sim.results %>% 
  select( nickname, med.pts = points.Median, sim.pts ) %>% 
  mutate( 
    nickname = as.factor(nickname),
    sim.pts = map(sim.pts, base::sample, size=40) # just to reduce de number of point to be ploted
  ) %>% 
  unnest(sim.pts) %>% 
  ggplot(aes(y=reorder(nickname, med.pts))) +
  stat_intervalh(aes(x=sim.pts), .width = c(seq(.05,.95,.1))) +
  scale_color_brewer() +
  geom_point(aes(x=sim.pts), alpha=.1) +
  theme_minimal() +
  ylab("teams") + xlab("points") +
  theme(legend.position = "none")

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12

simulation %>% 
  mutate(game=paste0(away.nickname, " @ ", home.nickname)) %>% 
  arrange(away.nickname) %>% 
  select(game, score.diff) %>%
  unnest() %>% 
  ggplot(aes(fill=game)) +
  geom_density(aes(score.diff), alpha=.6) +
  geom_vline(aes(xintercept=0),
             linetype=2, color="red") +
  facet_grid(rows=vars(game), switch = "x") +
  theme_minimal() +
  theme( legend.position = "bottom" )

1
2
3
4
5
6

simulation %>% 
  arrange(away.nickname) %>% 
  mutate_at(vars(away.win.prob, home.win.prob), function(x) round(100*x,1)) %>% 
  select(away.nickname, away.win.prob, home.win.prob, home.nickname)  %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17

# comparing simulated values with real values
simulation %>% 
  mutate( 
    away.win.real   = away.pts > home.pts,
    home.win.real   = home.pts > away.pts,
    score.diff.real = home.pts - away.pts,
    away.sim.pts = map_dbl(away.sim.pts, median, na.rm=T),
    home.sim.pts = map_dbl(home.sim.pts, median, na.rm=T),
    score.diff   = map_dbl(score.diff, median, na.rm=T )
  ) %>% 
  mutate_at( vars(away.win.prob, home.win.prob), function(x) round(100*x,2) )%>% 
  select( away.nickname, away.win.prob, away.win.real, away.sim.pts, away.pts, score.diff, score.diff.real, 
          home.pts, home.sim.pts, home.win.real, home.win.prob, home.nickname ) %>% 
  mutate_if(is.numeric, round, digits=1) %>% 
  arrange(away.nickname) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18

# comparing score difference
simulation %>% 
  mutate(
    game=paste0(away.nickname, " @ ", home.nickname),
    score.diff.real = home.pts - away.pts
  ) %>% 
  arrange(away.nickname) %>% 
  select(game, score.diff, score.diff.real) %>%
  unnest() %>% 
  ggplot(aes(fill=game)) +
  geom_density(aes(score.diff), alpha=.6) +
  geom_vline(aes(xintercept=score.diff.real),
             linetype=1, size=1, color="black") +
  geom_vline(aes(xintercept=0),
             linetype=2, color="red") +
  facet_grid(rows=vars(game), switch = "x") +
  theme_minimal() +
  theme( legend.position = "bottom" )

1
2
3
4
5
6
7

# rosted home team
simulation[1,]$home.roster[[1]] %>% 
  filter(rosterSlot != "BN") %>% 
  mutate(points.sim = map_dbl(sim.player,median, na.rm=T)) %>% 
  select(name, position, points) %>% 
   kable() %>%
   kable_styling(bootstrap_options = "striped", full_width = F, font_size = 11)