library(tidyverse)
library(broom)
library(knitr)
library(lattice)
library(ggplot2)
library(readr)

options(scipen = 999)

This lab explores the Los Angeles Dodgers attendance dataset and builds a marketing response model. The primary question is whether promotions, especially bobbleheads and fireworks, help explain game attendance. The report contains exploratory data analysis, visualizations, regression models and a prediction for a July Saturday game without a promotion.

Loading Data

DodgersData <- read_csv("https://raw.githubusercontent.com/mtpa/mds/refs/heads/master/MDS_Chapter_8/dodgers.csv")

head(DodgersData)
## # A tibble: 6 × 12
##   month   day attend day_of_week opponent  temp skies  day_night cap   shirt
##   <chr> <dbl>  <dbl> <chr>       <chr>    <dbl> <chr>  <chr>     <chr> <chr>
## 1 APR      10  56000 Tuesday     Pirates     67 Clear  Day       NO    NO   
## 2 APR      11  29729 Wednesday   Pirates     58 Cloudy Night     NO    NO   
## 3 APR      12  28328 Thursday    Pirates     57 Cloudy Night     NO    NO   
## 4 APR      13  31601 Friday      Padres      54 Cloudy Night     NO    NO   
## 5 APR      14  46549 Saturday    Padres      57 Cloudy Night     NO    NO   
## 6 APR      15  38359 Sunday      Padres      65 Clear  Day       NO    NO   
## # ℹ 2 more variables: fireworks <chr>, bobblehead <chr>
str(DodgersData)
## spc_tbl_ [81 × 12] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ month      : chr [1:81] "APR" "APR" "APR" "APR" ...
##  $ day        : num [1:81] 10 11 12 13 14 15 23 24 25 27 ...
##  $ attend     : num [1:81] 56000 29729 28328 31601 46549 ...
##  $ day_of_week: chr [1:81] "Tuesday" "Wednesday" "Thursday" "Friday" ...
##  $ opponent   : chr [1:81] "Pirates" "Pirates" "Pirates" "Padres" ...
##  $ temp       : num [1:81] 67 58 57 54 57 65 60 63 64 66 ...
##  $ skies      : chr [1:81] "Clear" "Cloudy" "Cloudy" "Cloudy" ...
##  $ day_night  : chr [1:81] "Day" "Night" "Night" "Night" ...
##  $ cap        : chr [1:81] "NO" "NO" "NO" "NO" ...
##  $ shirt      : chr [1:81] "NO" "NO" "NO" "NO" ...
##  $ fireworks  : chr [1:81] "NO" "NO" "NO" "YES" ...
##  $ bobblehead : chr [1:81] "NO" "NO" "NO" "NO" ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   month = col_character(),
##   ..   day = col_double(),
##   ..   attend = col_double(),
##   ..   day_of_week = col_character(),
##   ..   opponent = col_character(),
##   ..   temp = col_double(),
##   ..   skies = col_character(),
##   ..   day_night = col_character(),
##   ..   cap = col_character(),
##   ..   shirt = col_character(),
##   ..   fireworks = col_character(),
##   ..   bobblehead = col_character()
##   .. )
##  - attr(*, "problems")=<externalptr>
glimpse(DodgersData)
## Rows: 81
## Columns: 12
## $ month       <chr> "APR", "APR", "APR", "APR", "APR", "APR", "APR", "APR", "A…
## $ day         <dbl> 10, 11, 12, 13, 14, 15, 23, 24, 25, 27, 28, 29, 7, 8, 9, 1…
## $ attend      <dbl> 56000, 29729, 28328, 31601, 46549, 38359, 26376, 44014, 26…
## $ day_of_week <chr> "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", …
## $ opponent    <chr> "Pirates", "Pirates", "Pirates", "Padres", "Padres", "Padr…
## $ temp        <dbl> 67, 58, 57, 54, 57, 65, 60, 63, 64, 66, 71, 74, 67, 75, 71…
## $ skies       <chr> "Clear", "Cloudy", "Cloudy", "Cloudy", "Cloudy", "Clear", …
## $ day_night   <chr> "Day", "Night", "Night", "Night", "Night", "Day", "Night",…
## $ cap         <chr> "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO"…
## $ shirt       <chr> "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO"…
## $ fireworks   <chr> "NO", "NO", "NO", "YES", "NO", "NO", "NO", "NO", "NO", "YE…
## $ bobblehead  <chr> "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO", "NO"…

The Dodgers dataset includes game attendance, month, day of the week, opponent, temperature, weather, day or night game, and promotional variables.

Data Cleanup and Exploratory Analysis

