inst/doc/back-to-back-tax.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.6
)

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

## ----data---------------------------------------------------------------------
# Pull game and team catalogs.
games_tbl <- nhlscraper::games()
teams_tbl <- nhlscraper::teams()

# Keep completed salary-cap regular-season games.
games_tbl <- games_tbl[
  games_tbl[['seasonId']] >= 20052006 &
    games_tbl[['gameTypeId']] == 2 &
    !is.na(games_tbl[['homeScore']]) &
    !is.na(games_tbl[['visitingScore']]),
  c(
    'gameId',
    'seasonId',
    'gameDate',
    'homeTeamId',
    'visitingTeamId',
    'homeScore',
    'visitingScore'
  )
]

# Expand games into team-game rows.
home_games <- data.frame(
  gameId       = games_tbl[['gameId']],
  seasonId     = games_tbl[['seasonId']],
  gameDate     = as.Date(games_tbl[['gameDate']]),
  teamId       = games_tbl[['homeTeamId']],
  isHome       = TRUE,
  goalsFor     = games_tbl[['homeScore']],
  goalsAgainst = games_tbl[['visitingScore']]
)
away_games <- data.frame(
  gameId       = games_tbl[['gameId']],
  seasonId     = games_tbl[['seasonId']],
  gameDate     = as.Date(games_tbl[['gameDate']]),
  teamId       = games_tbl[['visitingTeamId']],
  isHome       = FALSE,
  goalsFor     = games_tbl[['visitingScore']],
  goalsAgainst = games_tbl[['homeScore']]
)
team_games <- rbind(home_games, away_games)

# Sort within team.
team_games <- team_games[order(
  team_games[['teamId']],
  team_games[['gameDate']],
  team_games[['gameId']]
), ]

# Compute previous game date within team.
team_games[['previousGameDate']] <- as.Date(NA)
for (team_id in unique(team_games[['teamId']])) {
  idx <- which(team_games[['teamId']] == team_id)
  team_games[['previousGameDate']][idx] <- c(
    as.Date(NA),
    utils::head(team_games[['gameDate']][idx], -1)
  )
}

# Create rest and result fields.
team_games[['restDays']] <-
  as.integer(team_games[['gameDate']] - team_games[['previousGameDate']]) - 1L
team_games <- team_games[!is.na(team_games[['restDays']]), ]
team_games[['restBucket']] <- ifelse(
  team_games[['restDays']] >= 3,
  '3+',
  as.character(team_games[['restDays']])
)
team_games[['restBucket']] <- factor(
  team_games[['restBucket']],
  levels = c('0', '1', '2', '3+')
)
team_games[['win']] <- team_games[['goalsFor']] > team_games[['goalsAgainst']]
team_games[['goalDiff']] <-
  team_games[['goalsFor']] - team_games[['goalsAgainst']]
nrow(team_games)

## ----rest-summary-------------------------------------------------------------
# Summarize results by rest bucket.
rest_summary <- aggregate(
  cbind(win, goalDiff) ~ restBucket,
  data = team_games,
  FUN = mean
)
rest_counts <- as.data.frame(table(team_games[['restBucket']]))
names(rest_counts) <- c('restBucket', 'games')
rest_summary <- merge(rest_summary, rest_counts, by = 'restBucket')
rest_summary <- rest_summary[
  match(levels(team_games[['restBucket']]), rest_summary[['restBucket']]),
  c('restBucket', 'games', 'win', 'goalDiff')
]
make_table(
  rest_summary,
  caption = 'Win rate and average goal differential by rest bucket.',
  digits = 3
)

## ----rest-plot, fig.cap = 'Team performance by days of rest.'-----------------
# Plot win rate and goal differential by rest bucket.
old_par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(1, 2), mar = c(5, 4, 3, 1))
graphics::barplot(
  rest_summary[['win']],
  names.arg = rest_summary[['restBucket']],
  col = c('#d62828', '#f77f00', '#fcbf49', '#90be6d'),
  border = NA,
  ylim = c(0, 0.6),
  xlab = 'Days of Rest',
  ylab = 'Win Rate'
)
graphics::abline(h = mean(team_games[['win']]), lty = 2, col = '#495057')
graphics::barplot(
  rest_summary[['goalDiff']],
  names.arg = rest_summary[['restBucket']],
  col = c('#d62828', '#f77f00', '#fcbf49', '#90be6d'),
  border = NA,
  xlab = 'Days of Rest',
  ylab = 'Average Goal Differential'
)
graphics::abline(h = 0, lty = 2, col = '#495057')
graphics::par(old_par)

