TidyTuesday - NFL Data - 2020 - Wk 6

The attendance dataset

kable(head(attendance))

attendance %>%
  skim()

Variable type: character

Variable type: numeric

We certainly have some interesting statistics here to mess with. It looks like the ‘total,’ ‘home,’ and ‘away’ attendance columns represent the entire season, while the ‘weekly_attendance’ field is for each week. Therefore, it looks like each row is a game. So there should be some variability in how many rows there are amongst the teams, as some make it to the playoff and some do not (therefore they’d have more games). A look at the summary statistics should tell us more… if that is the case or not.

So, as was expected, there does seem to be some variability associated with how many games they play. Not to worry, I’ll probably stay away from analyzing just that, and focus on either more aggregated descriptives or simply other statistics herein.

The standings dataset

kable(head(standings))

standings %>% 
  skim()

Variable type: character

Variable type: numeric

So, look at this snapshot of the data, there seems to be all kinds of interesting statistics between attendance and what appears to be by team year statistics.

The games dataset

kable(head(games))

From this vantage, it looks like I could connect the team name from the attendance data to the home team of the games data. To do so, I’ll have to make a key that matches. Most readily, it looks like I’ll need to combine a few the ‘team’ and ‘team_name’ columns in the attendance data.

att_reshape <- attendance %>% 
  mutate(t_name = str_c(team, team_name, sep = " ")) %>%
  select(-team, -team_name)

# to merge these datasets, I needed 'week' to be numeric on both... 
# and for whatever reason it was a character field to begin with...
games <- games %>%
  mutate(week = as.numeric(week))

att_games <- left_join(att_reshape, games, 
                       by = c('t_name' = 'home_team', 'year' = 'year', 'week' = 'week'))

kable(head(att_games))

At first glance it looks like there is a bunch of missing data, but because I merged on the home team, almost all the missingness appears to be related to the team is away or if they had a by week. Which makes it less alarming… I was alarmed at first… “did my join work?”

Nevertheless, I think we’re almost at a point to start visualizing stuff. It would be helpful to have a column identifying if a team is home or away… just so I can sort on it later.

att_games_ha <- att_games %>%
  mutate(away_team_ind = if_else(is.na(away_team) & !is.na(weekly_attendance), 1, 0),
         away_team_ind = case_when(
           is.na(weekly_attendance) ~ 9999,
           TRUE ~ away_team_ind))

So, by doing all of this, I can see trends across time of how well a team does in terms of attendance between home and away games.

Lets take a look.

chiefs <- att_games_ha %>%
  filter(t_name == "Kansas City Chiefs") 

chiefs_gg <- chiefs %>%
  filter(away_team_ind != 9999) %>%
  group_by(year, week, away_team_ind) %>%
  summarize(average_att = mean(weekly_attendance)) %>%
  ggplot(aes(x = year, y = average_att)) +
  geom_point() + 
  facet_wrap(~away_team_ind)

chiefs_gg

Well, that’s interesting… but I wonder if the obvious dip in at home attendance between ~2007 and ~2013 is simply a localized artifact to the Chiefs.

all_gg <- att_games_ha %>%
  filter(away_team_ind != 9999) %>%
  group_by(t_name, year, away_team_ind) %>%
  summarize(average_att = mean(weekly_attendance)) %>% ungroup() %>%
  ggplot(aes(x = year, y = average_att, color = as.factor(away_team_ind))) +
  geom_point() + 
  facet_wrap(~t_name) + 
  theme(legend.position = "top")

all_gg

So obviously, each team has a fairly unique pattern of attendance, especially between home and away games. You can also see where some teams got a new stadium that pushed attendance up, such as the Dallas Cowboys.

gg1 <- att_games_ha %>%
  filter(away_team_ind != 9999) %>%
  group_by(t_name, year, week, away_team_ind) %>%
  summarize(average_att = mean(weekly_attendance)) %>%
  ggplot(aes(t_name, average_att, color = as.factor(away_team_ind))) +
  geom_boxplot(outlier.alpha = .5) + 
  coord_flip() + 
  theme(legend.position = "top")

gg1

Although both the previous graph do not exhibit any clear reoccuring or dicernable trends, it makes me wonder what the relationship between home attendance and season performance is. Said another way, does a strong home team crowd during the first half of the season, relate to eventual success?

Lets take a look.

standings <- standings %>%
  mutate(t_name = str_c(team, team_name, sep = " "))
  
predict_1 <- att_games_ha %>%
  filter(!is.na(away_team),
         week < 8) %>%
  group_by(year, t_name) %>%
  summarize(avg.att = mean(weekly_attendance)) %>% ungroup() %>%
  left_join(standings, by = c("year", "t_name")) %>%
  mutate(perc.win = wins/(wins+loss))

cor(predict_1$avg.att, predict_1$perc.win) #this is not promissing, but lets visualize

## [1] 0.09888602

