inst/doc/team-edge-archetypes.R

In nhlscraper: Scraper for National Hockey League Data

## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = '#>',
  fig.align = 'center',
  out.width = '92%',
  fig.width = 7,
  fig.height = 4.8
)

make_table <- function(x, caption, digits = 3) {
  knitr::kable(x, caption = caption, digits = digits)
}

## ----leaders------------------------------------------------------------------
# Pull team EDGE leaders.
edge_leaders <- nhlscraper::team_edge_leaders(
  season    = 20242025,
  game_type = 2
)

# Build compact leader table.
leader_table <- data.frame(
  metric = c(
    'Shots over 90 mph',
    'Bursts over 22 mph',
    'Distance per 60',
    'High-danger shots on goal',
    'Offensive-zone time',
    'Neutral-zone time',
    'Defensive-zone time'
  ),
  team = c(
    edge_leaders[['shotAttemptsOver90']][['team']][['abbrev']],
    edge_leaders[['burstsOver22']][['team']][['abbrev']],
    edge_leaders[['distancePer60']][['team']][['abbrev']],
    edge_leaders[['highDangerSOG']][['team']][['abbrev']],
    edge_leaders[['offensiveZoneTime']][['team']][['abbrev']],
    edge_leaders[['neutralZoneTime']][['team']][['abbrev']],
    edge_leaders[['defensiveZoneTime']][['team']][['abbrev']]
  ),
  value = c(
    as.character(edge_leaders[['shotAttemptsOver90']][['attempts']]),
    as.character(edge_leaders[['burstsOver22']][['bursts']]),
    sprintf('%.2f miles', edge_leaders[['distancePer60']][['distanceSkated']][['imperial']]),
    as.character(edge_leaders[['highDangerSOG']][['sog']]),
    sprintf('%.3f', edge_leaders[['offensiveZoneTime']][['zoneTime']]),
    sprintf('%.3f', edge_leaders[['neutralZoneTime']][['zoneTime']]),
    sprintf('%.3f', edge_leaders[['defensiveZoneTime']][['zoneTime']])
  ),
  stringsAsFactors = FALSE
)
make_table(
  leader_table,
  caption = 'Selected 2024-25 team EDGE leaders.'
)

## ----profiles-----------------------------------------------------------------
# Define team set.
team_ids <- c(CAR = 12, COL = 21, EDM = 22, FLA = 13, WSH = 15)

# Define robust helpers.
fetch_with_retry <- function(fetch_fun, validator, tries = 3) {
  for (i in seq_len(tries)) {
    value <- try(fetch_fun(), silent = TRUE)
    if (!inherits(value, 'try-error') && validator(value)) {
      return(value)
    }
    Sys.sleep(i / 4)
  }
  NULL
}
valid_df <- function(x, required_cols) {
  is.data.frame(x) && nrow(x) > 0 && all(required_cols %in% names(x))
}
safe_num <- function(x) {
  out <- suppressWarnings(as.numeric(x))
  ifelse(is.na(out), NA_real_, out)
}
safe_name <- function(first_name, last_name) {
  if (
    is.na(first_name) ||
      is.na(last_name) ||
      first_name == '' ||
      last_name == ''
  ) {
    return(NA_character_)
  }
  paste(first_name, last_name)
}
safe_summary_num <- function(x, path) {
  value <- tryCatch({
    for (nm in path) x <- x[[nm]]
    x
  }, error = function(e) NA_real_)
  safe_num(value)
}

