SetUp, and Imports:

To set up, I loaded the data file in and loaded my packages that I planned on using. These packages consisted of many such as dplyr,data.table,scales,ggplot (and 2!). Next I just loaded in the .csv data and cleaned/organized them into direct data sets that I can use onward. I also used some outputed lines to see what my overall data set looks like at first. 

setwd("/Users/connorwilliams/Documents/SportsAn/NFLBDB22")

source("https://raw.githubusercontent.com/ptallon/SportsAnalytics_Fall2026/refs/heads/main/SharedCode.R")
load_packages(c("data.table", "dplyr", "ggplot2", "scales", "knitr", "kableExtra"))

library(data.table)
library(dplyr)
library(ggplot2)
library(scales)
library(knitr)
library(kableExtra)


games   <- fread("games.csv")
plays   <- fread("plays.csv")
players <- fread("players.csv")
pff     <- fread("PFFScoutingData.csv")

Data Cleaning:

I first used “df” to merge the data into one frame. This allows me to have everything in one spot and to move on from there. Next I isolated just the field goal attempts. I wanted to just use the field goals since I am finding the best field goal kicker. I then cleaned the data to get rid of n/a’s and only keep the Good or No Good Attempts. 

df <- plays %>%
  left_join(games, by = "gameId") %>%
  left_join(players %>% select(nflId, displayName),
            by = c("kickerId" = "nflId")) %>%
  left_join(pff, by = c("gameId", "playId"))

fg <- df %>% filter(specialTeamsPlayType == "Field Goal")

fg_clean <- fg %>%
  filter(specialTeamsResult %in% c("Kick Attempt Good", "Kick Attempt No Good"),
         !is.na(kickLength),
         !is.na(displayName)) %>%
  mutate(made = ifelse(specialTeamsResult == "Kick Attempt Good", 1, 0),
         possessionTeam = ifelse(possessionTeam == "OAK", "LV", possessionTeam)) %>%
  arrange(season, week, gameId, playId) %>%
  data.frame()

# Summary of what the cleaning did
data.frame(
  Step = c("All plays (df)",
           "Field goal plays (fg)",
           "Removed",
           "Clean attempts (fg_clean)",
           "Made kicks",
           "Missed kicks",
           "League-wide FG %"),
  Value = c(format(nrow(df), big.mark = ","),
            format(nrow(fg), big.mark = ","),
            format(nrow(fg) - nrow(fg_clean), big.mark = ","),
            format(nrow(fg_clean), big.mark = ","),
            format(sum(fg_clean$made), big.mark = ","),
            format(sum(fg_clean$made == 0), big.mark = ","),
            paste0(round(100 * mean(fg_clean$made), 1), "%")),
  Meaning = c("Every special teams play after merging the four files",
              "Only field goal plays (no punts, kickoffs, or extra points)",
              "Blocked kicks, fakes, and plays missing a distance or kicker name",
              "Kicks that were a clean make or miss, which is what I score",
              "Clean kicks that went through the uprights",
              "Clean kicks that missed",
              "Share of clean kicks that were made, the average I compare kickers to")
) %>%
  kable(col.names = c("Step", "Count", "What It Means")) %>%
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
Step Count What It Means
All plays (df) 19,979 Every special teams play after merging the four files
Field goal plays (fg) 2,657 Only field goal plays (no punts, kickoffs, or extra points)
Removed 53 Blocked kicks, fakes, and plays missing a distance or kicker name
Clean attempts (fg_clean) 2,604 Kicks that were a clean make or miss, which is what I score
Made kicks 2,218 Clean kicks that went through the uprights
Missed kicks 386 Clean kicks that missed
League-wide FG % 85.2% Share of clean kicks that were made, the average I compare kickers to

Expected Make Model:

To be fair to kickers with longer attempts, I needed to know how likely an average kicker is to make a kick from any distance. I used a logistic regression, which draws a curve showing how the chance of a make drops as the kick gets longer. It’s a curve and not a straight line because a probability can’t go above certain or below impossible. Short kicks are nearly automatic, and the odds fall off fast once you get into the 40s and beyond. The model gave me two numbers, an intercept of 6.593 and a slope of -0.1157. The slope means every extra yard lowers a kick’s chances. Plugging those into the logistic formula gives the equation for the chance of a make. I then weighted each kicker based off of that. 

fg_model <- glm(made ~ kickLength, data = fg_clean, family = binomial)

fg_clean$exp_make  <- predict(fg_model, type = "response")
fg_clean$fgoe_kick <- fg_clean$made - fg_clean$exp_make

# The equation, shown in a small titled table with the model's actual numbers
b0 <- coef(fg_model)[1]
b1 <- coef(fg_model)[2]

data.frame(
  Equation = sprintf("P(make) = 1 / (1 + e^-(%.3f %s %.4f x distance))",
                     b0, ifelse(b1 < 0, "-", "+"), abs(b1))
) %>%
  kable(col.names = "Chance of a Made Field Goal (Logistic Regression)",
        align = "c") %>%
  kable_styling(bootstrap_options = c("bordered"), full_width = FALSE) %>%
  row_spec(1, bold = TRUE, font_size = 16, background = "#f2f2f2")
