Merge pull request #34 from nflverse/fg_rework

tweak fg model

.gitignore

@@ -46,3 +46,7 @@ docs/
 
 # translation temp files
 po/*~
+
+# model debris
+*.ubj
+

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: nfl4th
 Title: Functions to Calculate Optimal Fourth Down Decisions in the National Football League
-Version: 1.0.4.9004
+Version: 1.0.4.9005
 Authors@R: 
     c(person(given = "Ben",
              family = "Baldwin",

NEWS.md

@@ -2,6 +2,7 @@
 
 * Stop letting roof break things
 * New location for pre-computed numbers
+* Re-work field goal model. Takes into account improvements in accuracy (especially on long kicks) and gives probability > 0 on kicks of over 70 yards
 
 # nfl4th 1.0.4
 

R/decision_functions.R

@@ -58,20 +58,26 @@ get_fg_wp <- function(pbp) {
     as_tibble() %>%
     dplyr::rename(fg_make_prob = value)
 
+  # probability 58 yard field goal is made in environment (indoor/ourdoor) / era (2014-2019 or 2020+)
+  # used to decay prob for longer kicks
+  fg_prob_58 <- as.numeric(mgcv::predict.bam(fg_model, newdata = pbp |> mutate(yardline_100 = 40), type="response")) %>%
+    as_tibble() %>%
+    dplyr::rename(fg_make_prob_58 = value)
+
   dat <- bind_cols(
     pbp,
-    fg_prob
+    fg_prob,
+    fg_prob_58
   ) %>%
     mutate(
-      # don't recommend kicking when fg is over 63 yards (this is very scientific)
-      fg_make_prob = ifelse(yardline_100 > 45, 0, fg_make_prob),
-      # hacky way to not have crazy high probs for long kicks
-      # because the bot should be conservative about recommending kicks in this region
-      # for 56 through 60 yards
-
-      # note: if you're implementing this for your own team, provide your own estimates of your kicker's
-      # true probs
-      fg_make_prob = ifelse(yardline_100 >= 38, .9 * fg_make_prob, fg_make_prob),
+      # linear drop from prob at 58 yards (40 yard line) to 0 at 71 (53 yard line)
+      # example: kick at 44 yard line (62 yard FG) has 69% chance of what a 58 yard FG has (40 yard line)
+      # this is very hacky but selection bias in kicks makes long FG hard
+      scalar = (53 - yardline_100) / 13,
+      fg_make_prob = ifelse(yardline_100 > 40, scalar * fg_make_prob_58, fg_make_prob),
+
+      # don't recommend kicking when fg is over 70 yards (this is very scientific)
+      fg_make_prob = ifelse(yardline_100 >= 53, 0, fg_make_prob),
 
       fg_index = 1 : n()
     )

R/helpers.R

@@ -20,7 +20,7 @@ team_name_fn <- function(var) {
 
 # helper column to avoid join errors
 drop.cols <- c(
-  "game_id", "week",  "model_roof", "roof", "era3", "era4", "era", "home_total", "away_total", "total_line", "spread_line",
+  "game_id", "week",  "model_roof", "roof", "era3", "era4", "home_total", "away_total", "total_line", "spread_line",
   "retractable", "dome", "outdoors"
 )
 
@@ -41,8 +41,12 @@ get_games_file <- function() {
       era0 = 0, era1 = 0, era2 = 0,
       era3 = dplyr::if_else(season > 2013 & season <= 2017, 1, 0),
       era4 = dplyr::if_else(season > 2017, 1, 0),
+
       # for field goal model
-      era = 3,
+      fg_roof = case_when(roof == "outdoors" ~ 1, TRUE ~ 0),
+      fg_era = case_when(season >= 2020 ~ 1, TRUE ~ 0),
+      fg_model_roof = paste0(fg_roof, fg_era) |> as.factor(),
+
       home_total = (total_line + spread_line) / 2,
       away_total = (total_line - spread_line) / 2,
       retractable = dplyr::if_else(model_roof == 'retractable', 1, 0),
@@ -57,7 +61,7 @@ get_games_file <- function() {
     dplyr::mutate_at(dplyr::vars("home_team", "away_team"), team_name_fn) %>%
     dplyr::select(
       game_id, season, type, week, away_team, home_team, espn,
-      model_roof, roof, era0, era1, era2, era3, era4, era, home_total, away_total, total_line, spread_line,
+      fg_model_roof, model_roof, roof, era0, era1, era2, era3, era4, home_total, away_total, total_line, spread_line,
       retractable, dome, outdoors
     ) %>%
     return()

data-raw/_punt_and_fg_models.R

@@ -167,25 +167,20 @@ bind_rows(
 
 # **************************************************************************************
 # field goals
-seasons <- 2014:2019
 
-pbp <- purrr::map_df(seasons, function(x) {
-  readRDS(
-    url(
-      glue::glue("https://raw.githubusercontent.com/nflverse/nflfastR-data/master/data/play_by_play_{x}.rds")
-    )
-  ) %>%
+pbp <- nflreadr::load_pbp(2014 : nflreadr::get_current_season()) %>%
     filter(
       play_type_nfl == "FIELD_GOAL"
-    )
-}) %>%
+    ) %>%
   mutate(
-    roof = if_else(roof %in% c("open", "closed"), "retractable", roof),
-    model_roof = as.factor(roof)
+    fg_roof = case_when(roof == "outdoors" ~ 1, TRUE ~ 0),
+    fg_era = case_when(season >= 2020 ~ 1, TRUE ~ 0),
+    fg_model_roof = paste0(fg_roof, fg_era) |> as.factor()
+
   )
 
 #estimate model
-fg_model <- mgcv::bam(sp ~ s(yardline_100, by = interaction(model_roof)) + model_roof,
+fg_model <- mgcv::bam(sp ~ s(yardline_100, by = interaction(fg_model_roof)) + fg_model_roof,
                       data = pbp, family = "binomial")
 
 save(fg_model, file = 'data-raw/fg_model.Rdata')