---
title: "NFL Punt Analytics Competition"
author: oilgorim
date: "01/08/2018"
output:
html_document:
theme: cosmo
toc: true
---
## Data Loading
First let's read in all data.
```{r setup}
library(data.table)
library(ggplot2)
injury_data = fread("../input/video_footage-injury.csv")
setnames(injury_data,
old = c("playid", "gamekey"),
new = c("PlayID", "GameKey"))
plays = fread("../input/play_information.csv")
play_player_roles = fread("../input/play_player_role_data.csv")
play_punt = fread("../input/player_punt_data.csv")
video_review = fread("../input/video_review.csv")
keyCols <- c("GameKey", "PlayID")
```
The NGS datasets are fragmented, let's combine them only with punt plays that resulted in a concussion. This drastically reduces the complexity of the task.
```{r, cache=F}
construct_ngs_paths <- function(year) {
prefix = paste('../input/NGS-', year, '-', sep='')
suffices = c(
'pre.csv',
'reg-wk1-6.csv',
'reg-wk7-12.csv',
'reg-wk13-17.csv',
'post.csv'
)
paste(prefix, suffices, sep='')
}
read_ngs <- function(year) {
df <- data.table()
for(p in construct_ngs_paths(year)) {
ngs <- fread(p)
setkeyv(ngs, keyCols)
dfi <- merge(ngs, injury_data)
df <- rbind(df, dfi)
}
df
}
ngs <- funion(read_ngs(2016), read_ngs(2017))
```
Let's now join NGS data with other datasets
This will duplicate some information across plays, however it make the data a bit easier to work with (and the join much simpler to write!).
```{r}
joined = merge(
merge(ngs, video_review, by=c(keyCols, "GSISID")),
merge(play_punt, play_player_roles, by="GSISID", allow.cartesian = T),
by=c(keyCols, "GSISID")
)
```
## Analysis
### Season Type
**How does season type relate to concussison?** I'd suspect that a punt-related injury is more likely in the pre-season since this involves rookies and unsigned agents who are trying to prove themselves during special teams. Let's see if there is a significant difference in concussion occurrences based on the season type.
```{r, fig.height=5, fig.width=15, message=F, warning=F}
total_punt_plays = (
plays[, .(total_plays=.N), "Season_Type"]
)
setnames(ngs,
old = c("Type"),
new = c("Season_Type"))
total_injury_punt_plays = (
unique(ngs[,.(Season_Type, GameKey, PlayID)])[,.(total_injury_plays=.N),"Season_Type"]
)
injury_likelihood <- merge(total_injury_punt_plays, total_punt_plays, by="Season_Type")
injury_likelihood$prop <- injury_likelihood$total_injury_plays / injury_likelihood$total_plays
bootstrapSeasonType <- function(stype) {
pop <- injury_likelihood[Season_Type==stype]
popVec <- c(
replicate(pop$total_injury_plays, T),
replicate(pop$total_plays, F)
)
n <- length(popVec)
bootstrapped <- sapply(1:10000, function(x) {
return(mean(sample(popVec, n, replace=T)))
})
bootstrapped
}
pre <- data.table(values=bootstrapSeasonType("Pre"))[,Season_Type:='Pre']
reg <-data.table(values=bootstrapSeasonType("Reg"))[,Season_Type:='Reg']
prereg <- funion(pre, reg)
injuryMerged <- merge(
merge(
prereg[,.(lwr=quantile(values, .025)), Season_Type],
prereg[,.(upr=quantile(values, .975)), Season_Type], by="Season_Type"),
injury_likelihood, by="Season_Type")
p1 <- ggplot(prereg, aes(x=values, fill=Season_Type)) +
geom_density(alpha=.8) + theme_bw() +
ggtitle("Bootstapped Densities of Concussion Plays by Season Type (n=10000)")
p2 <- ggplot(injuryMerged, aes(x=Season_Type, y=prop, fill=Season_Type)) +
geom_col(position = "dodge", alpha=.8) +
geom_errorbar(aes(ymin=lwr, ymax=upr), width=.2) +
geom_text(aes(label=paste(" ",
round(prop*100, 4), "%", sep="")),
position=position_dodge(width=.2), vjust=-0.25) +
theme_bw() +
ggtitle("Percent of Punt Plays Resulting in a Concussion by Season Type (with 95% CIs)") +
ylab("Percent Of Punt Plays") +
xlab("Season Type")
library(gridExtra)
grid.arrange(p1, p2, ncol=2)
```
The chart above on the left shows the bootstrapped densities of the percentage of plays resulting in a concussion per season type. I use a bootstrap technique since these percentages are so close to 0. This is constructed by sampling with replacement 10k times from each season type's observed values to create a distribution of possible values. We can then use the 0.025 and 0.975 quantiles as the 95% confidence intervals. The chart on the right shows these confidence intervals overlayed on the sample's observed percentages.
**While we do see a higher likelihood for concussions in the pre-season, the difference is not statistically significant from the regular season (hence the overlapping confidence interval bars), therefore, I attribute the increase to random noise**. This is also explained by the heavily overlapping densities on the left.
### NGS Munging
Let's now look at player's x-y positions. Below I make a ceiling and a floor for each player's possible position, as it seems some plays record positional data as players head for the sidelines.
```{r}
ngs$x[ngs$x > 120 ] <- 120
ngs$x[ngs$x < 0 ] <- 0
ngs$y[ngs$y > 53.3 ] <- 53.3
ngs$y[ngs$y < 0 ] <- 0
ngs$x <- ngs$x - 10 # shift down 10 for exact x->yardline mapping
# labels for trace plots
BREAKS = seq(-10, 110, 10)
LABELS = c("EZ", "0", "10", "20", "30", "40", "50",
"40", "30", "20", "10", "0", "EZ")
```
Below I define some helper functions.
```{r}
ballReceivedYL <- function(playDesc) {
if (grepl('J.Ryan up the middle', playDesc)) {
team <- "LA"
yl <- 47
} else {
yllist <- tail(strsplit(strsplit(playDesc, ", Center")[[1]][1], ' ')[[1]], 2)
yl <- yllist[2]
team <- yllist[1]
}
c(team, yl)
}
getSide <- function(role) {
if (role %in% c(
"GL", "GR", "PLW", "PLT", "PLG", "PLS",
"PRG", "PRT", "PRW", "PC", "PPR", "P"
)) {
"Kicking"
} else{
"Receiving"
}
}
adjustYL <- function(puntedFrom, receivedAt, pteam, rteam,
kickingStart) {
adjPuntedFrom <- 100 - puntedFrom
raw <- abs(kickingStart - puntedFrom)
adj <- abs(kickingStart - adjPuntedFrom)
adjusted <- F
if (adj < raw) {
puntedFrom <- adjPuntedFrom
adjusted <- T
}
if (adjusted) {
receivedAt <- ifelse(pteam == rteam, 100 - receivedAt, receivedAt)
} else {
receivedAt <- ifelse(pteam == rteam, receivedAt, 100 - receivedAt)
}
c(puntedFrom, receivedAt)
}
timeDiffSeconds <- function(t1, t2) {
diff <- strptime(t2, format='%Y-%m-%d %H:%M:%S.%OS') -
strptime(t1, format='%Y-%m-%d %H:%M:%S.%OS')
as.numeric(diff)
}
traceCollision <- function(s) {
gamekey <- s$GameKey
playDesc<- s$PlayDescription
playId <- s$PlayID
playerId1 <- s$GSISID
playerId2 <- s$Primary_Partner_GSISID
playerRole1 <- s$Role
playerRole2 <- play_player_roles[(GSISID == playerId2) &
(GameKey == gamekey) &
(PlayID == playId)]$Role
yl <- s$YardLine
htvt <- s$Home_Team_Visit_Team
q <- s$Quarter
link <- s$`PREVIEW LINK (5000K)`
season <- s$season
p <- ngs[(PlayID == playId) & (GameKey == gamekey)]
p$roundedx <- round(p$x)
p$roundedy <- round(p$y)
s1 <- p[GSISID == playerId1]
s2 <- p[GSISID == playerId2]
s1$side <- getSide(playerRole1)
s2$side <- getSide(playerRole2)
s <- funion(s1, s2)
playStart <- min(s$Time)
s$hurt_player <- s$GSISID == playerId1
s <- s[order(s$Time)]
s$GSISID <- factor(s$GSISID)
minx1 <- head(s[GSISID == playerId1], 1)$x
miny1 <- head(s[GSISID == playerId1], 1)$y
minx2 <- head(s[GSISID == playerId2], 1)$x
miny2 <- head(s[GSISID == playerId2], 1)$y
injuredSide <- s1$side[1]
kickingStart <- ifelse(injuredSide == "Kicking", minx1, minx2)
punted <- strsplit(yl, ' ')[[1]]
team <- punted[1]
puntedFrom <- as.numeric(punted[2])
received <- ballReceivedYL(s$PlayDescription[1])
teamr <- received[1]
receivedAt <- as.numeric(received[2])
adjustedYLs <- adjustYL(puntedFrom, receivedAt, team, teamr, kickingStart)
puntedFrom <- adjustedYLs[1]
receivedAt <- adjustedYLs[2]
onBall <- "PR" %in% c(playerRole1, playerRole2) | "P" %in% c(playerRole1, playerRole2)
penalty <- grepl("penalty", tolower(playDesc))
s$side <- factor(s$side)
p <- ggplot(s, aes(x=x, y=y, color=hurt_player, shape=side)) +
geom_point() +
annotate("point", x=minx1, y=miny1, size=4, color='green', label="Starting Position") +
annotate("point", x=minx2, y=miny2, size=4, color='green') +
theme_bw() +
scale_x_continuous(breaks = BREAKS, labels=LABELS,
limits=c(-10, 110)) +
scale_y_continuous(breaks = NULL) +
ylim(c(0, 53.3)) +
labs(title=(paste(" Game Key:", gamekey, "\n",
"Play ID:", playId, "\n",
"Season:", season, "\n",
"Home-Away:", htvt, "\n" ,
"On Ball:", onBall, "\n",
"Penalty:", penalty
)),
subtitle=paste("Desc:",
paste(substring(playDesc, 1, 70),
substring(playDesc, 71, 140),
substring(playDesc, 141, 200),
substring(playDesc, 201, nchar(playDesc)), sep='\n'))) +
geom_hline(yintercept =22.96, linetype='dashed') +
geom_hline(yintercept=53.3-22.96, linetype='dashed') +
geom_vline(xintercept = receivedAt) +
annotate("text", x=receivedAt, y=0, size=4, label="Receiving Yardline") +
geom_vline(xintercept = puntedFrom) +
annotate("text", x=puntedFrom, y=0, size=4, label="Punt Yardline")
return(c(
gamekey=gamekey,
playId=playId,
injuredSide=injuredSide,
onBall=onBall,
puntDistance=abs(puntedFrom - receivedAt),
penalty=penalty,
link=link,
plt=list((p))
))
}
```
Next we can join the relevant NGS data with some meta attributes, as well as get traces for the primary partners in the collision. If there is no indicated primary partner (`Primary_Partner_GSISID` = `NULL` or `Unclear`), the play is omitted. This leaves us with 33 plays.
```{r, warning=F, message=F, fig.width=12, fig.height=6, cache=F}
library(knitr)
library(plyr)
j <- unique(
merge(
merge(
merge(
merge(video_review, play_punt, by="GSISID"),
injury_data, by=c("GameKey", "PlayID")),
plays[,.(GameKey, PlayID, YardLine, Home_Team_Visit_Team, Quarter)], by=c("GameKey", "PlayID")),
play_player_roles[,.(GameKey, PlayID, GSISID, Role)],
by=c("GameKey", "PlayID", "GSISID")
))
j <- j[(!Primary_Partner_GSISID %in% c("Unclear", NULL, "")) &
(!grepl("d", Number))]
j <- unique(j[,.(PlayID, GameKey, GSISID, Primary_Partner_GSISID, PlayDescription, `PREVIEW LINK (5000K)`,
YardLine, Home_Team_Visit_Team, Quarter, Role, season)])
playAgg <- lapply(1:nrow(j), function(i) {
s <- j[i,]
traceCollision(s)
})
```
### Concussions on/off the ball by Kicking/Receiving team
From the meta data we can add some features to the plot such as
* Who was injured? (use `GSISID`)
* Who's on offense? (use `Role`)
* Was there a penalty? (parse `PlayDescription`)
* Did the concussion happen on the ball? (was the punt receiver (`PR`) involved?)
See above in the `traceCollision()` method for more details on how these meta fields were constructed.
Below I construct plots that show the percentage of concussions that were suffered by the Kicking/Receiving team, and on/off the ball.
```{r, fig.width=10, fig.height=5, message=F, warning=F}
library(DescTools, quietly=T)
meta <- unique(
joined[,.(Primary_Impact_Type,
Turnover_Related,
Player_Activity_Derived,
Primary_Partner_Activity_Derived,
Friendly_Fire,
GameKey,
PlayID)]
)
playMeta <- lapply(playAgg, function(i) {
c(GameKey=i$gamekey, PlayID=i$playId, injuredSide=i$injuredSide,
onBall=i$onBall,penalty=i$penalty, link=i$link)
})
playMetaDf <- as.data.frame(do.call(rbind, playMeta))
playMetaDf$penalty <- factor(playMetaDf$penalty)
injury_data$GameKey <- factor(injury_data$GameKey)
meta$GameKey <- factor(meta$GameKey)
playMetaDf$GameKey <- factor(playMetaDf$GameKey)
injury_data$PlayID <- factor(injury_data$PlayID)
meta$PlayID <- factor(meta$PlayID)
playMetaDf$PlayID <- factor(playMetaDf$PlayID)
metaMerge <- data.table(merge(
merge(
playMetaDf, meta, by=c("GameKey", "PlayID")),
injury_data, by=c("GameKey", "PlayID")
))
# util function to get CIs for a proportion
get_ci <- function(d) {
p <- BinomCI(as.numeric(d['succ']),
as.numeric(d['N']),
conf.level = 0.95)
lwr <- round(p[1,][2], 4)
upr <- round(p[1,][3], 4)
paste(lwr, upr, sep = ",")
}
# format proportion CIs based on number of successes
# and total events
stitch_cis <- function(d, succ, N) {
d$succ <- d[,..succ]
d$N <- d[,..N]
d$cis <- apply(d, 1, function(x) get_ci(x))
d$lwr <- sapply(d$cis, function(x) as.numeric(strsplit(x, ",")[[1]][1]))
d$upr <- sapply(d$cis, function(x) as.numeric(strsplit(x, ",")[[1]][2]))
d
}
n <- nrow(metaMerge)
is <- metaMerge[,.(concussions=.N, N=n, Percent=.N/n*100), .(injuredSide)]
is <- stitch_cis(is, "concussions", "N")
ggplot(is,
aes(x=injuredSide, y=Percent)) +
geom_col() +
geom_errorbar(aes(ymin=lwr*100, ymax=upr*100), width=.2) +
geom_text(aes(label=paste(" ",
round(Percent, 4), "%", sep="")),
position=position_dodge(width=.2), vjust=-0.25) +
theme_bw() +
theme_bw() +
labs(title="Percent of Concussions Suffered by Kicking/Receiving Team",
subtitle="with 95% Confidence Intervals",
x='Side of Ball')
```
```{r, fig.width=10, fig.height=5}
ob <- metaMerge[,.(concussions=.N, N=n, Percent=.N/n*100), .(onBall)]
ob <- stitch_cis(ob, "concussions", "N")
ggplot(ob,
aes(x=onBall, y=Percent)) +
geom_col() +
geom_errorbar(aes(ymin=lwr*100, ymax=upr*100), width=.2) +
geom_text(aes(label=paste(" ",
round(Percent, 4), "%", sep="")),
position=position_dodge(width=.2), vjust=-0.25) +
theme_bw() +
theme_bw() +
labs(title="Percent of Concussions Suffered On and Off the Ball",
subtitle="with 95% Confidence Intervals",
x='On the Ball')
```
```{r, fig.width=10, fig.height=8}
isn <- metaMerge[,.N, injuredSide]
obis <- merge(
metaMerge[,.(concussions=.N), .(onBall, injuredSide)],
isn,
by="injuredSide"
)
obis$Percent <- obis$concussions / obis$N * 100
obis <- stitch_cis(obis, "concussions", "N")
ggplot(obis,
aes(x=onBall, y=Percent)) +
geom_col() +
facet_grid(injuredSide~.) +
geom_errorbar(aes(ymin=lwr*100, ymax=upr*100), width=.2) +
geom_text(aes(label=paste(" ",
round(Percent, 4), "%", sep="")),
position=position_dodge(width=.2), vjust=-0.25) +
theme_bw() +
labs(title="Percent of Concussions Suffered by Kicking/Receiving Team on and off the Ball",
subtitle="with 95% Confidence Intervals",
x='On the Ball')
```
From the charts above we can conclude:
* **70% of concussions in the sample were suffered by the Kicking team**
* 60% of concussions in the sample were suffered off the ball
* Concussions suffered by the receiving team have an approximately equal chance of being on or off the ball, while those suffered by the kicking team are much more likely to be off the ball
Note that only the first bullet is in bold, since it is the only result that is a statistically significant difference. **For a sample of two seasons, we can expect the percentage of concussions suffered by the kicking team to be higher than the receiving team 95% of the time.**
Players on the kicking team are disadvantaged from a safety standpoint!
### Play Traces
Since there are only 33 concussion-related plays, it was realistic for me review all the footage accompanied by the traces of the 2 main players involved in the injury. Not all the footage contained the concussion-inducing collision, however I hand picked 7 that highlight a clear problem with punt plays, which is supported by the preceding analysis.
Below is a helper function to get a play's specific player trace plot.
```{r, fig.width=10, fig.height=6}
getPlot <- function(playId, gameKey) {
p <- NULL
for (i in 1:length(playAgg)) {
play <- playAgg[[i]]
if ((play$gamekey == gameKey) &
(play$playId == playId)) {
p <- play$plt
}
}
return(p)
}
```
Note that some example footage has yellow circles that highlight the collision that resulted in a concussion, whereas in others the collision is more obvious and no circle is needed. In the trace plots themselves, the green circles indicate each player's respective starting point on the play.
---
#### Example 1
The play below resulted in the penalty: `Illegal Blindside Block`. In fact, had this blocker gone a bit lower with his initial contact, this play would be considered legal.
```{r}
getPlot(playId=2587, gameKey=21)
```
---
#### Example 2
The play below had no penalty.
```{r}
getPlot(playId=1976, gameKey=231)
```
---
#### Example 3
The play below had no penalty related to the collision resulting in a concussion.
```{r}
getPlot(playId=2489, gameKey=364)
```
---
#### Example 4
The play below had no penalty. Note that there are **2** dangerous blocks just milliseconds from each other.
```{r}
getPlot(playId=2764, gameKey=364)
```
---
#### Example 5
The play below had no penalty.
```{r}
getPlot(playId=1088, gameKey=392)
```
---
#### Example 6
```{r}
getPlot(playId=2792, gameKey=448)
```
#### Example 7
The play below resulted in the penalty: `Unnecessary Roughness`. It isn't clear how this play is much different than the plays above that resulted in no penalty. Perhaps it is due to the theatrical aspect of the hit, or that the player **might** have left his feet as he was making contact.
```{r}
getPlot(playId=1683, gameKey=553)
```
---
**All of the above 7 blocks should be illegal!** While these big-hit plays are relished by the fans (and likely the players who come out un-concussed), these blocks are extremely dangerous since they involve a player coming full steam in the opposite direction of the ball. While many are considered blindside blocks, I consider this type of block to be a special case of the blindside block, as not all blindside blocks look this way.
Next I go into my recommendation for revising the NFL rule book to clearly outlaw these blocks.
## Recommended Rule Change
### Existing Protections
The analysis in the preceding sections indicates that players on the kicking team need to be better protected by dangerous blocks during punt plays. While the focus here is on punts, this can be applied to any play that involves heavy directional changes like interceptions, fumbles, quarterback scrambles, etc.
Right now, these players are offered certain protections, but these protections are ambiguous when applied to the example plays above. Again, only 2 out of the 7 blockers above were penalized.
One protection is in [Article 6: Unncecessary Roughness](https://operations.nfl.com/the-rules/2018-nfl-rulebook/#article-6.-unnecessary-roughness). which states that following is illegal:
> unnecessarily running, diving into, cutting, or throwing the body against or on a player who (1) is out of the play or (2) should not have reasonably anticipated such contact by an opponent, before or after the ball is dead;
Another protection can be found in [Article 7: Players in a Defenseless Posture](https://operations.nfl.com/the-rules/2018-nfl-rulebook/#article-7.-players-in-a-defenseless-posture). Definition 10 states the following player is protected since they are in a defenseless posture:
> A player who receives a “blindside” block when the path of the blocker is toward or parallel to his own end line.
It is my opinion that each of the blocked players in the examples above fall into this category. However, in Article 7 section b, the following contact is prohibited against these players:
* forcibly hitting the defenseless player’s **head or neck area** with the helmet, facemask, forearm, or shoulder, even if the initial contact is lower than the player’s neck, and regardless of whether the defensive player also uses his arms to tackle the defenseless player by encircling or grasping him;
* lowering the head and making forcible contact with any part of the helmet against any part of the defenseless player’s body ; or
* illegally launching into a defenseless opponent. It is an illegal launch if a player (i) leaves both feet prior to contact to spring forward and upward into his opponent, and (ii) uses any part of his helmet to initiate forcible contact against any part of his opponent’s body. (This does not apply to contact against a runner, unless the runner is still considered to be a defenseless player, as defined in Article 7.)
It is therefore legal to perform a blindside block when the the blocker strikes below the helmet and above the waist. During punts, almost every player is running at full speed. So even if a blocker strikes the opponent in the (legal) midsection, there is still significant risk to the blocker in this scenario.
### Rule Change for 2019
My goal is to suggest a rule that makes each of the 7 plays penalize-able, therefore deterring all blocking players from making high-speed blindside blocks. The rule should amend or add to either Article 6 or Article 7, protecting players on both sides from:
"A blindside block **anywhere on the body** when the path of the offensive blocker is toward or parallel to his own end line, **in the open field**, AND **in the opposite direction of the ball-carrier**.
The bolded sections are the changes I suggest to this already existing protection:
* **anywhere on the body**: tightens the current restriction of at or above the neck or below the waist.
* **in the open field**: an attempt to suggest the player is running at near full speed
* **in the opposite direction of the ball-carrier**: "toward or parallel to the end line" does not imply a head-on collision. Stating that the direction is opposite of the ball carrier implies that the collision is head-on or perpendicular.
**Note that under this suggested rule change, the [first example](#example-1) is considered legal if the blocker made contact below the neck since it was NOT in the opposite direction of the ball carrier**
While I'm not an expert in the structure and language of the NFL rule book, the blocks that fit the quoted statement above are clearly recognizable and should be a quick throw of the yellow flag for an official. These types of blocks are deliberate and targeted. The blockers, becoming aware of the rule change, can easily take a different, safer approach.
#### Risks
---
**Defensive players get a leg-up**
The major risk I see with this rule is for the receiving team (blockers) should the rule be implemented. Imagine a blocker running parallel to his own end line and slowing down to avoid penalty. This gives the defensive player an advantage if they see the block coming. However, since these are primarily blindside blocks (even head-on blocks are not typically seen until the last second), the slowing down of the blocker will still prevent a devastating collision.
**Fan blowback**
I expect many fans will not take kindly to such a rule change, however, I liken these blocks to a defenseless receiver or QB just after throwing the ball. There is precedent for such cautionary rule adjustments, and since these all happen off the ball, I don't see any player behavior modifications affecting the average fan's viewing experience, i.e. "That *would* have been a great block."
## Conclusion
In this report I used NGS data, punt play meta data and video clips to identify a problem with punt plays. To avoid unnecessary, high-speed, head on collisions, I recommend that a semantically equivalent version of the following statement be incorporated into the NFL Rule book for the 2019 season:
> Defensive players who receive a blindside block **anywhere on the body** when the path of the offensive blocker is toward or parallel to his own end line, **in the open field**, AND **in the opposite direction of the ball-carrier** are protected, and such behavior will result in a penalty.
Thank you for reading my analysis; I am thrilled to have contributed toward making the NFL safer for its players!