predict_1_gg <- predict_1 %>%
  ggplot(aes(x = perc.win, y = avg.att)) + 
  geom_point() 

predict_1_gg

So much variability. I would assume this is because each team has different stadium sizes, and therefore the y-axis is not relative across teams. Lets see if we can control this.

Let’s first create a function to normalize data within group (year, team)

zscore <- function(m){
  (m - mean(m)) / sd(m)
}

Group it and then lets see how things relate.

# Full season results were used, although home and away games' attendance will count for more than one team at a time. 

predict_2 <- att_games_ha %>%
  # filter(!is.na(away_team)) %>%
  filter(!is.na(weekly_attendance)) %>%
  group_by(year, t_name) %>%
  mutate(avg.att = zscore(weekly_attendance)) %>% ungroup() %>%
  left_join(standings, by = c("year", "t_name")) %>%
  mutate(perc.win = wins/(wins+loss)) %>%
  # filter(week < 8) %>%
  # filter(week > 4 & week < 10) %>% #trying out different perspectives
  # filter(week > 8) %>%
  group_by(year, t_name, perc.win) %>%
  summarize(avg_first_half = mean(avg.att)) %>% ungroup()

Lets take a look now.

predict_2_gg <- predict_2 %>%
  ggplot(aes(x = perc.win, y = avg_first_half)) + 
  geom_point() + 
  geom_smooth(method = "auto")
  
  # geom_point() + 
  # geom_smooth(stat = "smooth")

predict_2_gg

Although first half season attendance does not seem to be extensively predictive, perhaps there are other indicators that could help improve this model. Lets look a bit deeper here.

cor(predict_2$perc.win, predict_2$avg_first_half, method = "pearson")

## [1] 0.0536111

lm1 <- lm(data = predict_2, perc.win ~ avg_first_half)
broom::tidy(lm1)

## # A tibble: 2 x 5
##   term           estimate std.error statistic   p.value
##   <chr>             <dbl>     <dbl>     <dbl>     <dbl>
## 1 (Intercept)    5.01e- 1  7.66e- 3     65.4  1.72e-284
## 2 avg_first_half 8.59e+14  6.34e+14      1.35 1.76e-  1

broom::glance(lm1)

## # A tibble: 1 x 11
##   r.squared adj.r.squared sigma statistic p.value    df logLik   AIC   BIC
##       <dbl>         <dbl> <dbl>     <dbl>   <dbl> <int>  <dbl> <dbl> <dbl>
## 1   0.00287       0.00131 0.193      1.83   0.176     2   146. -286. -273.
## # … with 2 more variables: deviance <dbl>, df.residual <int>

lm2 <- lm(data = predict_2, perc.win ~ year + avg_first_half + year*avg_first_half)
broom::tidy(lm2)

## # A tibble: 4 x 5
##   term                 estimate std.error statistic p.value
##   <chr>                   <dbl>     <dbl>     <dbl>   <dbl>
## 1 (Intercept)          8.43e- 1  2.70e+ 0     0.312   0.755
## 2 year                -1.70e- 4  1.34e- 3    -0.126   0.899
## 3 avg_first_half       1.15e+17  2.34e+17     0.491   0.624
## 4 year:avg_first_half -5.67e+13  1.16e+14    -0.487   0.626

broom::glance(lm2)

## # A tibble: 1 x 11
##   r.squared adj.r.squared sigma statistic p.value    df logLik   AIC   BIC
##       <dbl>         <dbl> <dbl>     <dbl>   <dbl> <int>  <dbl> <dbl> <dbl>
## 1   0.00325      -0.00147 0.193     0.689   0.559     4   146. -283. -260.
## # … with 2 more variables: deviance <dbl>, df.residual <int>

predict_3 <- predict_2 %>%
  left_join(standings, by = c("year", "t_name"))

lm3 <- lm(data = predict_3, perc.win ~ year + avg_first_half + points_for)
broom::tidy(lm3)

## # A tibble: 4 x 5
##   term            estimate std.error statistic   p.value
##   <chr>              <dbl>     <dbl>     <dbl>     <dbl>
## 1 (Intercept)     8.60e+ 0  1.81e+ 0      4.75 2.55e-  6
## 2 year           -4.39e- 3  9.04e- 4     -4.85 1.53e-  6
## 3 avg_first_half  4.38e+14  4.26e+14      1.03 3.04e-  1
## 4 points_for      2.03e- 3  7.29e- 5     27.9  2.68e-112

broom::glance(lm3)

## # A tibble: 1 x 11
##   r.squared adj.r.squared sigma statistic   p.value    df logLik   AIC   BIC
##       <dbl>         <dbl> <dbl>     <dbl>     <dbl> <int>  <dbl> <dbl> <dbl>
## 1     0.552         0.550 0.129      261. 3.77e-110     4   402. -793. -771.
## # … with 2 more variables: deviance <dbl>, df.residual <int>