sample-nflfastR.R

library(arrow)
library(tidyverse)
library(slider)

ds <- arrow::open_dataset("data-parquet/", partitioning = "year")

all_plays <- ds |> 
  filter(!is.na(touchdown)) |> 
  filter(penalty == 0) |> 
  select(touchdown) |> 
  collect()

samp_ratio <- 50/nrow(all_plays)
samp_ratio

set.seed(100)
all_samp <- tibble(id = 1:30) |> 
  mutate(samples = map(id, function(x) slice_sample(all_plays, n = 50)))

samples_calc <- all_samp |> 
  mutate(est_td_rate = map_dbl(samples, ~mean(.x$touchdown)),
         est_sd = map_dbl(samples, ~sd(.x$touchdown)),
         est_td_overall = mean(est_td_rate)
         )|> 
  rowwise() |> 
  mutate(est_td_ratio = slide_dbl(est_td_rate, .f = mean, .before = 30)) |> 
  ungroup()

samples_calc |> 
  slice_tail(n = 1)

all_plays |> 
  summarise(n = n(), td_ratio = sum(touchdown)/n)

sample_plot <- samples_calc |> 
  ggplot(aes(x = id, y = est_td_ratio)) +
  geom_line() +
  geom_point() +
  geom_hline(aes(yintercept = est_td_overall)) +
  geom_hline(yintercept = 0.0309, color = "red") +
  geom_text(
    aes(x = 0, y = .25, label = "Actual TD Rate = ~3.1%"), color = "red", 
    hjust = 0, vjust = 0, position = position_nudge(y = 0.02)) +
  geom_text(
    aes(x = 0, y = .15, label = paste0("Estimated TD Rate = ~", scales::label_percent(accuracy = 0.1)(est_td_overall))), 
    color = "black", hjust = 0, vjust = 0, position = position_nudge(y = 0.02)) +
  geom_point(aes(x = 0, y = 0.0309), color = "red") +
  scale_y_continuous(limits = c(0, 1), labels = scales::label_percent()) +
  labs(x = "Sample ID", y = "Touchdown Rate", 
       title = "Estimated vs Actual Touchdown Rate in {nflfastR}",
       subtitle = "Total plays = 970,767 | Each sample = 50 plays (0.005%)")

ggsave("sample-nfl.png", sample_plot, dpi = "retina", height = 4, width = 6)

# Gist URL https://gist.github.com/d1a06bcbedf290954ff9d7d230c817aa