# Build one profile row.
build_team_profile <- function(team_code, team_id) {
  team_summary <- fetch_with_retry(
    function() nhlscraper::team_edge_summary(
      team      = team_id,
      season    = 20242025,
      game_type = 2
    ),
    function(x) is.list(x)
  )
  zone_rows <- fetch_with_retry(
    function() nhlscraper::team_edge_zone_time(
      team      = team_id,
      season    = 20242025,
      game_type = 2,
      category  = 'details'
    ),
    function(x) valid_df(x, c('strengthCode', 'offensiveZonePctg'))
  )
  skating_rows <- fetch_with_retry(
    function() nhlscraper::team_edge_skating_speed(
      team      = team_id,
      season    = 20242025,
      game_type = 2,
      category  = 'details'
    ),
    function(x) valid_df(x, c('positionCode', 'maxSkatingSpeed.imperial', 'burstsOver22.value'))
  )
  shot_speed_rows <- fetch_with_retry(
    function() nhlscraper::team_edge_shot_speed(
      team      = team_id,
      season    = 20242025,
      game_type = 2,
      category  = 'details'
    ),
    function(x) valid_df(x, c('position', 'topShotSpeed.imperial', 'shotAttempts90To100.value'))
  )
  shot_location_rows <- fetch_with_retry(
    function() nhlscraper::team_edge_shot_location(
      team      = team_id,
      season    = 20242025,
      game_type = 2,
      category  = 'details'
    ),
    function(x) valid_df(x, c('area', 'sog'))
  )
  if (
    is.null(zone_rows) ||
      is.null(skating_rows) ||
      is.null(shot_speed_rows) ||
      is.null(shot_location_rows)
  ) {
    return(data.frame(
      team = team_code,
      points = safe_summary_num(team_summary, c('team', 'points')),
      wins = safe_summary_num(team_summary, c('team', 'wins')),
      offensiveZonePctg = NA_real_,
      maxSkatingSpeed = NA_real_,
      burstsOver22 = NA_real_,
      shotAttemptsOver90 = NA_real_,
      hardestShot = NA_real_,
      trackedShots = NA_real_,
      interiorShare = NA_real_,
      circleShare = NA_real_,
      pointShare = NA_real_,
      fastestSkater = NA_character_,
      hardestShooter = NA_character_,
      stringsAsFactors = FALSE
    ))
  }
  zone_row <- zone_rows[zone_rows[['strengthCode']] == 'all', , drop = FALSE]
  skating_row <- skating_rows[skating_rows[['positionCode']] == 'all', , drop = FALSE]
  shot_speed_row <- shot_speed_rows[shot_speed_rows[['position']] == 'all', , drop = FALSE]
  if (!nrow(zone_row)) zone_row <- zone_rows[1, , drop = FALSE]
  if (!nrow(skating_row)) skating_row <- skating_rows[1, , drop = FALSE]
  if (!nrow(shot_speed_row)) shot_speed_row <- shot_speed_rows[1, , drop = FALSE]
  interior_mask <- shot_location_rows[['area']] %in% c(
    'Crease',
    'Low Slot',
    'L Net Side',
    'R Net Side'
  )
  circle_mask <- shot_location_rows[['area']] %in% c(
    'High Slot',
    'L Circle',
    'R Circle'
  )
  point_mask <- shot_location_rows[['area']] %in% c(
    'Center Point',
    'L Point',
    'R Point',
    'Outside L',
    'Outside R',
    'Beyond Red Line'
  )
  total_shots <- sum(shot_location_rows[['sog']], na.rm = TRUE)
  data.frame(
    team = team_code,
    points = safe_summary_num(team_summary, c('team', 'points')),
    wins = safe_summary_num(team_summary, c('team', 'wins')),
    offensiveZonePctg = safe_num(zone_row[['offensiveZonePctg']][1]),
    maxSkatingSpeed = safe_num(skating_row[['maxSkatingSpeed.imperial']][1]),
    burstsOver22 = safe_num(skating_row[['burstsOver22.value']][1]),
    shotAttemptsOver90 = sum(
      safe_num(shot_speed_row[['shotAttemptsOver100.value']][1]),
      safe_num(shot_speed_row[['shotAttempts90To100.value']][1]),
      na.rm = TRUE
    ),
    hardestShot = safe_num(shot_speed_row[['topShotSpeed.imperial']][1]),
    trackedShots = total_shots,
    interiorShare = sum(shot_location_rows[['sog']][interior_mask], na.rm = TRUE) / total_shots,
    circleShare = sum(shot_location_rows[['sog']][circle_mask], na.rm = TRUE) / total_shots,
    pointShare = sum(shot_location_rows[['sog']][point_mask], na.rm = TRUE) / total_shots,
    fastestSkater = safe_name(
      skating_row[['maxSkatingSpeed.overlay.player.firstName.default']][1],
      skating_row[['maxSkatingSpeed.overlay.player.lastName.default']][1]
    ),
    hardestShooter = safe_name(
      shot_speed_row[['topShotSpeed.overlay.player.firstName.default']][1],
      shot_speed_row[['topShotSpeed.overlay.player.lastName.default']][1]
    ),
    stringsAsFactors = FALSE
  )
}

