R/cfbd_pbp_data_v2.R

In cfbfastR: Access College Football Play by Play Data

#' @name cfbd_pbp_v2
#' @aliases cfbd_pbp_v2 pbp_v2 modular_epa modular_wpa
#' @title
#' **CFBD Play-by-Play (v2 Modular EPA/WPA Pipeline) Overview**
#' @description
#'
#' * `cfbd_pbp_data_v2()`: Get college football play-by-play data — modular
#'   EPA/WPA pipeline (v2). Thin orchestrator over the shared EPA/WPA engine
#'   `.run_epa_wpa()`, the canonical play-type taxonomy `.pbp_play_types()`,
#'   and the canonical output schema `.pbp_output_order`. Runs side-by-side
#'   with the legacy [cfbd_pbp_data()] entry point until the equivalence
#'   harness proves the new path matches.
#'
#' @details
#' The v2 entry point is a thin wrapper around `.run_epa_wpa()` -- the
#' shared engine that powers both the modular (v2) and legacy paths. The
#' `output = "default" / "lean" / "full"` tier argument selects which
#' intermediate columns survive the final select: `"default"` drops
#' pipeline lag/lead intermediates and redundant alternates, `"lean"`
#' additionally drops the per-branch WPA scratchpad, and `"full"` is the
#' legacy column set (drops only player-name aliases). The
#' equivalence-harness allow-list is intentionally permissive about
#' lag/lead intermediates and per-branch WPA scratchpad columns because
#' those are mechanically rebuildable from the surviving canonical
#' columns; the harness only enforces equality on user-facing values.
#'
#' ## **Get college football play-by-play data — modular EPA/WPA pipeline (v2)**
#'
#' ```r
#' cfbd_pbp_data_v2(
#'   year = 2024, week = 1, season_type = "regular",
#'   epa_wpa = TRUE, output = "default"
#' )
#' ```
#'
NULL

