Library

  • These following packages will help reproduce the results contained within this project:
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.1
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(ggplot2)
library(dplyr)
library(tidyr)
library(readxl)
library(fpp3)
## Registered S3 method overwritten by 'tsibble':
##   method               from 
##   as_tibble.grouped_df dplyr
## ── Attaching packages ──────────────────────────────────────────── fpp3 1.0.1 ──
## ✔ tsibble     1.1.5     ✔ feasts      0.4.1
## ✔ tsibbledata 0.4.1     ✔ fable       0.4.1
## ── Conflicts ───────────────────────────────────────────────── fpp3_conflicts ──
## ✖ lubridate::date()    masks base::date()
## ✖ dplyr::filter()      masks stats::filter()
## ✖ tsibble::intersect() masks base::intersect()
## ✖ tsibble::interval()  masks lubridate::interval()
## ✖ dplyr::lag()         masks stats::lag()
## ✖ tsibble::setdiff()   masks base::setdiff()
## ✖ tsibble::union()     masks base::union()
library(lubridate)
library(tsibble)
library(fable)
library(fabletools)
library(feasts)

Dataset

nfl <- read_excel("2018NFLAttendance.xlsx")
glimpse(nfl)
## Rows: 544
## Columns: 8
## $ Team       <chr> "Arizona Cardinals", "Atlanta Falcons", "Baltimore Ravens",…
## $ Week       <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,…
## $ Attendance <chr> "61613", "69696", "70591", "70591", "74532", "78282", "5869…
## $ Type       <chr> "home", "away", "home", "away", "home", "away", "away", "ho…
## $ Day        <chr> "Sun", "Thu", "Sun", "Sun", "Sun", "Sun", "Sun", "Sun", "Su…
## $ Date       <dttm> 2018-09-09, 2018-09-06, 2018-09-09, 2018-09-09, 2018-09-09…
## $ Time       <chr> "4:25PM", "8:20PM", "1:00PM", "1:00PM", "4:25PM", "8:20PM",…
## $ Points     <dbl> 6, 12, 47, 3, 16, 23, 34, 21, 8, 27, 17, 24, 20, 23, 20, 38…

Introduction

  • The data set is a list of the attendance numbers for all of the NFL teams in the year 2018. It is the official numbers from the NFL. The index is the Team + Week. The keys are Team, Week, Type, Date, and Points. The forecast variable is Attendance, and the Predictor variables are the team, week, type, day, date, time, and points. We chose this dataset because we are sports fans so this dataset resonates with us, and we can discern information easier. It can be leveraged to decide ticket prices for that game or deals for tickets, or concession supplies needed or gift store supplies needed.

Data Wrangling

  • In order to make the data easier to analyze, we changed them into the right data type:
nfl <- nfl %>%
  mutate(Week = as.integer(Week),
         Attendance = as.numeric(Attendance),
         Team = as.factor(Team))
## Warning: There was 1 warning in `mutate()`.
## ℹ In argument: `Attendance = as.numeric(Attendance)`.
## Caused by warning:
## ! NAs introduced by coercion
  • There are several weeks where the teams don’t have a game scheduled, we will remove them to make the data cleaner:
nfl <- nfl %>%
  filter(Attendance != c("Bye"))
  • To make the dataset more diverse, we will create another variable that showing the date where each week of the season started:
nfl <- nfl %>%
  mutate(week_date = ymd("2018-09-06") + weeks(Week - 1))
  • Lastly, we will create the total number of the attendance for each week for the forecasting that we’re doing:
weekly_attendance <- nfl %>%
  group_by(Week) %>%
  summarise(total_attendance = sum(Attendance)) %>%
  as_tsibble(index = Week)

weekly_attendance

Visualization

Time Series

autoplot(weekly_attendance, total_attendance) +
  labs(title = "Weekly NFL Attendance (2018)",
       x = "Week",
       y = "Total Attendance") +
  theme_minimal()

  • There seems to be a dip in the weekly attendance in the middle of the season but this can be due to bye weeks so less teams are playing.

Detect Anomalies

weekly_attendance %>%
  mutate(z_score = scale(total_attendance)) %>%
  filter(abs(z_score) > 2)  # Threshold for anomaly
## Warning: Using one column matrices in `filter()` was deprecated in dplyr 1.1.0.
## ℹ Please use one dimensional logical vectors instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
  • Using a z-score threshold of ±2 to detect anomalies, Week 11 stood out as the only statistical anomaly in total weekly attendance, with a z-score of -2.23. This suggests a significantly lower-than-average attendance that week, which could be due to factors like weather, team performance, or scheduling.

Autocorrelation Plot (ACF)

weekly_attendance %>%
  ACF(total_attendance) %>%
  autoplot() +
  labs(title = "Autocorrelation of Weekly NFL Attendance")

  • The ACF plot shows statistically significant positive autocorrelation at lags 1 and 2, meaning weekly attendance values are moderately influenced by the attendance of the previous one to two weeks. However, beyond lag 2, the autocorrelations quickly decline and fluctuate around zero, with no indication of strong seasonality. This suggests attendance patterns have short-term momentum but no persistent cyclic trend across the season.

Decompose Trend/Seasonality

