Option 1

Create a set of four graphs. This must include: • 1- Base R graph • 1- ggplot graph • At least one of either: 1- trelliscope graph or 1- plotly graph. Each graph should include at least two variables. So, a single histogram, box plot, density plot, etc. will not be sufficient.

You will create these graphs in an Rmarkdown document. For each graph you must have a clear statement of what you are trying to investigate in the data. Discuss how your choice of graph will help in this investigation. This should be given in the document before each graph.

After each graph, you must include at least a 1-paragraph discussion. This should discuss any trends, insights, conclusions, etc. that you gained from your graph. That is, you should address your investigation statement and what you gained from the graph to answer it.

Complete the above in an Rmarkdown document and knit it to an html file. Your html page should include a title and your name. Publish this to an RPubs page.

Libraries

library(nflreadr)
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.0     ✔ 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(nflplotR)
library(ggplot2)
library(plotly)
## 
## Attaching package: 'plotly'
## 
## The following object is masked from 'package:ggplot2':
## 
##     last_plot
## 
## The following object is masked from 'package:stats':
## 
##     filter
## 
## The following object is masked from 'package:graphics':
## 
##     layout
library(trelliscopejs)

Read in the data

season_rec <- load_pfr_advstats(stat_type = "rec", summary_level = "season")

Filter data

# Choose only primary pass catchers (running backs, wide receivers, and tight ends)
season_rec <- season_rec %>% 
  filter(pos %in% c("RB", "WR", "TE"))

# summary of stats played to find "qualified" players
summary(season_rec$tgt)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    1.00    8.00   24.00   38.81   58.75  181.00
# filter by qualified players
season_rec_q <- season_rec %>% 
  filter(tgt >= 8) %>% 
  mutate(firstDown = x1d) %>% 
  select(-c(x1d, loaded))

# table of positions
table(season_rec_q$pos)
## 
##  RB  TE  WR 
##  80  83 169

Base R Graph

Investigation

I am investigating the distributions of the number of receptions by each primary receiving position (RB, WR, TE). A boxplot is the ideal graph because it shows all three boxplots on the same plot. A histogram requires three separate histograms for each level, which is more difficult to compare.

boxplot(rec ~ pos, data = season_rec_q, horizontal = TRUE,
        xlab = "Receptions",
        ylab = "Position",
        main = "Receptions by Position",
        col = c("#D3BC8D", "#E31837", "#869397"),
        notch = TRUE)

### Discussion: The shapes of the distributions are a little surprising. I thought wide receivers would have a much higher median number of receptions than tight ends and running backs; however, the median for wide receivers is in the 95% confidence interval for median number of receptions for running backs and and tight ends; therefore, there is not a significant difference in medians between the positions. The reason for this is because there are more than twice as many wide receivers as each tight ends and running backs; therefore, there are more wide receivers who barely qualified in targets who do not have many receptions. For example, a third or fourth wide receiver is more likely to have more targets and receptions than a back-up tight end or running back. A future consideration is to only consider “starters” and check the distributions after that.

ggplot graph

Investigation:

I am investigating the average yards after catch by average receptions by the primary receiving positions (RB, WR, TE). Both statistics are averaged by team and position group. A faceted scatterplot is the best plot to determine if there’s a trend because a regression line can be fit over the data. Also, the facet is an easy way to compare the trends between the positions.

season_rec_q %>% 
  # group by team and position
  group_by(tm, pos) %>% 
  
  # find the average YAC and receptions by the groups
  summarise(
    avg_yac = round(mean(yac), 2),
    avg_rec = round(mean(rec), 2)
  ) %>% 
  
  # reorder position to have the facet graph RB, WR, and TE in that order
  mutate(pos = factor(pos, levels = c("RB", "WR", "TE"))) %>% 
  
  # plot
  ggplot(aes(avg_rec, avg_yac)) +
  
  # NFL logos as points
  geom_nfl_logos(aes(team_abbr = tm), width = 0.10) +
  
  # attempted code that may work with some fixing
  # geom_label(aes(label = tm), nudge_y = -0.35, alpha = 0.5) +
  
  # labels
  labs(x = "Average Receptions",
       y = "Average YAC",
       title = "Average YAC by Average Receptions") + 
  
  # facet by position
  facet_wrap(~ pos) +
  
  # plot a regression line for each position 
  geom_smooth(method = "lm", formula = y ~ x) +
  
  # theme black and white
  theme_bw() +
  
  # center title
  theme(plot.title = element_text(hjust = 0.5))
## `summarise()` has grouped output by 'tm'. You can override using the `.groups`
## argument.

Discussion:

There is a strong, positive linear relationship between average receptions and average yards after catch for each position. The more receptions a player has, the more yards after catch they have, which makes logical sense. However, there are differences between the positions. Running backs have the largest slope of the three groups. Running backs run the shallowest routes and generally have a lower average depth of target than the other positions. Typically, running backs are running screens, swing routes, and other “checkdown” routes that allows them to receive the ball near the line of scrimmage and gain yards after the catch. The trend for wide receivers and tight ends is not surprising; however, there is a major outlier in tight ends. San Francisco 49ers tight end George Kittle is a yards after catch “machine.” He is notorious for shrugging off defenders during his monster runs and his athleticism makes defenders think twice before tackling him; therefore, his “YAC” ability is much greater than typical tight ends.