The month and day of week variables need to be converted into factors. This helps R understand that they are categories instead of regular text.

DodgersData$day_of_week <- factor(DodgersData$day_of_week)
DodgersData$month <- factor(DodgersData$month)

levels(DodgersData$day_of_week)
## [1] "Friday"    "Monday"    "Saturday"  "Sunday"    "Thursday"  "Tuesday"  
## [7] "Wednesday"
levels(DodgersData$month)
## [1] "APR" "AUG" "JUL" "JUN" "MAY" "OCT" "SEP"
head(DodgersData, 10)
## # A tibble: 10 × 12
##    month   day attend day_of_week opponent   temp skies  day_night cap   shirt
##    <fct> <dbl>  <dbl> <fct>       <chr>     <dbl> <chr>  <chr>     <chr> <chr>
##  1 APR      10  56000 Tuesday     Pirates      67 Clear  Day       NO    NO   
##  2 APR      11  29729 Wednesday   Pirates      58 Cloudy Night     NO    NO   
##  3 APR      12  28328 Thursday    Pirates      57 Cloudy Night     NO    NO   
##  4 APR      13  31601 Friday      Padres       54 Cloudy Night     NO    NO   
##  5 APR      14  46549 Saturday    Padres       57 Cloudy Night     NO    NO   
##  6 APR      15  38359 Sunday      Padres       65 Clear  Day       NO    NO   
##  7 APR      23  26376 Monday      Braves       60 Cloudy Night     NO    NO   
##  8 APR      24  44014 Tuesday     Braves       63 Cloudy Night     NO    NO   
##  9 APR      25  26345 Wednesday   Braves       64 Cloudy Night     NO    NO   
## 10 APR      27  44807 Friday      Nationals    66 Clear  Night     NO    NO   
## # ℹ 2 more variables: fireworks <chr>, bobblehead <chr>

Information for the 20th Home Game

DodgersData[20, c("temp", "attend", "opponent", "bobblehead")]
## # A tibble: 1 × 4
##    temp attend opponent bobblehead
##   <dbl>  <dbl> <chr>    <chr>     
## 1    70  47077 Snakes   YES

Average Attendance

meanattend <- mean(DodgersData$attend)
meanattend
## [1] 41040.07

Number of Bobblehead Promotions

promotions <- sum(DodgersData$bobblehead == "YES")
promotions
## [1] 11

EDA Summary

For EDA, I created a separate dataset called EDAdata. This lets me convert YES/NO promotion columns into 1/0 values for easier counting.

EDAdata <- DodgersData

EDAdata$cap <- ifelse(EDAdata$cap == "YES", 1, 0)
EDAdata$shirt <- ifelse(EDAdata$shirt == "YES", 1, 0)
EDAdata$fireworks <- ifelse(EDAdata$fireworks == "YES", 1, 0)
EDAdata$bobblehead <- ifelse(EDAdata$bobblehead == "YES", 1, 0)

Count Each Promotion Type

promotion_counts <- colSums(EDAdata[, c("cap", "shirt", "fireworks", "bobblehead")])
promotion_counts
##        cap      shirt  fireworks bobblehead 
##          2          3         14         11

Count Games by Month

table(DodgersData$month)
## 
## APR AUG JUL JUN MAY OCT SEP 
##  12  15  12   9  18   3  12

Count Games by Day of Week

table(DodgersData$day_of_week)
## 
##    Friday    Monday  Saturday    Sunday  Thursday   Tuesday Wednesday 
##        13        12        13        13         5        13        12

Attendance Distribution

summary(EDAdata$attend)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   24312   34493   40284   41040   46588   56000
max(EDAdata$attend)
## [1] 56000
sum(EDAdata$attend >= 56000)
## [1] 2

This summary shows the overall attendance range for the Dodgers games. It also checks how many games reached at least 56,000 fans, which is close to a full stadium.

Number of Bobblehead Promotions on Tuesday Nights

sum(EDAdata$bobblehead == 1 &
      EDAdata$day_of_week == "Tuesday" &
      EDAdata$day_night == "Night")
## [1] 6

Exploratory Analysis

The results show that the dataset includes several types of promotions, including caps, shirts, fireworks, and bobbleheads. Cap and shirt promotions appear less often, so they may not be as useful for modeling. Fireworks and bobblehead promotions happen more often, so they are better variables to test in the regression model.

EDA Plot 1: Attendance by Weather