# Data Wrangling (Ensure we have individual game attendances per week)
nfl_for_boxplot <- nfl %>%
  mutate(Week = as.integer(Week),
         Attendance = as.numeric(Attendance),
         Team = as.factor(Team)) %>%
  filter(Attendance != "Bye") %>%
  mutate(week_date = ymd("2018-09-06") + weeks(Week - 1))

# Visualization (Plotting the distribution of attendance for each week)
ggplot(nfl_for_boxplot, aes(x = as.factor(Week), y = Attendance)) +
  geom_boxplot(fill = "lightblue") +
  labs(title = "Distribution of Game Attendance by Week (2018)",
       x = "Week",
       y = "Game Attendance") +
  theme_minimal()

  • The boxplot shows that NFL game attendance in 2018 was fairly consistent, with medians around 67,000–72,000 each week. Some weeks had low outliers, likely due to smaller venues or less popular games, while a few had unusually high attendance. No clear trend or seasonality is visible.

Model Fitting

Splitting Data

train <- weekly_attendance %>%
  filter(Week <= 12)

test <- weekly_attendance %>%
  filter(Week > 12)
  • We split the data at Week 12 to retain the last 5 weeks for testing, simulating how a model would perform on unseen late-season games. This allows us to validate the model on a realistic future segment of the season.

Fitting Models

weekly_attendance <- weekly_attendance %>%
  arrange(Week) %>%
  as_tsibble(index = Week)
  • We decided to choose TSLM and ETS to fit to the training data:
fit_tslm <- train %>%
  model(TSLM(total_attendance ~ trend()))

glance(fit_tslm)
fit_ets <- train %>%
  model(ETS(total_attendance))

glance(fit_ets)
bind_rows(
  glance(fit_tslm),
  glance(fit_ets)
) %>%
  select(.model, AICc, BIC)
  • Although both models provide a reasonable fit, TSLM was selected due to its lower AICc value, indicating a better balance between fit and complexity. Residual diagnostics further support the model’s adequacy, with no major patterns or autocorrelation observed:
# Plot residuals
fit_tslm %>% gg_tsresiduals()

  • The residuals over the “season” show non-random fluctuations, indicating potential unaccounted factors influencing attendance week to week. Significant autocorrelation at certain lags implies that attendance in one period is related to previous periods. Finally, the skewed distribution of residuals suggests the model’s error terms aren’t behaving as expected.

Benchmark Method

fit_benchmark <- train %>%
  model(
    Mean = MEAN(total_attendance),
    Naive = NAIVE(total_attendance),
    Drift = RW(total_attendance ~ drift())
  )
forecast(fit_benchmark, h = 5) %>%
  autoplot(train) +
  autolayer(test, total_attendance, color = "black") +
  labs(title = "Benchmark Model Forecasts vs Actual Attendance",
       y = "Total Weekly Attendance",
       x = "Week")

  • The Naive forecast initially aligns best with the actual attendance, but all benchmark models show increasing uncertainty over time and don’t capture the upward trend at the end of the forecast period. This suggests that more sophisticated modeling is needed for better predictions.

Accuracy

fc_tslm <- forecast(fit_tslm, new_data = test)
fc_ets <- forecast(fit_ets, new_data = test)
fc_benchmark <- forecast(fit_benchmark, new_data = test)
# Get accuracy for each model
acc_tslm <- accuracy(fc_tslm, test)
acc_ets <- accuracy(fc_ets, test)
acc_benchmark <- accuracy(fc_benchmark, test)
  • These metrics are commonly used for time series forecasting and offer interpretable insights: RMSE penalizes larger errors, MAE provides a general error magnitude, and MAPE helps understand relative error percentages.
# Combine them into one table
accuracy_results <- bind_rows(acc_tslm, acc_ets, acc_benchmark)

# Show relevant columns, ordered by RMSE
accuracy_results %>%
  select(.model, RMSE, MAE, MAPE) %>%
  arrange(RMSE)
  • The Mean model was selected due to its superior performance on the test set, exhibiting the lowest values for all three accuracy metrics.

Forecast

# Produce a forecast for the future
final_model <- fit_tslm # Replace with your selected final model

future_forecast <- forecast(final_model, h = 5) # Assuming you forecasted 5 weeks
report(final_model)
## Series: total_attendance 
## Model: TSLM 
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -149604  -56261  -35419   65161  177032 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  2187599      64835  33.741 1.24e-11 ***
## trend()       -32970       8809  -3.743  0.00383 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 105300 on 10 degrees of freedom
## Multiple R-squared: 0.5835,  Adjusted R-squared: 0.5418
## F-statistic: 14.01 on 1 and 10 DF, p-value: 0.00383
autoplot(future_forecast, weekly_attendance) +
  autolayer(weekly_attendance, total_attendance, color = "black") +
  labs(title = paste("Forecast of Weekly NFL Attendance Last", length(future_forecast$Week), "Weeks"),
       y = "Total Weekly Attendance",
       x = "Week") +
  theme_minimal()

future_forecast
  • We forecasted 5 weeks into the future to simulate the NFL playoffs or preseason scenarios. This length provides insight into near-future trends while maintaining model reliability. We did it because short-term forecasts help NFL teams, broadcasters, and vendors make staffing, marketing, and operational decisions. Some Considerations or Watchouts are Forecasts are based on regular season data only; special events (e.g., playoffs, holidays, weather, rivalries) are not explicitly modeled, which could impact accuracy.