Making Animated Win Probability Charts with cfbfastR
Jared Lee
Source: vignettes/animated-wp-plotting.Rmd
animated-wp-plotting.RmdHave you ever wanted to make an animated
win probability chart for college football like Lee Sharpe makes for the
NFL? This document will walk you step-by-step through the process of
adapting Sharpe’s
code to college football using data from CollegeFootballData.com collected
using the cfbfastR package for R.
Load and Install Packages
We’re going to need several packages to generate the winning
percentage plot: tidyverse for easy data wrangling, string
manipulation, and plotting, glue to easily make the labels,
ggimage to put the logos on the plot, and
animation to actually build the GIF.
if (!requireNamespace('pacman', quietly = TRUE)){
install.packages('pacman')
}
pacman::p_load(tidyverse, animation, glue, zoo, ggimage, cfbfastR)cfbfastR
We’ll start by picking a team, a week, and a year and using
cfbfastR’s functions to pull the play-by-play and the game
info. cfbd_pbp_data() will grab the play-by-play info and
make sure that epa_wpa is TRUE to get the win probabilities for the
plot. cfbd_game_info() will pull the game info such as the
home and away team and the result.
team <- "Utah"
week <- 1
year <- 2019
interp_TimeSecsRem <- function(pbp) {
temp <- pbp %>%
mutate(TimeSecsRem = ifelse(TimeSecsRem == lag(TimeSecsRem), NA, TimeSecsRem)) %>%
select(TimeSecsRem)
ind <- which(temp$TimeSecsRem == 1800)
temp$TimeSecsRem[1] <- 1800
temp$TimeSecsRem[nrow(temp)] <- 0
temp$TimeSecsRem[ind-1] <- 0
pbp<- pbp %>%
mutate(TimeSecsRem = round(zoo::na.approx(temp$TimeSecsRem))) %>%
mutate(clock.minutes = floor(TimeSecsRem/60),clock.seconds = TimeSecsRem %% 60)
return(pbp)
}
game_pbp <- cfbfastR::cfbd_pbp_data(year, team = team, week = week, epa_wpa = TRUE) %>%
filter(down > 0) %>%
interp_TimeSecsRem()
game <- cfbfastR::cfbd_game_info(year=year, team = team, week = week)We’ll also use the cfbd_team_info() function to pull the
color and logo information and add it to the game info. We’ll also add
in a result column that is the score difference between the
home and the away teams that we’ll use later.
team_info <- cfbfastR::cfbd_team_info()
team_logos <- team_info %>%
select(school, color, alt_color, logo, alt_name2)
game <- game %>%
left_join(team_logos, by = c("away_team" = "school"),) %>%
rename(away_logo = logo, away_color = color, away_alt_color = alt_color, away_abr = alt_name2)
game <- game %>%
left_join(team_logos, by = c("home_team" = "school")) %>%
rename(home_logo = logo, home_color = color, home_alt_color = alt_color, home_abr = alt_name2) %>%
mutate(result = home_points - away_points) %>%
rename(home_score = home_points, away_score = away_points)To build the labels, we’re going to use a custom function to pull the
player names out of the play text. Saiem Gilani wrote the bulk
of the regular expressions here to get the names. EDIT: The improved
version of this is now included in the cfbd_pbp_data()
function by default.
Now we are ready to transform our play-by-play data frame to match
what we need to work with Lee Sharpe’s animation code. First, we will
rename several columns that are similar between cfbfastR
and nflfastR to match nflfastR’s column names.
Then we need to create a few new columns that cfbfastR
doesn’t have. game_seconds_remaining is really just
renaming TimeSecsRem but correcting for the half.
result grabs from the game information and is the
difference in the home and away score. We create the time
column to use as the clock on the right side of the animation.
game_pbp <- game_pbp %>%
rename(qtr = period, wp = wp_before, posteam = pos_team, defteam = def_pos_team,
away_team = away, home_team = home, play_id = game_play_number,
posteam_score = pos_team_score, defteam_score = def_pos_team_score) %>%
mutate(game_seconds_remaining = ifelse(half == 1, TimeSecsRem + 1800, TimeSecsRem),
result = game$result,
minlabel = ifelse(clock.minutes >= 15,
ifelse(clock.minutes == 15 & clock.seconds == 0, 15, clock.minutes - 15),
clock.minutes),
minlabel = ifelse(minlabel < 10, paste0("0", minlabel), minlabel),
seclabel = ifelse(clock.seconds < 10, paste0("0", clock.seconds), clock.seconds),
time = paste0(minlabel, ":", seclabel)) Now that our data matches nflfastR, we can start to copy
Lee Sharpe’s code and the bulk of the remaining code is his with a few
minor adjustments to the plot, the overtime logic, and the labels. First
we filter out plays that don’t have a win percentage and fix the win
probability so that it is always the probability of the away team
winning.
base_wp_data <- game_pbp %>%
filter(!is.na(wp)) %>%
mutate(s = game_seconds_remaining,
wp = ifelse(posteam == away_team, wp, 1 - wp))Then we fix the plays without a wpa.
# fix if play other than last is NA
for (r in (nrow(base_wp_data)-1):1) {
if (!is.na(base_wp_data$wp[r]) && is.na(base_wp_data$wpa[r]))
{
target_wp <- base_wp_data$wp[r+1]
base_wp_data$wpa[r] <- target_wp - base_wp_data$wp[r]
}
}
# fix if last play is NA
if (is.na(base_wp_data$wpa[nrow(base_wp_data)])) {
r <- nrow(base_wp_data)
move_to <- ifelse(game$result < 0, 1, ifelse(game$result > 0, 0, 0.5))
delta <- move_to - base_wp_data$wp[r]
base_wp_data$wpa[r] <- ifelse(base_wp_data$posteam[r] == game$away_team, delta, -delta)
}Now we create the labels. This generates labels for any play that had a change in the winning percentage of more than 10 percentage points. We’ll also simplify our data frame by only selecting the relevant columns for our plots.
abs_wpa <- 0.07
wp_data <- base_wp_data %>%
mutate(
helped=ifelse(wpa > 0, posteam, defteam),
text =
case_when(
abs(wpa) > abs_wpa & play_type == "Kickoff" &
!is.na(kickoff_returner_player_name) ~ glue("{kickoff_returner_player_name} KR"),
abs(wpa) > abs_wpa & play_type == "Rush" ~ glue("{rusher_player_name} Rush"),
abs(wpa) > abs_wpa & play_type == "Pass Reception" ~ glue("{receiver_player_name} Catch"),
abs(wpa) > abs_wpa & play_type == "Sack" ~ glue("{sack_player_name} SACK"),
abs(wpa) > abs_wpa & play_type == "Punt" ~ "",#glue("{punt_returner_player_name} PR"),
abs(wpa) > abs_wpa & play_type == "Pass Incompletion" ~ glue("{passer_player_name} Incomplete"),
abs(wpa) > abs_wpa & play_type == "Fumble Recovery (Opponent)" ~ glue("{posteam} FUMBLE"),
abs(wpa) > abs_wpa & play_type == "Penalty" ~ glue("PENALTY"),
abs(wpa) > abs_wpa & play_type == "Field Goal Missed" ~ glue("{posteam} FG MISS"),
abs(wpa) > abs_wpa & play_type == "Passing Touchdown" ~ glue("{receiver_player_name} TD"),
abs(wpa) > abs_wpa & play_type == "Rushing Touchdown" ~ glue("{rusher_player_name} TD"),
abs(wpa) > abs_wpa & play_type == "Field Goal Good" &
!is.na(fg_kicker_player_name) ~ glue("{fg_kicker_player_name} FG GOOD"),
abs(wpa) > abs_wpa & play_type == "Field Goal Good" &
is.na(fg_kicker_player_name) ~ glue("{posteam} FG GOOD"),
abs(wpa) > abs_wpa & play_type == "Timeout" ~ "",
abs(wpa) > abs_wpa & play_type == "Interception Return" ~ glue("{interception_player_name} INT"),
abs(wpa) > abs_wpa & play_type == "Fumble Recovery (Own)" ~ glue("{rusher_player_name} Rush"),
abs(wpa) > abs_wpa & play_type == "Blocked Field Goal" ~ glue("{posteam} FG BLK"),
abs(wpa) > abs_wpa & play_type == "Kickoff Return (Offense)" ~ glue("{kickoff_returner_player_name} KR"),
abs(wpa) > abs_wpa & play_type == "Blocked Punt" ~ glue("{defteam} PUNT BLK"),
abs(wpa) > abs_wpa & play_type == "Interception Return Touchdown" ~ glue("{interception_player_name} DEF TD"),
abs(wpa) > abs_wpa & play_type == "Kickoff Return Touchdown" &
!is.na(kickoff_returner_player_name) ~ glue("{kickoff_returner_player_name} KR TD"),
abs(wpa) > abs_wpa & play_type == "Punt Touchdown" ~ glue("{punt_returner_player_name} PR TD"),
abs(wpa) > abs_wpa & play_type == "Fumble Recovery (Opponent) Touchdown" ~ glue("{defteam} FUMBLE TD"),
abs(wpa) > abs_wpa & play_type == "Fumble Return Touchdown" ~ glue("{defteam} FUMBLE TD"),
abs(wpa) > abs_wpa & play_type == "Safety" ~ glue("SAFETY"),
abs(wpa) > abs_wpa & play_type == "Punt Touchdown" ~ glue("{posteam} PR FUMBLE TD"),
abs(wpa) > abs_wpa & play_type == "Kickoff Touchdown" ~ glue("{posteam} KR FUMBLE TD"),
abs(wpa) > abs_wpa & play_type == "Punt Return Touchdown" ~ glue("{punt_returner_player_name} PR TD"),
abs(wpa) > abs_wpa & play_type == "Uncategorized" ~ "",
abs(wpa) > abs_wpa & play_type == "Blocked Punt Touchdown" ~ glue("{defteam} PUNT BLK TD"),
abs(wpa) > abs_wpa & play_type == "placeholder" ~ "",
abs(wpa) > abs_wpa & play_type == "Missed Field Goal Return" ~ glue("{posteam} FG MISS"),
abs(wpa) > abs_wpa & play_type == "Missed Field Goal Return Touchdown" ~ glue("{defteam} FGR TD"),
abs(wpa) > abs_wpa & play_type == "Defensive 2pt Conversion" ~ glue("{defteam} DEF 2PT"),
TRUE ~ ""),
text = ifelse(text == "","", glue("{text}\n{helped} +{abs(round(100*wpa))}%")),
away_score = ifelse(posteam == away_team, posteam_score, defteam_score),
home_score = ifelse(posteam == away_team, defteam_score, posteam_score)) %>%
select(play_id, qtr, time, s, wp, wpa, posteam, away_score, home_score, text)This is where the real magic happens. Sharpe’s code will iterate over the labels and try to determine valid locations for each one.
# points for plotting
x_max <- 0
x_lab_min <- 3600 - 250
x_lab_max <- x_max + 250
x_score <- 320 - x_max
# determine the location of the label
wp_data$x_text <- NA
wp_data$y_text <- NA
wp_data <- wp_data %>% arrange(desc(abs(wpa)))
seq_fix <- function(start, end, move)
{
if (move < 0 && start < end) return(end)
if (move > 0 && start > end) return(end)
return(seq(start, end, move))
}
for (r in which(wp_data$text != ""))
{
# ordered list of spots this label could go
y_side <- wp_data$wp[r] >= 0.5
if (y_side)
{
y_spots <- c(seq_fix(wp_data$wp[r] - 0.1, 0.05, -0.1), seq_fix(wp_data$wp[r] + 0.1, 0.95, 0.1))
} else {
y_spots <- c(seq_fix(wp_data$wp[r] + 0.1, 0.95, 0.1), seq_fix(wp_data$wp[r] - 0.1, 0.05, -0.1))
}
# iterate, see if this spot is valid
for (i in 1:length(y_spots))
{
valid <- TRUE
if (nrow(wp_data %>%
filter(y_spots[i] - 0.1 < wp & wp < y_spots[i] + 0.1 &
wp_data$s[r] - 300 < s & s < wp_data$s[r] + 300)) > 0)
{
# too close to the WP line
valid <- FALSE
}
if (nrow(wp_data %>%
filter(y_spots[i] - 0.1 < y_text & y_text < y_spots[i] + 0.1 &
wp_data$s[r] - 600 < x_text & x_text < wp_data$s[r] + 600)) > 0)
{
# too close to another label
valid <- FALSE
}
if (valid)
{
# we found a spot for it, store and break loop
wp_data$x_text[r] <- wp_data$s[r]
wp_data$y_text[r] <- y_spots[i]
break
}
}
# try x_spots?
if (!valid)
{
x_side <- wp_data$s[r] >= 1800
if (x_side)
{
x_spots <- c(seq_fix(wp_data$s[r] - 400, x_lab_max, -200),
seq_fix(wp_data$s[r] + 400, x_lab_min, 200))
} else {
x_spots <- c(seq_fix(wp_data$s[r] + 400, x_lab_min, 200),
seq_fix(wp_data$s[r] - 400, x_lab_max, -200))
}
for (i in 1:length(x_spots))
{
valid <- TRUE
if (nrow(wp_data %>%
filter(wp_data$wp[r] - 0.1 < wp & wp < wp_data$wp[r] + 0.1 &
x_spots[i] - 300 < s & s < x_spots[i] + 300)) > 0)
{
# too close to the WP line
valid <- FALSE
}
if (nrow(wp_data %>%
filter(wp_data$wp[r] - 0.1 < y_text & y_text < wp_data$wp[r] + 0.1 &
x_spots[i] - 600 < x_text & x_text < x_spots[i] + 600)) > 0)
{
# too close to another label
valid <- FALSE
}
if (valid)
{
# we found a spot for it, stop loop
wp_data$x_text[r] <- x_spots[i]
wp_data$y_text[r] <- wp_data$wp[r]
break
}
}
}
# warn about the labels not placed
if (!valid)
{
warning(glue(paste("No room for ({wp_data$s[r]},{round(wp_data$wp[r], 3)}):",
"{gsub('\n',' ',wp_data$text[r])}")))
}
}Finally, we create two new rows to our data frame for the start and end of the game, filter out any other weirdness, and arrange our data frame by the order of the plays.
# add on WP boundaries
first_row <- data.frame(play_id = 0, qtr = 1, time = "15:00", s = 3600,
wp = 0.5, wpa = NA, text = as.character(""),
x_text = 3600, y_text = 0.5, away_score = 0, home_score = 0,
stringsAsFactors = FALSE)
last_row <- data.frame(play_id = 999999, qtr = max(wp_data$qtr), s = x_max - 1,
time = ifelse(max(wp_data$qtr) >= 5, "FINAL\nOT", "FINAL"),
wp = ifelse(game$result < 0, 1, ifelse(game$result > 0, 0, 0.5)),
wpa = NA, text = as.character(""), x_text = x_max, y_text = 0.5,
away_score = game$away_score, home_score = game$home_score,
stringsAsFactors = FALSE)
wp_data <- wp_data %>%
filter(posteam != "",
wpa != 0) %>%
bind_rows(first_row) %>%
bind_rows(last_row) %>%
arrange(play_id)Plotting
Now we’re ready for plotting. The draw_frame() function
will draw our win probability plot for any given number of seconds
remaining in the game. This is where you can make any changes to the
plot that you would like.
draw_frame <- function(n_sec)
{
# frame data
frm_data <- wp_data %>%
filter(s >= n_sec)
# output quarter changes
if (nrow(frm_data %>% filter(qtr == max(qtr))) == 1)
{
print(glue("Plotting pbp in quarter {max(frm_data$qtr)}"))
}
# plot
frm_plot <- frm_data %>%
ggplot(aes(x = s, y = wp)) +
theme_minimal() +
geom_vline(xintercept = c(3600, x_max), color = "#5555AA") +
geom_segment(x = -3600, xend = -x_max, y = 0.5, yend = 0.5, size = 0.75) +
geom_image(x = x_score, y = 0.82, image = game$away_logo, size = 0.08, asp = 1.5) +
geom_image(x = x_score, y = 0.18, image = game$home_logo, size = 0.08, asp = 1.5) +
geom_line(aes(color = ..y.. < .5), size = 1) +
scale_color_manual(values = c(game$away_color, game$home_color)) +
scale_x_continuous(trans = "reverse",
minor_breaks = NULL,
labels = c("KICK\nOFF", "END\nQ1", "HALF\nTIME", "END\nQ3", "FINAL"),
breaks = seq(3600, 0, -900),
limits = c(3700, x_max - 490)) +
scale_y_continuous(labels = c(glue("{game$home_abr} 100%"),
glue("{game$home_abr} 75%"),
"50%",
glue("{game$away_abr} 75%"),
glue("{game$away_abr} 100%")),
breaks = c(0, 0.25, 0.5, 0.75, 1),
limits = c(0, 1)) +
coord_cartesian(clip = "off") +
xlab("") +
ylab("") +
labs(title = glue("Win Probability Chart: {game$season} Week {game$wk} {game$away_team} @ {game$home_team}"),
caption = "Data from cfbfastR, Visualization by @LeeSharpeNFL, Adapted for CFB by @JaredDLee") +
theme(legend.position = "none")
# score display
away_score <- max(frm_data$away_score)
home_score <- max(frm_data$home_score)
# clock display
qtr <- case_when(
max(frm_data$qtr) == 1 ~ "1st",
max(frm_data$qtr) == 2 ~ "2nd",
max(frm_data$qtr) == 3 ~ "3rd",
max(frm_data$qtr) == 4 ~ "4th",
max(frm_data$qtr) == 5 ~ "OT",
TRUE ~ as.character(max(frm_data$qtr))
)
clock <- tail(frm_data$time, 1)
clock <- ifelse(substr(clock, 1, 1) == "0", substr(clock, 2, 100), clock)
clock <- paste0(qtr, "\n", clock)
clock <- ifelse(grepl("FINAL", tail(frm_data$time, 1)), tail(frm_data$time, 1), clock)
# add score and clock to plot
frm_plot <- frm_plot +
annotate("text", x = -1*x_score, y = 0.71, label = away_score, color = game$away_color, size = 8) +
annotate("text", x = -1*x_score, y = 0.29, label = home_score, color = game$home_color, size = 8) +
annotate("text", x = -1*x_score, y = 0.50, label = clock, color = "#000000", size = 6)
# label key moments
frm_labels <- frm_data %>%
filter(text != "")
frm_plot <- frm_plot +
geom_point(frm_labels, mapping = aes(x = s, y = wp),
color = "#000000", size = 2, show.legend = FALSE) +
geom_segment(frm_labels, mapping = aes(x = x_text, xend = s, y = y_text, yend = wp),
linetype = "dashed", color = "#000000", na.rm=TRUE) +
geom_label(frm_labels, mapping = aes(x = x_text, y = y_text, label = text),
size = 3, color = "#000000", na.rm = TRUE, alpha = 0.8)
# plot the frame
plot(frm_plot, width = 12.5, height = 6.47, dpi = 500)
}Let’s test our function to make sure the plot looks like how we want it by running our function with 6 minutes left in the game.
draw_frame(360)
Looks great, so next we create the draw_game() function
which will draw every frame for our GIF.
Animating
Finally, we run our draw_game() function inside of
saveGIF().
# saveGIF(draw_game(), interval = 0.1, movie.name = "animated_wp.gif")
Result
This process takes awhile, about 3 minutes on my computer. We can
also re-size our GIF using the ani.width,
ani.height and ani.res parameters. I like to
make my plots wider and at higher resolution, but be careful, this will
drastically increase the rendering time and the file size.
# saveGIF(draw_game(), interval = 0.1, movie.name = 'animated_wp_wide.gif',
# ani.width = 800, ani.height = 500, ani.res = 110)
Result