ggplot(DodgersData, aes(x = temp, y = attend / 1000, color = fireworks)) +
  geom_point(size = 2) +
  facet_wrap(day_night ~ skies) +
  ggtitle("Dodgers Attendance By Temperature, Time of Game, and Skies") +
  theme(plot.title = element_text(lineheight = 3, face = "bold", color = "black", size = 10)) +
  xlab("Temperature (Degrees Fahrenheit)") +
  ylab("Attendance (Thousands)")

This plot compares attendance by temperature, weather, time of game, and fireworks promotion. It helps show whether hotter or clearer games had different attendance patterns.

EDA Plot 2: Attendance by Opponent

ggplot(DodgersData, aes(x = attend / 1000, y = opponent, color = day_night)) +
  geom_point(size = 2) +
  ggtitle("Dodgers Attendance By Opponent") +
  theme(plot.title = element_text(lineheight = 3, face = "bold", color = "black", size = 10)) +
  xlab("Attendance (Thousands)") +
  ylab("Opponent / Visiting Team")

This strip plot shows attendance by opponent. Some opponents may attract larger crowds than others, and this may also depend on whether the game was played during the day or night.

Extra EDA: Attendance by Month

ggplot(DodgersData, aes(x = month, y = attend)) +
  geom_boxplot() +
  labs(
    title = "Dodgers Attendance by Month",
    x = "Month",
    y = "Attendance"
  )

Extra EDA: Attendance by Day of Week

ggplot(DodgersData, aes(x = day_of_week, y = attend)) +
  geom_boxplot() +
  labs(
    title = "Dodgers Attendance by Day of Week",
    x = "Day of Week",
    y = "Attendance"
  ) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

Design Predictive Model - Original Model

To advise management if promotions impact attendance, I first created a model using month, day of week, and bobblehead promotion.

my.model <- attend ~ month + day_of_week + bobblehead

my.model.fit <- lm(my.model, data = DodgersData)

print(summary(my.model.fit))
## 
## Call:
## lm(formula = my.model, data = DodgersData)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -10786.5  -3628.1   -516.1   2230.2  14351.0 
## 
## Coefficients:
##                      Estimate Std. Error t value             Pr(>|t|)    
## (Intercept)          38792.98    2364.68  16.405 < 0.0000000000000002 ***
## monthAUG              2377.92    2402.91   0.990               0.3259    
## monthJUL              2849.83    2578.60   1.105               0.2730    
## monthJUN              7163.23    2732.72   2.621               0.0108 *  
## monthMAY             -2385.62    2291.22  -1.041               0.3015    
## monthOCT              -662.67    4046.45  -0.164               0.8704    
## monthSEP                29.03    2521.25   0.012               0.9908    
## day_of_weekMonday    -4883.82    2504.65  -1.950               0.0554 .  
## day_of_weekSaturday   1488.24    2442.68   0.609               0.5444    
## day_of_weekSunday     1840.18    2426.79   0.758               0.4509    
## day_of_weekThursday  -4108.45    3381.22  -1.215               0.2286    
## day_of_weekTuesday    3027.68    2686.43   1.127               0.2638    
## day_of_weekWednesday -2423.80    2485.46  -0.975               0.3330    
## bobbleheadYES        10714.90    2419.52   4.429            0.0000359 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 6120 on 67 degrees of freedom
## Multiple R-squared:  0.5444, Adjusted R-squared:  0.456 
## F-statistic: 6.158 on 13 and 67 DF,  p-value: 0.0000002083

The bobblehead coefficient is the main promotion variable in this model. If the coefficient is positive, then bobblehead games are associated with higher attendance compared with games that did not have bobbleheads.

Re-Level Factors for Interpretability

DodgersData$month <- factor(
  DodgersData$month,
  levels = c("APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT")
)

DodgersData$day_of_week <- factor(
  DodgersData$day_of_week,
  levels = c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
)

levels(DodgersData$month)
## [1] "APR" "MAY" "JUN" "JUL" "AUG" "SEP" "OCT"
levels(DodgersData$day_of_week)
## [1] "Monday"    "Tuesday"   "Wednesday" "Thursday"  "Friday"    "Saturday" 
## [7] "Sunday"

Required Model After Re-Leveling

my.model2 <- attend ~ month + day_of_week + bobblehead

my.model.fit2 <- lm(my.model2, data = DodgersData)

