Add vegas_wpa, out_of_bounds, fantasy player columns

NEWS.md

@@ -15,6 +15,8 @@ required for `calculate_win_probability()`
 * Fixed a bug related to the calculation of EPA on plays before a failed pass interference challenge in a few 2019 games (#175)
 * Fixed a bug related to lots of fields with `NA` on offsetting penalties (#44)
 * Switched data source for 2001-2010 to what is used for 2011 and on
+* Added columns `vegas_wpa` and `vegas_home_wpa` which contain Win Probability Added from the spread-adjusted WPA model
+* Fix bug in `epa` when possession team changes at end of 1st or 3rd quarter (#182)
 
 # nflfastR 3.2.0
 

R/helper_add_ep_wp.R

@@ -797,13 +797,19 @@ add_wp_variables <- function(pbp_data) {
   pbp_data <- pbp_data %>%
     dplyr::mutate(
       wp = OffWinProb,
-      vegas_wp = OffWinProb_spread) %>%
+      vegas_wp = OffWinProb_spread,
+      # for figuring out posteam on NA posteam lines
+      tmp_posteam = .data$posteam
+      ) %>%
     tidyr::fill(
       .data$wp, .direction = "up"
     ) %>%
     tidyr::fill(
       .data$vegas_wp, .direction = "up"
     ) %>%
+    tidyr::fill(
+      .data$tmp_posteam, .direction = "up"
+    ) %>%
     dplyr::mutate(
       wp = dplyr::if_else(is.na(.data$posteam), NA_real_, .data$wp),
       def_wp = 1 - .data$wp,
@@ -813,9 +819,8 @@ add_wp_variables <- function(pbp_data) {
                                .data$wp, .data$def_wp),
 
       #add columns for WP taking into account spread
-      vegas_wp = dplyr::if_else(is.na(.data$posteam), NA_real_, .data$vegas_wp),
-      vegas_home_wp = dplyr::if_else(.data$posteam == .data$home_team,
-                                     .data$vegas_wp, 1 - .data$vegas_wp),
+      # vegas_wp = dplyr::if_else(is.na(.data$posteam), NA_real_, .data$vegas_wp),
+      vegas_home_wp = dplyr::if_else(.data$tmp_posteam == .data$home_team, .data$vegas_wp, 1 - .data$vegas_wp),
       #make 1 or 0 the final win prob
       vegas_home_wp = dplyr::if_else(
         stringr::str_detect(
@@ -827,7 +832,9 @@ add_wp_variables <- function(pbp_data) {
           .data$home_score == .data$away_score ~ .5
         ),
         .data$vegas_home_wp
-      )
+      ),
+      vegas_home_wpa = dplyr::lead(.data$vegas_home_wp) - .data$vegas_home_wp,
+      vegas_wpa = dplyr::if_else(.data$tmp_posteam == .data$home_team, .data$vegas_home_wpa, -.data$vegas_home_wpa)
     )
 
   # For now follow the code from before, will need to update later:

R/helper_add_nflscrapr_mutations.R

@@ -36,14 +36,14 @@ add_nflscrapr_mutations <- function(pbp) {
     dplyr::arrange(.data$order_sequence, .data$quarter, !is.na(.data$quarter_seconds_remaining), -.data$quarter_seconds_remaining, !is.na(.data$drive), .data$drive, .data$index, .by_group = TRUE) %>%
     dplyr::ungroup() %>%
     dplyr::mutate(
-      # Fill in the rows with missing posteam with the lag:
+      # Fill in the rows with missing posteam with the lead:
       posteam = dplyr::if_else(
         (.data$quarter_end == 1 | .data$posteam == ""),
-        dplyr::lag(.data$posteam),
+        dplyr::lead(.data$posteam),
         .data$posteam),
       posteam_id = dplyr::if_else(
         (.data$quarter_end == 1 | .data$posteam_id == ""),
-        dplyr::lag(.data$posteam_id),
+        dplyr::lead(.data$posteam_id),
         .data$posteam_id),
       # Denote whether the home or away team has possession:
       posteam_type = dplyr::if_else(.data$posteam == .data$home_team, "home", "away"),

R/helper_additional_functions.R

@@ -35,7 +35,12 @@
 #' \item{passer_id}{ID of the player in the 'passer' column (NOTE: ids vary pre and post 2011 but are consistent for each player. Please see details for further information)}
 #' \item{rusher_id}{ID of the player in the 'rusher' column (NOTE: ids vary pre and post 2011 but are consistent for each player. Please see details for further information)}
 #' \item{receiver_id}{ID of the player in the 'receiver' column (NOTE: ids vary pre and post 2011 but are consistent for each player. Please see details for further information)}
+#' \item{fantasy_id}{ID of the rusher on rush players or receiver on pass players.}
 #' \item{name}{Name of the 'passer' if it is not 'NA', or name of the 'rusher' otherwise.}
+#' \item{fantasy}{Name of the rusher on rush players or receiver on pass plays.}
+#' \item{fantasy_id}{ID of the rusher on rush players or receiver on pass plays.}
+#' \item{fantasy_player_name}{Name of the rusher on rush players or receiver on pass plays (from official stats).}
+#' \item{fantasy_player_id}{ID of the rusher on rush players or receiver on pass plays (from official stats).}
 #' \item{jersey_number}{Jersey number of the player listed in the 'name' column.}
 #' \item{id}{ID of the player in the 'name' column (NOTE: ids vary pre and post 2011 but are consistent for each player. Please see details for further information)}
 #' \item{qb_epa}{Gives QB credit for EPA for up to the point where a receiver lost a fumble after a completed catch and makes EPA work more like passing yards on plays with fumbles.}
@@ -51,7 +56,7 @@ clean_pbp <- function(pbp, ...) {
     usethis::ui_info("Nothing to clean. Return passed data frame.")
     r <- pbp
   } else{
-    rlang::inform(paste0(crayon::red(cli::symbol$bullet), " Cleaning up play-by-play... (", crayon::yellow(cli::symbol$info), " If you run this with a lot of seasons this could take a few minutes.)"))
+    rlang::inform(paste0(crayon::red(cli::symbol$bullet), " Cleaning up play-by-play..."))
 
     # Load id map to standardize player ids for players that were active before 2011
     # and in or after 2011 meaning they appear with old gsis_ids and new ids
@@ -213,7 +218,30 @@ clean_pbp <- function(pbp, ...) {
         dplyr::vars(.data$passer_id, .data$rusher_id, .data$receiver_id, .data$id, ends_with("player_id")),
         update_ids, legacy_id_map) %>%
       dplyr::arrange(.data$index) %>%
-      dplyr::select(-"index")
+      dplyr::select(-"index") %>%
+      # add action player
+      dplyr::mutate(
+        fantasy_player_name = case_when(
+          !is.na(.data$rusher_player_name) ~ .data$rusher_player_name,
+          is.na(.data$rusher_player_name) & !is.na(.data$receiver_player_name) ~ .data$receiver_player_name,
+          TRUE ~ NA_character_
+        ),
+        fantasy_player_id = case_when(
+          !is.na(.data$rusher_player_id) ~ .data$rusher_player_id,
+          is.na(.data$rusher_player_id) & !is.na(.data$receiver_player_id) ~ .data$receiver_player_id,
+          TRUE ~ NA_character_
+        ),
+        fantasy = case_when(
+          !is.na(.data$rusher) ~ .data$rusher,
+          is.na(.data$rusher) & !is.na(.data$receiver) ~ .data$receiver,
+          TRUE ~ NA_character_
+        ),
+        fantasy_id = case_when(
+          !is.na(.data$rusher_id) ~ .data$rusher_id,
+          is.na(.data$rusher_id) & !is.na(.data$receiver_id) ~ .data$receiver_id,
+          TRUE ~ NA_character_
+        )
+      )
   }
 
   message_completed("Cleaning completed", ...)

R/helper_decode_player_ids.R

@@ -4,7 +4,7 @@
 # Code Style Guide: styler::tidyverse_style()
 ################################################################################
 
-#' Decode the player IDs in nflfastR play-by-ply data
+#' Decode the player IDs in nflfastR play-by-play data
 #'
 #' @inheritParams clean_pbp
 #' @param fast If \code{TRUE} the IDs will be decoded with the high efficient
@@ -14,9 +14,9 @@
 #' which can take several days to fix on CRAN.)
 #'
 #' @description Takes all columns ending with \code{'player_id'} as well as the
-#' variables \code{'passer_id'}, \code{'rusher_id'}, \code{'receiver_id'} and \code{'id'}
-#' of an nflfastR play-by-play data set and decodes the player IDs to the commonly
-#' known GSIS ID format 00-00xxxxx.
+#' variables \code{'passer_id'}, \code{'rusher_id'}, \code{'fantasy_id'},
+#' \code{'receiver_id'}, and \code{'id'} of an nflfastR play-by-play data set
+#' and decodes the player IDs to the commonly known GSIS ID format 00-00xxxxx.
 #'
 #' The function uses by default the high efficient \link[gsisdecoder]{decode_ids}
 #' of the package \href{https://cran.r-project.org/package=gsisdecoder}{\code{gsisdecoder}}.
@@ -62,7 +62,7 @@ decode_player_ids <- function(pbp, ..., fast = TRUE) {
     ret <- pbp %>%
       dplyr::mutate_at(
         dplyr::vars(
-          tidyselect::any_of(c("passer_id", "rusher_id", "receiver_id", "id")),
+          tidyselect::any_of(c("passer_id", "rusher_id", "receiver_id", "id", "fantasy_id")),
           tidyselect::ends_with("player_id")
         ),
         decode_ids, pp

R/helper_variable_selector.R

@@ -22,7 +22,7 @@ select_variables <- function(pbp) {
 }
 
 # columns that are not in gamecenter that we created
-new_cols <- c("season", "cp", "cpoe", "series", "series_success", "series_result")
+new_cols <- c("season", "cp", "cpoe", "series", "series_success", "series_result", "vegas_home_wpa", "vegas_wpa")
 
 # original nflscrapr columns
 nflscrapr_cols <-

R/top-level_scraper.R

@@ -119,6 +119,8 @@
 #' \item{home_wp}{Estimated win probability for the home team.}
 #' \item{away_wp}{Estimated win probability for the away team.}
 #' \item{wpa}{Win probability added (WPA) for the posteam.}
+#' \item{vegas_wpa}{Win probability added (WPA) for the posteam: spread_adjusted model.}
+#' \item{vegas_home_wpa}{Win probability added (WPA) for the home team: spread_adjusted model.}
 #' \item{home_wp_post}{Estimated win probability for the home team at the end of the play.}
 #' \item{away_wp_post}{Estimated win probability for the away team at the end of the play.}
 #' \item{vegas_wp}{Estimated win probabiity for the posteam given the current situation at the start of the given play, incorporating pre-game Vegas line.}

data-raw/create_field_descriptions.R

@@ -9,4 +9,5 @@ field_descriptions <- tibble(x = x) %>%
   separate(x,"{",into = c(NA,"Field","Description")) %>%
   mutate_all(str_remove_all,"\\}")
 
-usethis::use_data(field_descriptions,overwrite = TRUE)
+# usethis::use_data(field_descriptions,overwrite = TRUE)
+save(field_descriptions, file = "vignettes/field_descriptions.rda")

data-raw/variable_list.txt

@@ -93,6 +93,8 @@
 #' \item{home_wp}{Estimated win probability for the home team.}
 #' \item{away_wp}{Estimated win probability for the away team.}
 #' \item{wpa}{Win probability added (WPA) for the posteam.}
+#' \item{vegas_wpa}{Win probability added (WPA) for the posteam: spread_adjusted model.}
+#' \item{vegas_home_wpa}{Win probability added (WPA) for the home team: spread_adjusted model.}
 #' \item{home_wp_post}{Estimated win probability for the home team at the end of the play.}
 #' \item{away_wp_post}{Estimated win probability for the away team at the end of the play.}
 #' \item{vegas_wp}{Estimated win probabiity for the posteam given the current situation at the start of the given play, incorporating pre-game Vegas line.}
@@ -332,9 +334,15 @@
 #' \item{name}{Name of the 'passer' if it is not 'NA', or name of the 'rusher' otherwise.}
 #' \item{jersey_number}{Jersey number of the player listed in the 'name' column.}
 #' \item{id}{ID of the player in the 'name' column (NOTE: ids vary pre and post 2011 but are consistent for each player. Please see details for further information)}
+#' \item{fantasy}{Name of the rusher on rush players or receiver on pass plays.}
+#' \item{fantasy_id}{ID of the rusher on rush players or receiver on pass plays.}
+#' \item{fantasy_player_name}{Name of the rusher on rush players or receiver on pass plays (from official stats).}
+#' \item{fantasy_player_id}{ID of the rusher on rush players or receiver on pass plays (from official stats).}
 #' \item{qb_epa}{Gives QB credit for EPA for up to the point where a receiver lost a fumble after a completed catch and makes EPA work more like passing yards on plays with fumbles.}
 #' \item{xyac_epa}{Expected value of EPA gained after the catch, starting from where the catch was made. Zero yards after the catch would be listed as zero EPA.}
 #' \item{xyac_success}{Probability play earns positive EPA (relative to where play started) based on where ball was caught.}
 #' \item{xyac_fd}{Probability play earns a first down based on where the ball was caught.}
 #' \item{xyac_mean_yardage}{Average expected yards after the catch based on where the ball was caught.}
 #' \item{xyac_median_yardage}{Median expected yards after the catch based on where the ball was caught.}
+#' \item{xpass}{Probability of dropback scaled from 0 to 1.}
+#' \item{pass_oe}{Dropback percent over expected on a given play scaled from 0 to 100.}

vignettes/nflfastR.Rmd

@@ -70,7 +70,6 @@ This is a demonstration of `nflfastR`'s capabilities. While `nflfastR` can scrap
 games_2019 <- nflfastR::fast_scraper_schedules(2019) %>%
   utils::head(10) %>%
   dplyr::pull(game_id)
-
 tictoc::tic(glue::glue("{length(games_2019)} games with nflfastR:"))
 f <- nflfastR::fast_scraper(games_2019, pp = TRUE)
 tictoc::toc()
@@ -101,9 +100,7 @@ When working with `nflfastR`, drive results are automatically included. We use `
 ``` {r ex4, warning = FALSE, message = FALSE}
 games_2000 <- readRDS(url("https://raw.githubusercontent.com/guga31bb/nflfastR-data/master/data/play_by_play_2000.rds"))
 games_2015 <- readRDS(url("https://raw.githubusercontent.com/guga31bb/nflfastR-data/master/data/play_by_play_2015.rds"))
-
 pbp <- dplyr::bind_rows(games_2000, games_2015)
-
 pbp %>%
   dplyr::filter(season_type == "REG" & down == 1 & ydstogo == 10 & yardline_100 == 80) %>%
   dplyr::mutate(drive_score = dplyr::if_else(fixed_drive_result %in% c("Touchdown", "Field Goal"), 1, 0)) %>%
@@ -131,7 +128,6 @@ defense <- pbp %>%
   dplyr::group_by(defteam) %>%
   dplyr::summarise(def_epa = mean(epa, na.rm = TRUE))
 logos <- teams_colors_logos %>% dplyr::select(team_abbr, team_logo_espn)
-
 offense %>%
   dplyr::inner_join(defense, by = c("posteam" = "defteam")) %>%
   dplyr::inner_join(logos, by = c("posteam" = "team_abbr")) %>%
@@ -172,7 +168,6 @@ data <- tibble::tibble(
   "posteam_timeouts_remaining" = 3,
   "defteam_timeouts_remaining" = 3
 )
-
 nflfastR::calculate_expected_points(data) %>%
   dplyr::select(season, yardline_100, td_prob, ep) %>%
   knitr::kable(digits = 2)
@@ -196,7 +191,6 @@ data <- tibble::tibble(
   "posteam_timeouts_remaining" = 3,
   "defteam_timeouts_remaining" = 3
 )
-
 nflfastR::calculate_expected_points(data) %>%
   dplyr::select(season, yardline_100, td_prob, ep) %>%
   knitr::kable(digits = 2)
@@ -225,7 +219,6 @@ data <- tibble::tibble(
   "posteam_timeouts_remaining" = 3,
   "defteam_timeouts_remaining" = 3
 )
-
 nflfastR::calculate_win_probability(data) %>%
   dplyr::select(spread_line, wp, vegas_wp) %>%
   knitr::kable(digits = 2)
@@ -325,7 +318,6 @@ And now, everything will magically just "work": you can forget you're even worki
 pbp_db %>%
   dplyr::group_by(season) %>%
   dplyr::summarize(n = dplyr::n())
-
 pbp_db %>%
   dplyr::filter(rush == 1 | pass == 1, down <= 2, !is.na(epa), !is.na(posteam)) %>%
   dplyr::group_by(pass) %>%
@@ -339,7 +331,6 @@ russ <- pbp_db %>%
   dplyr::filter(name == "R.Wilson" & posteam == "SEA") %>%
   dplyr::select(desc, epa) %>%
   dplyr::collect()
-
 russ
 ```
 
@@ -455,3 +446,55 @@ joined %>%
 ```
 
 Not surprisingly, all 5 of the top 5 WRs in terms of EPA added come in ahead of the top RB. Note that the number of targets won't match official stats because we're including plays with penalties.
+
+# Frequent issues
+
+## Replicating official stats
+
+The columns like `name`, `passer`, etc are `nflfastR`-created columns that mimic "real" football: i.e., excluding plays with spikes, counting scrambles and sacks as pass plays, etc. But if you're trying to replicate official statistics -- perhaps for fantasy purposes -- use the `*_player_name` and `*_player_id` columns.
+
+[Let's try to replicate this page of passing leaders](https://www.nfl.com/stats/player-stats/).
+
+``` {r stats}
+nflfastR:::load_pbp(2020) %>%
+  filter(week <= 17, complete_pass == 1 | incomplete_pass == 1 | interception == 1, !is.na(down)) %>%
+  group_by(passer_player_name) %>%
+  summarize(
+    yards = sum(yards_gained),
+    tds = sum(touchdown == 1 & td_team == posteam),
+    ints = sum(interception),
+    att = n()
+            ) %>%
+  arrange(-yards) %>%
+  head(10) %>%
+  knitr::kable(digits = 0)
+```
+
+These match the official stats on NFL.com with the exception of Watson missing 22 passing yards (this is a bug related to laterals where he's missing yardage from the final play of the week 16 game against the Bengals).
+
+We can do the same for rush attempts to replicate the [NFL leaderboard](https://www.nfl.com/stats/player-stats/category/rushing/2020/POST/all/rushingyards/desc):
+
+``` {r stats_rush}
+nflfastR:::load_pbp(2020) %>%
+  filter(week <= 17, !is.na(down)) %>%
+  group_by(rusher_player_name) %>%
+  summarize(
+    yards = sum(yards_gained),
+    tds = sum(touchdown == 1 & td_team == posteam),
+    att = n()
+            ) %>%
+  arrange(-yards) %>%
+  head(10) %>%
+  knitr::kable(digits = 0)
+```
+
+This matches up exactly.
+
+## The `drive` column looks wacky
+
+Used `fixed_drive` and `fixed_drive_result` instead. See Example 4 above.
+
+## Why are there so many win probability columns?
+
+`vegas_wp` and `vegas_home_wp` incorporate the pregame spread and are much better models. 
+