#' @title
#' **Get college football play-by-play data — modular EPA/WPA pipeline (v2)**
#' @description Returns CFBD play-by-play data with optional Expected Points
#' Added (EPA) and Win Probability Added (WPA) modeling. The modular
#' successor to [cfbd_pbp_data()]: a thin orchestrator over the shared
#' EPA/WPA engine (`.run_epa_wpa()`), the canonical play-type taxonomy
#' (`.pbp_play_types()`), and the canonical output schema
#' (`.pbp_output_order`). Side-by-side with the legacy entry point until the
#' equivalence harness proves the new path matches.
#' @param year (*Numeric* required): Season year (e.g. `2024`). \cr
#' Minimum value accepted: `r min_year_map_df[min_year_map_df$function_name == 'cfbd_pbp_data_v2', 'min_year']`
#' @param season_type (*Character*): Season type — `"regular"` (default),
#'   `"postseason"`, `"both"`, `"allstar"`, `"spring_regular"`,
#'   `"spring_postseason"`.
#' @param week (*Numeric*): Week number.
#' @param team (*Character*): Optional team filter (e.g. `"Texas"`).
#' @param play_type (*Character*): Optional play-type filter (see
#'   [cfbd_play_type_df]).
#' @param epa_wpa (*Logical*): When `TRUE`, run the EPA/WPA pipeline and
#'   return the modeled frame; when `FALSE` (default) return the raw plays +
#'   drives + betting join.
#' @param output (*Character*): controls the modeled-output column set when
#'   `epa_wpa = TRUE`. Ignored when `epa_wpa = FALSE`. Defaults to
#'   `"default"`. Must be one of:
#'
#'   * `"default"` (recommended) -- drops pipeline lag/lead
#'     intermediates, redundant alternates (`sack_vec`, `turnover_indicator`,
#'     `kick_play`, `missing_yard_flag`), and drive-result aliases
#'     (`drive_result2`, `drive_result_detailed_flag`,
#'     `lag_drive_result_detailed`, `lead_drive_result_detailed`,
#'     `lag_new_drive_pts`). Keeps `orig_play_type` and `pts_scored` (they
#'     carry useful per-play information distinct from the canonical
#'     columns) and the per-branch WPA scratchpad (`wpa_base`/`wpa_change`
#'     etc.). ~75 columns lighter than `"full"` with no loss of information
#'     that isn't trivially rebuildable.
#'   * `"lean"` -- everything `"default"` drops, plus the WPA
#'     computation scratchpad. For dashboards / leaderboards / game logs.
#'   * `"full"` -- legacy behavior, drops only the player-name
#'     aliases. For sequential modeling that consumes pre-computed lag/lead
#'     shifts or the per-branch WPA decomposition.
#' @return A `cfbfastR_data` tibble. The `epa_wpa = TRUE` output matches the
#'   legacy [cfbd_pbp_data()] pipeline-canonical column set on every column
#'   it carries; the `output` argument controls which intermediate columns
#'   are retained. Documented bug-fix sites are listed in the package
#'   vignette.
#' @keywords CFB PBP
#' @family CFBD PBP
#' @importFrom rlang .data
#' @importFrom dplyr filter group_by mutate left_join select rename ungroup slice_min any_of all_of setdiff
#' @importFrom janitor clean_names
#' @importFrom jsonlite fromJSON
#' @importFrom httr2 request req_url_query req_perform resp_body_string
#' @importFrom cli cli_alert_warning
#' @importFrom glue glue
#' @importFrom stats setNames
#' @export
#' @examples
#' \donttest{
#'   x <- try(cfbd_pbp_data_v2(
#'     year = 2024, week = 1, season_type = "regular",
#'     epa_wpa = TRUE, output = "default"
#'   ))
#' }
cfbd_pbp_data_v2 <- function(year,
                             season_type = "regular",
                             week        = 1,
                             team        = NULL,
                             play_type   = NULL,
                             epa_wpa     = FALSE,
                             output      = "default") {
  if (!is.character(output) || length(output) != 1L ||
      !output %in% c("default", "lean", "full")) {
    cli::cli_abort(c(
      "{.arg output} must be one of {.val default}, {.val lean}, or {.val full}.",
      x = "You supplied {.val {output}}."
    ))
  }
  old <- options(list(stringsAsFactors = FALSE, scipen = 999))
  on.exit(options(old))

  # --- validation -------------------------------------------------------
  allowable_play_types <- na.omit(c(
    cfbfastR::cfbd_play_type_df$text,
    cfbfastR::cfbd_play_type_df$abbreviation
  ))

  validate_api_key()
  validate_year(year)
  validate_week(week)
  validate_season_type(season_type)

  pt_abb_exists <- TRUE
  if (!is.null(play_type)) {
    text <- play_type %in% cfbfastR::cfbd_play_type_df$text
    abbr <- play_type %in% cfbfastR::cfbd_play_type_df$abbreviation
    validate_list(play_type, allowable_play_types)
    if (text) {
      pt_abb <- cfbfastR::cfbd_play_type_df$abbreviation[
        which(cfbfastR::cfbd_play_type_df$text == play_type)]
      pt_abb_exists <- !is.null(pt_abb)
    } else {
      pt_abb <- play_type
    }
  } else {
    pt_abb <- NULL
  }
  team <- handle_accents(team)

  # --- raw plays --------------------------------------------------------
  play_base_url <- "https://api.collegefootballdata.com/plays"
  query_params  <- list(
    "seasonType" = season_type,
    "year"       = year,
    "week"       = week,
    "team"       = team,
    "playType"   = pt_abb
  )
  full_url <- httr2::req_url_query(
    httr2::request(play_base_url), !!!.compact(query_params)
  )$url
  res <- get_req(full_url)
  check_status(res)

  raw_play_df <- res |>
    httr2::resp_body_string(encoding = "UTF-8") |>
    jsonlite::fromJSON()
  raw_play_df <- do.call(data.frame, raw_play_df)
  if (nrow(raw_play_df) == 0) {
    cli::cli_alert_warning(
      "Likely a bye week or empty filter for {year} wk {week}; returning NULL."
    )
    return(NULL)
  }

  # --- betting lines (year >= 2013, with a non-silent error handler) ----
  if (year >= 2013) {
    tryCatch(
      expr = {
        providers_list <- c(
          "consensus", "DraftKings", "ESPN Bet", "Caesars",
          "Caesars Sportsbook (Colorado)", "Caesars (Pennsylvania)",
          "Bovada", "SugarHouse", "William Hill (New Jersey)",
          "teamrankings", "numberfire"
        )
        game_spread <- cfbd_betting_lines(
          year        = year,
          week        = week,
          season_type = season_type,
          team        = team
        )
        game_spread <- game_spread |>
          dplyr::filter(.data$provider %in% providers_list) |>
          dplyr::mutate(
            spread     = as.numeric(.data$spread),
            over_under = as.numeric(.data$over_under)
          ) |>
          dplyr::select(
            "game_id", "provider", "spread", "formatted_spread", "over_under"
          )
        prov_priority <- stats::setNames(
          seq_along(providers_list), providers_list
        )
        game_spread <- game_spread |>
          dplyr::mutate(.prov_rank = prov_priority[.data$provider]) |>
          dplyr::group_by(.data$game_id) |>
          dplyr::slice_min(.data$.prov_rank, with_ties = FALSE) |>
          dplyr::ungroup() |>
          dplyr::select(-dplyr::all_of(".prov_rank"))
        raw_play_df <- raw_play_df |>
          dplyr::left_join(
            game_spread, by = c("gameId" = "game_id"),
            suffix = c("_x", "")
          )
        if (all(is.na(raw_play_df$spread))) {
          raw_play_df$spread           <- NA_real_
          raw_play_df$formatted_spread <- NA_character_
          raw_play_df$over_under       <- NA_real_
        }
      },
      error = function(e) {
        cli::cli_alert_warning(
          "Betting lines unavailable for {year} wk {week}: {conditionMessage(e)}"
        )
      }
    )
  }

  # --- drives -----------------------------------------------------------
  drive_info     <- cfbd_drives(
    year = year, season_type = season_type, team = team, week = week
  )
  clean_drive_df <- clean_drive_info(drive_info)
  colnames(clean_drive_df) <- paste0("drive_", colnames(clean_drive_df))

  # --- assemble: clean_names + drive join + col cleanups (legacy:521-559)
  play_df <- raw_play_df |>
    janitor::clean_names() |>
    dplyr::rename("yard_line" = "yardline") |>
    dplyr::mutate(drive_id = as.numeric(.data$drive_id)) |>
    dplyr::left_join(
      clean_drive_df,
      by = c("drive_id" = "drive_drive_id",
             "game_id"  = "drive_game_id"),
      suffix = c("_play", "_drive")
    )

  rm_cols <- c(
    "drive_game_id", "drive_id_drive",
    "drive_plays", "drive_start_yardline", "drive_end_yardline",
    "drive_offense", "drive_offense_conference",
    "drive_defense", "drive_defense_conference",
    "drive_start_time_hours", "drive_start_time_minutes",
    "drive_start_time_seconds",
    "drive_end_time_hours", "drive_end_time_minutes",
    "drive_end_time_seconds",
    "drive_elapsed_hours", "drive_elapsed_minutes", "drive_elapsed_seconds"
  )

  play_df <- play_df |>
    dplyr::select(-dplyr::any_of(rm_cols)) |>
    dplyr::rename(
      "drive_pts"          = "drive_pts_drive",
      "drive_result"       = "drive_drive_result",
      "orig_drive_number"  = "drive_drive_number",
      "id_play"            = "id",
      "offense_play"       = "offense",
      "defense_play"       = "defense"
    )

  play_df <- .cfbd_to_epa_input(play_df, year = year, week = week)

  if (!pt_abb_exists) {
    play_df <- play_df |>
      dplyr::filter(tolower(.data$play_type) == tolower(!!play_type))
  }

  # --- modeled path (epa_wpa = TRUE) -----------------------------------
  if (isTRUE(epa_wpa)) {
    if (year <= 2005) {
      cli::cli_alert_warning(
        "Data quality prior to 2005 is inconsistent; EPA/WPA may be unreliable."
      )
    }
    play_df <- .run_epa_wpa_by_game(
      play_df,
      ep_model   = ep_model,
      fg_model   = fg_model,
      wp_model   = wp_model,
      clean_text = TRUE,
      min_plays  = 20L
    ) |>
      .pbp_apply_output_schema(output = output)
  }

  play_df |>
    make_cfbfastR_data(
      "Play-by-Play data from CollegeFootballData.com (v2)", Sys.time()
    )
}