print(summary(my.model.fit2))
## 
## Call:
## lm(formula = my.model2, data = DodgersData)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -10786.5  -3628.1   -516.1   2230.2  14351.0 
## 
## Coefficients:
##                      Estimate Std. Error t value             Pr(>|t|)    
## (Intercept)          33909.16    2521.81  13.446 < 0.0000000000000002 ***
## monthMAY             -2385.62    2291.22  -1.041              0.30152    
## monthJUN              7163.23    2732.72   2.621              0.01083 *  
## monthJUL              2849.83    2578.60   1.105              0.27303    
## monthAUG              2377.92    2402.91   0.990              0.32593    
## monthSEP                29.03    2521.25   0.012              0.99085    
## monthOCT              -662.67    4046.45  -0.164              0.87041    
## day_of_weekTuesday    7911.49    2702.21   2.928              0.00466 ** 
## day_of_weekWednesday  2460.02    2514.03   0.979              0.33134    
## day_of_weekThursday    775.36    3486.15   0.222              0.82467    
## day_of_weekFriday     4883.82    2504.65   1.950              0.05537 .  
## day_of_weekSaturday   6372.06    2552.08   2.497              0.01500 *  
## day_of_weekSunday     6724.00    2506.72   2.682              0.00920 ** 
## bobbleheadYES        10714.90    2419.52   4.429            0.0000359 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 6120 on 67 degrees of freedom
## Multiple R-squared:  0.5444, Adjusted R-squared:  0.456 
## F-statistic: 6.158 on 13 and 67 DF,  p-value: 0.0000002083

Clean Model Table

tidy(my.model.fit2) %>%
  kable(
    caption = "Model 1: Attendance Predicted by Month, Day of Week, and Bobblehead",
    digits = 3
  )
Model 1: Attendance Predicted by Month, Day of Week, and Bobblehead
term estimate std.error statistic p.value
(Intercept) 33909.162 2521.806 13.446 0.000
monthMAY -2385.625 2291.216 -1.041 0.302
monthJUN 7163.234 2732.721 2.621 0.011
monthJUL 2849.828 2578.600 1.105 0.273
monthAUG 2377.924 2402.915 0.990 0.326
monthSEP 29.030 2521.249 0.012 0.991
monthOCT -662.668 4046.452 -0.164 0.870
day_of_weekTuesday 7911.494 2702.208 2.928 0.005
day_of_weekWednesday 2460.023 2514.029 0.979 0.331
day_of_weekThursday 775.364 3486.154 0.222 0.825
day_of_weekFriday 4883.818 2504.653 1.950 0.055
day_of_weekSaturday 6372.056 2552.084 2.497 0.015
day_of_weekSunday 6724.003 2506.721 2.682 0.009
bobbleheadYES 10714.903 2419.520 4.429 0.000

Model Fit Statistics

glance(my.model.fit2) %>%
  select(r.squared, adj.r.squared, sigma, statistic, p.value, AIC, BIC) %>%
  kable(
    caption = "Model 1 Fit Statistics",
    digits = 3
  )
Model 1 Fit Statistics
r.squared adj.r.squared sigma statistic p.value AIC BIC
0.544 0.456 6120.158 6.158 0 1657.031 1692.948

Fireworks as a Second Promotion Variable

I added fireworks to the model to see if it improves the prediction of attendance as a secondary promotional variable.

my.model3 <- attend ~ month + day_of_week + fireworks + bobblehead

my.model.fit3 <- lm(my.model3, data = DodgersData)

print(summary(my.model.fit3))
## 
## Call:
## lm(formula = my.model3, data = DodgersData)
## 
## Residuals:
##    Min     1Q Median     3Q    Max 
##  -9504  -3683   -709   2569  15390 
## 
## Coefficients:
##                       Estimate Std. Error t value             Pr(>|t|)    
## (Intercept)           34321.68    2418.90  14.189 < 0.0000000000000002 ***
## monthMAY              -2492.79    2193.60  -1.136              0.25990    
## monthJUN               7062.62    2616.13   2.700              0.00881 ** 
## monthJUL               1315.38    2534.42   0.519              0.60549    
## monthAUG               2377.88    2300.15   1.034              0.30501    
## monthSEP                -55.37    2413.63  -0.023              0.98177    
## monthOCT               -502.88    3873.86  -0.130              0.89711    
## day_of_weekTuesday     7750.46    2587.35   2.996              0.00386 ** 
## day_of_weekWednesday    904.16    2476.14   0.365              0.71617    
## day_of_weekThursday     309.24    3341.63   0.093              0.92655    
## day_of_weekFriday    -12386.23    6901.86  -1.795              0.07729 .  
## day_of_weekSaturday    6094.17    2445.16   2.492              0.01521 *  
## day_of_weekSunday      6577.96    2400.14   2.741              0.00788 ** 
## fireworksYES          17028.78    6381.63   2.668              0.00958 ** 
## bobbleheadYES         10995.05    2318.43   4.742            0.0000117 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 5858 on 66 degrees of freedom
## Multiple R-squared:  0.5887, Adjusted R-squared:  0.5015 
## F-statistic: 6.749 on 14 and 66 DF,  p-value: 0.00000002848

