R/ncaa_pbp.R

In baseballr: Acquiring and Analyzing Baseball Data

#' @rdname ncaa_pbp
#' @title **Get Play-By-Play Data for NCAA Baseball Games**
#' @param game_info_url The url for the game's boxscore data. This can be 
#'  found using the ncaa_schedule_info function.
#' @param game_pbp_url The url for the game's play-by-play data. This can be 
#'  found using the ncaa_schedule_info function.
#' @param raw_html_to_disk Write raw html to disk (saves as `{game_pbp_id}`.html
#'  in `raw_html_path` directory)
#' @param raw_html_path Directory path to write raw html
#' @param read_from_file Read from raw html on disk
#' @param file File with full path to read raw html
#' @param ... Additional arguments passed to an underlying function like httr.
#' @return A data frame with play-by-play data for an individual game.
#' 
#'  |col_name       |types     |description                                         |
#'  |:--------------|:---------|:---------------------------------------------------|
#'  |game_date      |character |Game date (NA on the redesigned page; use `ncaa_schedule_info()`). |
#'  |location       |character |Venue / conditions line when present.               |
#'  |attendance     |logical   |Reported attendance (NA on the redesigned page).    |
#'  |inning         |character |Inning number.                                      |
#'  |inning_top_bot |character |Half-inning ("top" or "bot").                       |
#'  |score          |character |Running score (away-home) after the play.           |
#'  |batting        |character |Batting team name.                                  |
#'  |fielding       |character |Fielding team name.                                 |
#'  |description    |character |Play description text.                              |
#'  |game_pbp_url   |character |stats.ncaa.org play-by-play url for the game.       |
#'  |game_pbp_id    |integer   |stats.ncaa.org play-by-play (contest) identifier.   |
#'  
#' @importFrom tibble tibble
#' @importFrom tidyr gather spread
#' @importFrom purrr map
#' @importFrom janitor make_clean_names
#' @import rvest 
#' @details
#' Live usage (reads `stats.ncaa.org`, which is behind Akamai bot protection and
#' needs the optional `chromote` + Google Chrome browser fallback, so it is shown
#' here rather than as a runnable example):
#'
#' ```r
#' ncaa_pbp(game_info_url = "https://stats.ncaa.org/contests/2167178/box_score")
#' ```
#' @export