# Build profile table.
team_profiles <- Map(
  build_team_profile,
  team_code = names(team_ids),
  team_id   = unname(team_ids)
)
team_profiles <- do.call(rbind, team_profiles)
rownames(team_profiles) <- NULL
profile_table <- team_profiles[, c(
  'team',
  'points',
  'wins',
  'offensiveZonePctg',
  'maxSkatingSpeed',
  'burstsOver22',
  'shotAttemptsOver90',
  'hardestShot',
  'interiorShare'
)]
make_table(
  profile_table,
  caption = 'Five-team 2024-25 EDGE profile comparison.',
  digits = 3
)

## ----scorecard----------------------------------------------------------------
# Rescale profile metrics within sample.
rescale01 <- function(x) {
  rng <- range(x, na.rm = TRUE)
  if (!all(is.finite(rng)) || diff(rng) == 0) {
    return(rep(NA_real_, length(x)))
  }
  (x - rng[1]) / diff(rng)
}
scorecard <- data.frame(
  team = team_profiles[['team']],
  territory = rescale01(team_profiles[['offensiveZonePctg']]),
  pace = rescale01(team_profiles[['burstsOver22']]),
  shotPower = rescale01(team_profiles[['shotAttemptsOver90']]),
  interior = rescale01(team_profiles[['interiorShare']]),
  hardestShot = rescale01(team_profiles[['hardestShot']]),
  stringsAsFactors = FALSE
)
make_table(
  scorecard,
  caption = 'Within-sample EDGE archetype scores.',
  digits = 3
)

## ----scorecard-plot, fig.cap = 'Within-sample archetype scorecard for five teams.'----
# Plot archetype scorecard.
score_matrix <- t(as.matrix(scorecard[, -1]))
colnames(score_matrix) <- scorecard[['team']]
graphics::barplot(
  score_matrix,
  beside = TRUE,
  col = c('#264653', '#2a9d8f', '#e9c46a', '#f4a261', '#e76f51'),
  ylim = c(0, 1.35),
  ylab = 'Within-Sample Score',
  xlab = 'Team'
)
graphics::legend(
  'top',
  legend = rownames(score_matrix),
  fill = c('#264653', '#2a9d8f', '#e9c46a', '#f4a261', '#e76f51'),
  bty = 'n',
  cex = 0.75,
  ncol = 3
)

## ----shot-mix-plot, fig.cap = 'Tracked shot-location mix by team.'------------
# Plot shot-location mix.
shot_mix <- t(as.matrix(team_profiles[, c(
  'interiorShare',
  'circleShare',
  'pointShare'
)]))
colnames(shot_mix) <- team_profiles[['team']]
rownames(shot_mix) <- c('Interior', 'Circles / slot', 'Points / perimeter')
graphics::barplot(
  shot_mix,
  beside = FALSE,
  col = c('#1b4332', '#52b788', '#b7e4c7'),
  ylim = c(0, 1.18),
  ylab = 'Share of Tracked Shots',
  xlab = 'Team'
)
graphics::legend(
  'top',
  legend = rownames(shot_mix),
  fill = c('#1b4332', '#52b788', '#b7e4c7'),
  bty = 'n',
  cex = 0.8,
  horiz = TRUE
)

## ----player-table-------------------------------------------------------------
# Show players behind extreme traits.
player_table <- team_profiles[, c(
  'team',
  'fastestSkater',
  'maxSkatingSpeed',
  'hardestShooter',
  'hardestShot'
)]
make_table(
  player_table,
  caption = 'Players behind each team profile.'
)