Chance of a Made Field Goal (Logistic Regression)
P(make) = 1 / (1 + e^-(6.593 - 0.1157 x distance)) 
weights_tbl <- data.frame(kickLength = c(25, 35, 45, 55, 60))
weights_tbl$prob_make    <- predict(fg_model, newdata = weights_tbl, type = "response")
weights_tbl$credit_make  <- 1 - weights_tbl$prob_make    # points earned for a make
weights_tbl$penalty_miss <- -weights_tbl$prob_make       # points lost for a miss

weights_tbl %>%
  mutate(across(where(is.numeric), ~ round(.x, 3))) %>%
  kable(col.names = c("Distance (yds)", "Chance of Make", "Credit if Made", "Penalty if Missed"),
        caption = "How each kick is weighted: easy kicks earn little and cost a lot, long kicks earn a lot and cost little") %>%
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
How each kick is weighted: easy kicks earn little and cost a lot, long kicks earn a lot and cost little
Distance (yds) Chance of Make Credit if Made Penalty if Missed
25 0.976 0.024 -0.976
35 0.927 0.073 -0.927
45 0.800 0.200 -0.800
55 0.558 0.442 -0.558
60 0.414 0.586 -0.414

Kicker Table:

Here I used group_by and summarise to build each kicker’s totals: attempts, makes, field goal percentage, average distance, expected makes, and FGOE (makes minus expected makes). I grouped by name and team first, like the assignment says. But a few kickers changed teams, which split their kicks into smaller pieces, so I also grouped by name alone and used that version for the charts. I only kept kickers with a solid number of attempts so a couple of kicks couldn’t swing the ranking. 

min_attempts <- 25

kicker_team_stats <- fg_clean %>%
  group_by(displayName, possessionTeam) %>%
  summarise(
    seasons        = n_distinct(season),
    attempts       = n(),
    makes          = sum(made),
    fg_pct         = makes / attempts,
    avg_distance   = mean(kickLength),
    expected_makes = sum(exp_make),
    fgoe           = makes - expected_makes,
    fgoe_per_att   = fgoe / attempts,
    .groups = "drop"
  ) %>%
  filter(attempts >= min_attempts) %>%
  arrange(-fgoe)


kicker_stats <- fg_clean %>%
  group_by(displayName) %>%
  summarise(
    teams          = paste(unique(possessionTeam), collapse = "/"),
    seasons        = n_distinct(season),
    attempts       = n(),
    makes          = sum(made),
    fg_pct         = makes / attempts,
    avg_distance   = mean(kickLength),
    longest_made   = max(kickLength * made),
    expected_makes = sum(exp_make),
    fgoe           = makes - expected_makes,
    fgoe_per_att   = fgoe / attempts,
    .groups = "drop"
  ) %>%
  filter(attempts >= min_attempts) %>%
  arrange(-fgoe)

kicker_stats %>%
  select(displayName, teams, attempts, makes, fg_pct, avg_distance, expected_makes, fgoe) %>%
  mutate(across(where(is.numeric), ~ round(.x, 2))) %>%
  kable(col.names = c("Kicker", "Teams", "Attempts", "Makes", "FG %",
                      "Avg Distance", "Expected Makes", "FGOE")) %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"), full_width = FALSE) %>%
  scroll_box(height = "450px")
Kicker Teams Attempts Makes FG % Avg Distance Expected Makes FGOE
Justin Tucker BAL 92 87 0.95 37.97 78.02 8.98
Jason Myers NYJ/SEA 80 73 0.91 39.36 67.38 5.62
Brandon McManus DEN 82 72 0.88 40.78 66.50 5.50
Josh Lambo JAX 57 54 0.95 37.77 48.52 5.48
Graham Gano CAR/NYG 45 42 0.93 39.91 37.49 4.51
Wil Lutz NO 85 77 0.91 37.51 73.46 3.54
Harrison Butker KC 84 77 0.92 35.92 73.66 3.34
Mason Crosby GB 71 63 0.89 39.48 60.08 2.92
Younghoe Koo ATL 57 52 0.91 36.79 49.80 2.20
Nick Folk NE 41 38 0.93 36.80 35.82 2.18
Jason Sanders MIA 83 71 0.86 39.13 69.69 1.31
Dustin Hopkins WAS 85 73 0.86 39.07 71.71 1.29
Randy Bullock CIN 77 66 0.86 39.12 64.79 1.21
Ka’imi Fairbairn HOU 94 81 0.86 38.27 79.91 1.09
Matt Bryant ATL 34 28 0.82 41.35 27.47 0.53
Chris Boswell PIT 62 55 0.89 35.97 54.73 0.27
Greg Zuerlein LA/DAL 92 76 0.83 39.45 76.09 -0.09
Aldrick Rosas NYG/JAX 52 45 0.87 36.21 45.29 -0.29
Joey Slye CAR 53 42 0.79 40.58 42.52 -0.52
Matt Prater DET 78 65 0.83 38.00 65.87 -0.87
Tyler Bass BUF 28 22 0.79 40.11 22.88 -0.88
Matt Gay TB/LA 43 35 0.81 39.86 35.89 -0.89
Rodrigo Blankenship IND 36 31 0.86 35.69 31.91 -0.91
Robbie Gould SF 77 66 0.86 36.95 66.98 -0.98
Ryan Succop TEN/TB 60 52 0.87 35.78 53.42 -1.42
Adam Vinatieri IND 47 38 0.81 37.55 39.88 -1.88
Sam Ficken LA/NYJ 38 30 0.79 39.32 31.94 -1.94
Austin Seibert CLE/CIN 34 27 0.79 38.91 29.03 -2.03
Stephen Hauschka BUF/JAX 54 43 0.80 39.78 45.07 -2.07
Jake Elliott PHI 66 54 0.82 38.24 56.14 -2.14
Stephen Gostkowski NE/TEN 63 51 0.81 38.79 53.16 -2.16
Zane Gonzalez CLE/ARI 62 50 0.81 38.26 52.19 -2.19
Cairo Santos LA/TB/TEN/CHI 50 41 0.82 37.48 43.35 -2.35
Cody Parkey CHI/TEN/CLE 53 44 0.83 37.45 46.40 -2.40
Dan Bailey MIN 71 59 0.83 37.10 61.77 -2.77
Brett Maher DAL 60 47 0.78 38.52 49.91 -2.91
Michael Badgley LAC 61 49 0.80 38.49 51.99 -2.99
Daniel Carlson MIN/LV 77 64 0.83 35.88 67.77 -3.77