ncaa_pbp <- function(game_info_url = NA_character_, 
                              game_pbp_url = NA_character_,
                              raw_html_to_disk = FALSE, 
                              raw_html_path = "/",
                              read_from_file = FALSE,
                              file = NA_character_,
                              ...) {
  
  
  tryCatch(
    expr = {
      if (is.na(game_info_url) && is.na(game_pbp_url) && is.na(file)) {
        cli::cli_abort(glue::glue("{Sys.time()}: No game_info_url, game_pbp_url, or file provided"))
      }
      if (read_from_file == FALSE && !is.na(game_info_url)) {
        contest_id <- as.integer(stringr::str_extract(game_info_url, "\\d+"))
        
        game_info_resp <- request_with_proxy(url = game_info_url, ...)

        check_status(game_info_resp)
        
        init_payload <- game_info_resp %>% 
          httr2::resp_body_string() %>% 
          xml2::read_html() 
        
        # Follow the "Play By Play" tab link. The React redesign replaced the old
        # `#root` nav with a labelled <a> to /contests/{id}/play_by_play; fall
        # back to deriving it from the box-score URL if the link isn't present.
        hrefs <- init_payload %>%
          rvest::html_elements("a") %>%
          rvest::html_attr("href")
        pbp_slug <- unique(hrefs[grepl("play_by_play", hrefs)])
        game_pbp_url <- if (length(pbp_slug) > 0) {
          paste0("https://stats.ncaa.org", pbp_slug[1])
        } else {
          sub("box_score", "play_by_play", game_info_url)
        }
        
        pbp_payload_resp <-  request_with_proxy(url = game_pbp_url, ...)
        
        check_status(pbp_payload_resp)
        
        pbp_payload <- pbp_payload_resp %>% 
          httr2::resp_body_string() %>% 
          xml2::read_html()
        
        if (raw_html_to_disk == TRUE) {
          pbp_id <- as.integer(stringr::str_extract(payload,"\\d+"))
          xml2::write_xml(pbp_payload, file = glue::glue("{raw_html_path}{pbp_id}.html"))
        }
      }
      if (read_from_file == FALSE && !is.na(game_pbp_url)) {
        payload <- game_pbp_url
        pbp_payload_resp <- request_with_proxy(url = game_pbp_url, ...)
        
        check_status(pbp_payload_resp)
        
        pbp_payload <- pbp_payload_resp %>% 
          httr2::resp_body_string() %>% 
          xml2::read_html()
        
        if (raw_html_to_disk == TRUE) {
          pbp_id <- as.integer(stringr::str_extract(game_pbp_url,"\\d+"))
          xml2::write_xml(pbp_payload, file = glue::glue("{raw_html_path}{pbp_id}.html"))
        }
      }
      if ((read_from_file == TRUE) && (!is.na(file))) {
        pbp_payload <- file %>% 
          xml2::read_html()
        payload <- stringr::str_extract(file, "\\d+")
      }
      
      # The redesigned /contests/{id}/play_by_play page renders each inning as a
      # <table class="table"> whose column headers are the away / home team names
      # (away | Score | home). The old key-value game-info table and the
      # `mytable` inning class are gone.
      table_list_innings <- pbp_payload %>%
        rvest::html_elements("table.table")
      if (length(table_list_innings) == 0) {
        cli::cli_abort("{Sys.time()}: No play-by-play tables found at {game_pbp_url}")
      }
      table_list_innings <- table_list_innings %>%
        stats::setNames(seq_along(table_list_innings))

      header_names <- table_list_innings[[1]] %>%
        rvest::html_table() %>%
        names()
      teams <- tibble::tibble(away = header_names[1], home = header_names[3])

      # Game meta no longer ships as a tidy key-value table on the redesigned
      # page; carry the venue/conditions line when present and leave date /
      # attendance NA (the game date is available from `ncaa_schedule_info()`).
      info_df <- table_list_innings[[1]] %>%
        rvest::html_table() %>%
        as.data.frame()
      info_line <- if (nrow(info_df) > 0) as.character(info_df[[1]][1]) else NA_character_
      game_info <- data.frame(
        game_date = NA_character_,
        location = if (!is.na(info_line) && grepl("\\.\\.", info_line)) info_line else NA_character_,
        attendance = NA_real_,
        stringsAsFactors = FALSE
      )

      mapped_table <- purrr::map(.x = table_list_innings,
                                 ~format_baseball_pbp_tables(.x, teams = teams)) %>%
        dplyr::bind_rows(.id = "inning")
      
      mapped_table[1,2] <- ifelse(mapped_table[1,2] == "",
                                  "0-0", mapped_table[1,2])
      
      mapped_table <- mapped_table %>%
        dplyr::mutate(score = ifelse(.data$score == "", NA, .data$score)) %>%
        tidyr::fill("score", .direction = "down")
      
      mapped_table <- mapped_table %>%
        dplyr::mutate(
          inning_top_bot = ifelse(teams$away == .data$batting, "top", "bot"),
          attendance = game_info$attendance,
          game_date = game_info$game_date,
          location = game_info$location,
          year = as.integer(stringr::str_extract(.data$game_date, "\\d{4}")),
          game_pbp_url = payload,
          game_pbp_id = as.integer(stringr::str_extract(payload, "\\d+"))) %>%
        dplyr::select(
          "game_date", "location", "attendance", 
          "inning", "inning_top_bot", tidyr::everything()) %>%
        make_baseballr_data("NCAA Baseball Play-by-Play data from stats.ncaa.org",Sys.time())
      
    },
    error = function(e) {
      cli::cli_alert_danger(
        paste0("{Sys.time()}: Could not retrieve or parse NCAA play-by-play from ",
               "game_info_url {game_info_url} / game_pbp_url {game_pbp_url}. The ",
               "stats.ncaa.org page layout may have changed or the request was ",
               "challenged.")
      )
      cli::cli_alert_danger("Error: {conditionMessage(e)}")
    },
    finally = {
    }
  )
  return(mapped_table)
}

#' @rdname get_ncaa_baseball_pbp
#' @title **(legacy) Get Play-By-Play Data for NCAA Baseball Games**
#' @inheritParams ncaa_pbp
#' @inherit ncaa_pbp return
#' @keywords legacy
#' @export
get_ncaa_baseball_pbp <- ncaa_pbp


#' @rdname get_ncaa_baseball_pbp
#' @title **(legacy) Get Play-By-Play Data for NCAA Baseball Games**
#' @inheritParams ncaa_pbp
#' @inherit ncaa_pbp return
#' @keywords legacy
#' @export
ncaa_baseball_pbp <- ncaa_pbp


format_baseball_pbp_tables <- function(table_node, teams) {
  # header = FALSE keeps the columns positional (X1 = away, X2 = score, X3 =
  # home); the redesigned pbp tables carry the team names as the header row, so
  # the leading `[-1, ]` below drops that team-name row, leaving only plays.
  table <- (table_node %>%
              rvest::html_table(header = FALSE) %>%
              as.data.frame() %>%
              dplyr::filter(!grepl(pattern = "R:", x = .data$X1)) %>%
              dplyr::mutate(batting = ifelse(.data$X1 != "", teams$away, teams$home)) %>%
              dplyr::mutate(fielding = ifelse(.data$X1 != "", teams$home, teams$away)))[-1,] %>%
    tidyr::gather(key = "X1", value = "value", -c("batting", "fielding", "X2")) %>%
    dplyr::rename("score" = "X2") %>%
    dplyr::filter(.data$value != "")
  
  table <- table %>%
    dplyr::rename("description" = "value") %>%
    dplyr::select(-"X1")
  
  return(table)
}