plotly graph

load data

week_run <- season_rec <- load_pfr_advstats(stat_type = "rush", summary_level = "week")

team colors

### Load team names and colors
team_names <- load_teams()

### Team colors
team_colors_off <- team_names$team_color

plot

Investigation:

I am investigating the rushing yards after contact (rush YAC) by carries grouped by team for each week (1-18). I expect the rush YAC to increase as the carries increase because the defense gets more tired as the team runs more. A plot_ly scatterplot with 18 frames (1 for each week) is the ideal graph because the points will change for each week.

# plot_ly plot
week_run %>% 
  filter(game_type == "REG") %>% 
  group_by(team, week) %>% 
  summarise(
    carries = sum(carries), 
    rush_ybc = sum(rushing_yards_before_contact),
    rush_yac = sum(rushing_yards_after_contact)
  ) %>%
  
  # plot
  plot_ly(x = ~carries, y = ~rush_yac,
          color = ~team,
          colors = team_colors_off,
          hoverinfo = "text",
          text = ~paste0("Team: ", team,
                        "<br>Carries: ", carries,
                        "<br>Rush YAC: ", rush_yac, " yds")) %>% 
  
  # add frame for each week 
  add_markers(frame = ~week,
              size = ~rush_yac) %>% 
  
  # labels
  layout(xaxis = list(title = "Carries"),
         yaxis = list(title = "Rushing Yards After Contact"),
         title = "Rushing Yards After Contact by Carries for Each Week") %>%
  
  # adjust frame time to 4 seconds and transition time to 3 seconds with elastic easing
  animation_opts(frame = 4000, transition = 3000,
                 easing = "elastic") %>% 
  
  # change frame to "Week" and adjust color and size
  animation_slider(currentvalue = list(prefix = "Week: ", 
                                font = list(color = "black", size = 20)))
## `summarise()` has grouped output by 'team'. You can override using the
## `.groups` argument.


Discussion:

There is a positive linear relationship between rushing yards after contact and carries for each week. At a quick glance, it is tough to tell trends for each team throughout the year. However, a noticeable trend is the variability of carries increases throughout the season. At the beginning of the year, teams attempt to have a balanced approach (approximately 50-50 run and pass). NFL teams’ philosophy’s can change throughout the year based on a variety of factors, such as gameplan, weather, overall record, etc. A hypothesis is teams that are in colder climates run more towards the end of the year because it is harder to run a passing offense in the cold (throwing and receiving). One example is the Pittsburgh Steelers’ carries increased throughout the year, and they were routinely in the top 5 in carries the last couple of weeks. However, the Miami Dolphins, were in the bottom half in carries in the last couple weeks, but the fair weather in Miami allowed them to run a strong passing offense. There are a lot of trends that can explored with this graph. I am excited to make similar graphs in the future to explore trends throughout the season.

trelliscope graph

Load in QB Data

qbs_23 <- load_espn_qbr(league = "nfl", summary_type = "weekly")

plot

Investigating:

I am exploring how NFL Quarterbacks’ Total Quarterback Rating changes throughout each week. Trelliscope visualizes the trend for each qualified quarterback. A line plot of Total QBR by Week is the best way to find the trends.

# filter data
qbs_23 %>% 
  filter(qualified == TRUE, season_type == "Regular") %>% 
  mutate(Name = cog(val = name_display, default_label = TRUE),
         Team = cog(val = team, default_label = TRUE)) %>% 
  select(game_week, Name, Team, team_abb, qbr_total, epa_total) %>% 
  group_by(game_week, Name, Team) %>% 
  
  # plot
  ggplot(aes(game_week, qbr_total)) +
  geom_point(aes(color = team_abb), size = 2.5) + 
  scale_color_nfl(type = "primary") +
  geom_line(aes(color = team_abb)) +
  labs(x = "Week", y = "Total QBR") +
  theme_bw() +
  facet_trelliscope(~ Name + Team,
                    name = "QB Stats by Week",
                    nrow = 2, ncol = 3,
                    path = ".",
                    self_contained = TRUE)

Discussion:

The main trend I noticed was a high variance for quarterbacks who were primary starters (roughly started 5 or more games). Throughout the season, quarterbacks are not consistent, regardless of who they are. Josh Allen and Patrick Mahomes are considered some of the best quarterbacks; however, even they lacked consistency. The trend shows the parity in the NFL. Any team can win any game because even the best teams typically lose three to four wins. There are three things I want to explore more: Total QBR in previous seasons (e.g., Tom Brady and Peyton Manning) to see if there was more consistency, possible Time Series models (e.g., Random Walk or ARIMA models to see if models can be made), and compare to NCAA quarterbacks to see if there is more consistency in college since there are undefeated teams.