Visualiation 1:

Each bar shows how many more field goals a kicker made than an average kicker (Field Goals Expected) would have from the same distances. Green means above average, red means below, and the label on each bar shows his attempts so you can see how much data is behind it. Justin Tucker lands at the top, followed by Jason Myers, Brandon McManus, and Josh Lambo. 

plot_df <- kicker_stats %>%
  mutate(label = paste0(displayName, " (", teams, ")"),
         above = ifelse(fgoe >= 0, "Above expected", "Below expected"))

ggplot(plot_df, aes(x = reorder(label, fgoe), y = fgoe, fill = above)) +
  geom_col(width = 0.75) +
  geom_text(aes(label = paste0(attempts, " att"),
                hjust = ifelse(fgoe >= 0, -0.15, 1.15)),
            size = 3, color = "grey30") +
  coord_flip() +
  scale_fill_manual(values = c("Above expected" = "#1b7837",
                               "Below expected" = "#b2182b")) +
  scale_y_continuous(expand = expansion(mult = 0.12)) +
  labs(title = "Who Is the NFL's Best Kicker?",
       subtitle = "Field Goals Over Expected (FGOE), 2018-2020 | Minimum 25 attempts",
       x = NULL,
       y = "Made field goals above what an average kicker would make from the same distances",
       fill = NULL,
       caption = "Blocked kicks and non-kick plays excluded. Data: 2022 NFL Big Data Bowl") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "top",
        plot.title = element_text(face = "bold", size = 16),
        panel.grid.major.y = element_blank())

Visualzation 2:

This chart shows why the rankings look the way they do. The black curve is the average kicker’s chance of making a kick at each distance, which is the equation from above drawn out. Each dot is a real kick, sitting at the top if it was made and at the bottom if it was missed. A make on the right side, where the curve is low, earns a lot of credit. A miss on the left side, where the curve is high, costs a lot. The panels show the best and worst kickers so you can see where their makes and misses landed. 

top_bottom <- c(head(kicker_stats$displayName, 2), tail(kicker_stats$displayName, 2))

curve_df <- data.frame(kickLength = seq(18, 68, by = 0.5))
curve_df$exp_make <- predict(fg_model, newdata = curve_df, type = "response")

pts <- fg_clean %>%
  filter(displayName %in% top_bottom) %>%
  mutate(result = ifelse(made == 1, "Made", "Missed"),
         displayName = factor(displayName, levels = top_bottom))

ggplot(pts, aes(x = kickLength, y = made)) +
  geom_line(data = curve_df, aes(x = kickLength, y = exp_make),
            inherit.aes = FALSE, linewidth = 1.1, color = "grey20") +
  geom_jitter(aes(color = result), height = 0.04, width = 0, alpha = 0.8, size = 2) +
  facet_wrap(~ displayName, ncol = 2) +
  scale_color_manual(values = c("Made" = "#1b7837", "Missed" = "#b2182b")) +
  scale_y_continuous(labels = percent_format(), breaks = c(0, 0.25, 0.5, 0.75, 1)) +
  labs(title = "Why the Rankings Look the Way They Do",
       subtitle = "Black curve = chance an average kicker makes the kick. Dots = each kicker's actual attempts.",
       x = "Kick distance (yards)",
       y = "Make probability",
       color = NULL,
       caption = "Misses on the left side of the curve cost the most. Makes on the right side earn the most.") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "top",
        plot.title = element_text(face = "bold", size = 16),
        strip.text = element_text(face = "bold"))