## ----venue-summary------------------------------------------------------------
# Summarize rest effect by venue.
venue_summary <- aggregate(
  cbind(win, goalDiff) ~ restBucket + isHome,
  data = team_games,
  FUN = mean
)
venue_counts <- aggregate(
  gameId ~ restBucket + isHome,
  data = team_games,
  FUN = length
)
names(venue_counts)[names(venue_counts) == 'gameId'] <- 'games'
venue_summary <- merge(
  venue_summary,
  venue_counts,
  by = c('restBucket', 'isHome')
)
venue_summary[['venue']] <- ifelse(
  venue_summary[['isHome']],
  'Home',
  'Away'
)
venue_summary <- venue_summary[, c(
  'restBucket',
  'venue',
  'games',
  'win',
  'goalDiff'
)]
make_table(
  venue_summary,
  caption = 'Rest effect split by home and road games.',
  digits = 3
)

## ----venue-plot, fig.cap = 'Home and road win rate by rest bucket.'-----------
# Plot venue-specific rest curves.
home_rows <- venue_summary[venue_summary[['venue']] == 'Home', ]
away_rows <- venue_summary[venue_summary[['venue']] == 'Away', ]
graphics::plot(
  seq_len(nrow(home_rows)),
  home_rows[['win']],
  type = 'b',
  pch = 19,
  lwd = 2,
  col = '#1d3557',
  xaxt = 'n',
  ylim = c(0.34, 0.62),
  xlab = 'Days of Rest',
  ylab = 'Win Rate'
)
graphics::lines(
  seq_len(nrow(away_rows)),
  away_rows[['win']],
  type = 'b',
  pch = 19,
  lwd = 2,
  col = '#e63946'
)
graphics::axis(
  side = 1,
  at = seq_len(nrow(home_rows)),
  labels = home_rows[['restBucket']]
)
graphics::legend(
  'bottomright',
  legend = c('Home', 'Away'),
  col = c('#1d3557', '#e63946'),
  pch = 19,
  lwd = 2,
  bty = 'n'
)

## ----season-rest--------------------------------------------------------------
# Summarize zero-rest share by season.
season_rest <- aggregate(
  I(restDays == 0) ~ seasonId,
  data = team_games,
  FUN = mean
)
names(season_rest)[names(season_rest) == 'I(restDays == 0)'] <- 'zeroRestShare'
season_rest <- season_rest[order(season_rest[['seasonId']]), ]
season_text <- as.character(season_rest[['seasonId']])
season_rest[['season']] <- paste0(
  substr(season_text, 1, 4),
  '-',
  substr(season_text, 7, 8)
)
make_table(
  utils::tail(season_rest[, c('season', 'zeroRestShare')], 8),
  caption = 'Recent share of team-games played on zero rest.',
  digits = 3
)

## ----season-plot, fig.cap = 'Share of team-games played on zero rest by season.'----
# Plot season trend in zero-rest games.
season_x <- seq_len(nrow(season_rest))
label_idx <- seq(1L, nrow(season_rest), by = 2L)
old_par <- graphics::par(no.readonly = TRUE)
graphics::par(mar = c(7, 4, 3, 1))
graphics::plot(
  season_x,
  season_rest[['zeroRestShare']],
  type = 'h',
  lwd = 3,
  col = '#457b9d',
  xaxt = 'n',
  xlab = '',
  ylab = 'Zero-Rest Share'
)
graphics::points(
  season_x,
  season_rest[['zeroRestShare']],
  pch = 19,
  col = '#1d3557'
)
graphics::axis(
  side = 1,
  at = season_x[label_idx],
  labels = season_rest[['season']][label_idx],
  las = 2,
  cex.axis = 0.75
)
graphics::mtext('Season', side = 1, line = 5)
graphics::par(old_par)

## ----team-table---------------------------------------------------------------
# Rank teams by zero-rest win rate.
zero_rest_tbl <- team_games[
  team_games[['restDays']] == 0,
  c('teamId', 'win', 'goalDiff')
]
zero_summary <- aggregate(
  cbind(win, goalDiff) ~ teamId,
  data = zero_rest_tbl,
  FUN = mean
)
zero_counts <- aggregate(
  win ~ teamId,
  data = zero_rest_tbl,
  FUN = length
)
names(zero_counts)[names(zero_counts) == 'win'] <- 'games'
zero_summary <- merge(zero_summary, zero_counts, by = 'teamId')
zero_summary <- zero_summary[zero_summary[['games']] >= 50, ]
zero_summary <- merge(
  zero_summary,
  teams_tbl[, c('teamId', 'teamTriCode')],
  by = 'teamId',
  all.x = TRUE
)
best_zero <- zero_summary[order(-zero_summary[['win']]), ]
best_zero <- utils::head(best_zero[, c(
  'teamTriCode',
  'games',
  'win',
  'goalDiff'
)], 8)
worst_zero <- zero_summary[order(zero_summary[['win']]), ]
worst_zero <- utils::head(worst_zero[, c(
  'teamTriCode',
  'games',
  'win',
  'goalDiff'
)], 8)
make_table(
  best_zero,
  caption = 'Best zero-rest win rates among teams with at least 50 games.',
  digits = 3
)
make_table(
  worst_zero,
  caption = 'Lowest zero-rest win rates among teams with at least 50 games.',
  digits = 3
)