Clean Fireworks Model Table

tidy(my.model.fit3) %>%
  kable(
    caption = "Model 2: Attendance Predicted by Month, Day of Week, Fireworks, and Bobblehead",
    digits = 3
  )
Model 2: Attendance Predicted by Month, Day of Week, Fireworks, and Bobblehead
term estimate std.error statistic p.value
(Intercept) 34321.675 2418.904 14.189 0.000
monthMAY -2492.791 2193.598 -1.136 0.260
monthJUN 7062.618 2616.126 2.700 0.009
monthJUL 1315.384 2534.422 0.519 0.605
monthAUG 2377.877 2300.152 1.034 0.305
monthSEP -55.371 2413.633 -0.023 0.982
monthOCT -502.883 3873.864 -0.130 0.897
day_of_weekTuesday 7750.462 2587.349 2.996 0.004
day_of_weekWednesday 904.161 2476.142 0.365 0.716
day_of_weekThursday 309.237 3341.635 0.093 0.927
day_of_weekFriday -12386.234 6901.856 -1.795 0.077
day_of_weekSaturday 6094.171 2445.160 2.492 0.015
day_of_weekSunday 6577.963 2400.143 2.741 0.008
fireworksYES 17028.779 6381.631 2.668 0.010
bobbleheadYES 10995.053 2318.426 4.742 0.000

Fireworks Coefficient

tidy(my.model.fit3) %>%
  filter(term == "fireworksYES") %>%
  kable(
    caption = "Fireworks Coefficient",
    digits = 3
  )
Fireworks Coefficient
term estimate std.error statistic p.value
fireworksYES 17028.78 6381.631 2.668 0.01

If the fireworks estimate is positive, fireworks games are associated with higher attendance. If the p-value is high, fireworks does not appear to have a strong statistical effect after controlling for month, day of week, and bobblehead promotions.

Compare the Models

model_comparison <- bind_rows(
  glance(my.model.fit2) %>% mutate(model = "Model 1: Month + Day + Bobblehead"),
  glance(my.model.fit3) %>% mutate(model = "Model 2: Added Fireworks")
) %>%
  select(model, r.squared, adj.r.squared, AIC, BIC, p.value)

model_comparison %>%
  kable(
    caption = "Model Comparison",
    digits = 3
  )
Model Comparison
model r.squared adj.r.squared AIC BIC p.value
Model 1: Month + Day + Bobblehead 0.544 0.456 1657.031 1692.948 0
Model 2: Added Fireworks 0.589 0.502 1650.733 1689.044 0 
anova(my.model.fit2, my.model.fit3)
## Analysis of Variance Table
## 
## Model 1: attend ~ month + day_of_week + bobblehead
## Model 2: attend ~ month + day_of_week + fireworks + bobblehead
##   Res.Df        RSS Df Sum of Sq      F   Pr(>F)   
## 1     67 2509574563                                
## 2     66 2265194779  1 244379784 7.1204 0.009581 **
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

The model comparison helps decide whether fireworks improves the model. If adjusted R-squared improves and the fireworks p-value is low, then fireworks matters. If adjusted R-squared does not improve and the p-value is high, then fireworks does not add much value.

Predicted Attendance for a Saturday Afternoon in July With No Promotion

Predicted attendance for a Saturday afternoon in July with no promotion.

new_no <- data.frame(
  month = factor("JUL", levels = levels(DodgersData$month)),
  day_of_week = factor("Saturday", levels = levels(DodgersData$day_of_week)),
  bobblehead = factor("NO", levels = c("NO", "YES"))
)

pred_no <- predict(
  my.model.fit2,
  newdata = new_no,
  interval = "prediction"
)

pred_no
##        fit      lwr      upr
## 1 43131.05 29866.75 56395.35
cat("Predicted attendance with no promotion:", round(pred_no[1]), "\n")
## Predicted attendance with no promotion: 43131

Business Recommendation

The regression results indicate a positive relationship between Dodgers attendance and bobblehead promotions. Fireworks should be thought of as useful only when they have a low p-value, and they improve the model after inclusion. For business, the Dodgers should target their promotions on games that are expected to be weaker attended, as opposed to only doing promotions on games that are expected to sell well.

References

Los Angeles Dodgers attendance dataset from the MDS Chapter 8 GitHub repository:
https://github.com/mtpa/mds/tree/master/MDS_Chapter_8

R Documentation for Linear Models:
https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/lm

Tidyverse Documentation:
https://www.tidyverse.org/