---
title: "A full analysis on the Men's NCAA Basketball"
author: "Jason Zivkovic"
date: "15/02/2020"
output:
  html_document:
    code_folding: hide
    theme: journal
    highlight: tango
    df_print: paged
    fig_height: 8
    fig_width: 11
    toc: yes
    number_sections: true
---


```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```

# The competition

For the seventh consecutive year running, the collaboration between Google Cloud and the NCAA® brings the Kaggle-backed March Madness® competition. Another year, another chance to anticipate the upsets, call the probabilities, and put your bracketology skills to the leaderboard test. Kagglers will join the millions of fans who attempt to forecast the outcomes of March Madness during this year's NCAA Division I Men’s and Women’s Basketball Championships. 

<br>
<center><img src="https://storage.googleapis.com/kaggle-media/competitions/march-madness-2018/lockup_cloud.png"></center>
<br>


```{r, warning=FALSE, message=FALSE}
library(tidyverse)
library(scales)
library(gridExtra)
library(knitr)
library(ggExtra)

# set up plotting theme
theme_jason <- function(legend_pos="top", base_size=12, font=NA){
  
  # come up with some default text details
  txt <- element_text(size = base_size+3, colour = "black", face = "plain")
  bold_txt <- element_text(size = base_size+3, colour = "black", face = "bold")
  
  # use the theme_minimal() theme as a baseline
  theme_minimal(base_size = base_size, base_family = font)+
    theme(text = txt,
          # axis title and text
          axis.title.x = element_text(size = 15, hjust = 1),
          axis.title.y = element_text(size = 15),
          # gridlines on plot
          panel.grid.major = element_line(linetype = 2),
          panel.grid.minor = element_line(linetype = 2),
          # title and subtitle text
          plot.title = element_text(size = 18, colour = "grey25", face = "bold"),
          plot.subtitle = element_text(size = 16, colour = "grey44"),

          ###### clean up!
          legend.key = element_blank(),
          # the strip.* arguments are for faceted plots
          strip.background = element_blank(),
          strip.text = element_text(face = "bold", size = 13, colour = "grey35")) +

    #----- AXIS -----#
    theme(
      #### remove Tick marks
      axis.ticks=element_blank(),

      ### legend depends on argument in function and no title
      legend.position = legend_pos,
      legend.title = element_blank(),
      legend.background = element_rect(fill = NULL, size = 0.5,linetype = 2)

    )
}


plot_cols <- c("#498972", "#3E8193", "#BC6E2E", "#A09D3C", "#E06E77", "#7589BC", "#A57BAF", "#4D4D4D")
          
```

# Introduction

The analysis contained in the following report will be built upon throughout this competition and will use a number of the different provided data sources, including play by play data, detailed game data, and also the ratings systems of the different experts. 

It will begin by exploring play by play data, specifically the offensive side of the data and visualising how the NCAA is following the NBA and changing the way the game is played.

The analysis with then take a high level view at the NCAA championships - who has won them and how. It will analyse pre-tournament seedings and will also look at some of the data contained in the Massey Ordinal data, specifically Pomeroy and Sagarin rankings, and will try to analyse what a different ranking means to a team's performance.

Then it will move on to analyse the averages per regular season of the teams and then take those season averages of each team and plot their correlation with wins.

The analysis will then included a detailed look at **Advanced Metrics** and analyse their relationship with team performance, both at a per game level, and by taking a look at the overall season performance. It will highlight the performance of the champion team in each season with regards to these metrics. This section will show the importance of some of these advanced metrics, and how they can help explain basketball games better than the traditional box score statistics.

It will continue highlighting the champion team's performance with regards to tradition box score stats for the season.

The analysis will then move on to comparing the differences in team stats between regular season play and tournament play to see whether the tournament games yield a different style of play.

Finally, per game statistics will be analysed for 2015 - 2019 and compared between winning and losing teams, and also looks at if there is a difference between winning and losing in both tournament and regular season games.


I will build upon this kernel throughout the competition. Feel free to add in any suggestions. **If you like the analysis, an upvote would also be greatly appreciated!**

```{r, warning=FALSE, message=FALSE}
reg_season_stats <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MRegularSeasonDetailedResults.csv", stringsAsFactors = FALSE)
tourney_stats <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MNCAATourneyDetailedResults.csv", stringsAsFactors = FALSE)
teams <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MTeams.csv", stringsAsFactors = FALSE)
tourney_stats_compact <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MNCAATourneyCompactResults.csv",stringsAsFactors = FALSE)
tourney_seeds <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MNCAATourneySeeds.csv", stringsAsFactors = FALSE)
team_conferences <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MTeamConferences.csv", stringsAsFactors = FALSE)
conferences <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/Conferences.csv", stringsAsFactors = FALSE)
players <- read.csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MPlayers.csv", stringsAsFactors = FALSE, na.strings=c("","NA")) %>% filter(!is.na(LastName))
```

***

# Play by Play Analysis (2015-19)

```{r, warning=FALSE, message=FALSE}
#~~~~~~~~~~~~~~~~~~~~~~~
# Read in data
#~~~~~~~~~~~~~~~~~~~~~~~
play_by_play <- data.frame()

# loop through each seasons PlayByPlay folders and read in in the play by play files
for(each in list.files("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/")[str_detect(list.files("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/"), "MEvents")]) {
  df <- read_csv(paste0("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/", each))
  
  
  # Grouped shooting variables ----------------------------------------------
  # there are some shooting variables that can probably be condensed - tip ins and dunks
  paint_attempts_made <- c("made2_dunk", "made2_lay", "made2_tip") 
  paint_attempts_missed <- c("miss2_dunk", "miss2_lay", "miss2_tip") 
  paint_attempts <- c(paint_attempts_made, paint_attempts_missed)
  # create variables for field goals made, and also field goals attempted (which includes the sum of FGs made and FGs missed)
  FGM <- c("made2_dunk", "made2_jump", "made2_lay",  "made2_tip",  "made3_jump")
  FGA <- c(FGM, "miss2_dunk", "miss2_jump" ,"miss2_lay",  "miss2_tip",  "miss3_jump")
  # variable for three-pointers
  ThreePointer <- c("made3_jump", "miss3_jump")
  #  Two point jumper
  TwoPointJump <- c("miss2_jump", "made2_jump")
  # Free Throws
  FT <- c("miss1_free", "made1_free")
  # all shots
  AllShots <- c(FGA, FT)
  
  
  # Feature Engineering -----------------------------------------------------
  # paste the two even variables together for FGs as this is the format for last years comp data
  df <- df %>%
    mutate_if(is.factor, as.character) %>% 
    mutate(EventType = ifelse(str_detect(EventType, "miss") | str_detect(EventType, "made") | str_detect(EventType, "reb"), paste0(EventType, "_", EventSubType), EventType))
  
  # change the unknown for 3s to "jump" and for FTs "free"
  df <- df %>% 
    mutate(EventType = ifelse(str_detect(EventType, "3"), str_replace(EventType, "_unk", "_jump"), EventType),
           EventType = ifelse(str_detect(EventType, "1"), str_replace(EventType, "_unk", "_free"), EventType))
  
  
  df <- df %>% 
    # create a variable in the df for whether the attempts was made or missed
    mutate(shot_outcome = ifelse(grepl("made", EventType), "Made", ifelse(grepl("miss", EventType), "Missed", NA))) %>%
    # identify if the action was a field goal, then group it into the attempt types set earlier
    mutate(FGVariable = ifelse(EventType %in% FGA, "Yes", "No"),
           AttemptType = ifelse(EventType %in% paint_attempts, "PaintPoints", 
                                ifelse(EventType %in% ThreePointer, "ThreePointJumper", 
                                       ifelse(EventType %in% TwoPointJump, "TwoPointJumper", 
                                              ifelse(EventType %in% FT, "FreeThrow", "NoAttempt")))))
  
  
  # Rework DF so only shots are included and whatever lead to the shot --------
  df <- df %>% 
    mutate(GameID = paste(Season, DayNum, WTeamID, LTeamID, sep = "_")) %>% 
    group_by(GameID, ElapsedSeconds) %>% 
    mutate(EventType2 = lead(EventType),
           EventPlayerID2 = lead(EventPlayerID)) %>% ungroup()
  
  
  df <- df %>% 
    mutate(FGVariableAny = ifelse(EventType %in% FGA | EventType2 %in% FGA, "Yes", "No")) %>% 
    filter(FGVariableAny == "Yes") 
  
  
  # create a variable for if the shot was made, but then the second event was also a made shot
  df <- df %>% 
    mutate(Alert = ifelse(EventType %in% FGM & EventType2 %in% FGM, "Alert", "OK")) %>% 
    # only keep "OK" observations
    filter(Alert == "OK") 
  # replace NAs with somerhing
  df$EventType2[is.na(df$EventType2)] <- "no_second_event"
  
  
  # create a variable for if there was an assist on the FGM:
  df <- df %>% 
    mutate(AssistedFGM = ifelse(EventType %in% FGM & EventType2 == "assist", "Assisted", 
                                ifelse(EventType %in% FGM & EventType2 != "assist", "Solo", 
                                       ifelse(EventType %in% FGM & EventType2 == "no_second_event", "Solo", "None"))))
  
  # # because the FGA culd be either in `EventType` (more likely) or `EventType2` (less likely), need
  # # one variable to indicate the shot type
  # df <- df %>% \
  #   mutate(fg_type = ifelse(EventType %in% FGA, EventType, ifelse(EventType2 %in% FGA, EventType2, "Unknown")))
  
  # create final output
  df <- df %>% ungroup()
  play_by_play <- bind_rows(play_by_play, df)
  
  rm(df);gc()
}

# saveRDS(play_by_play, "play_by_play2015_19.rds")
```


```{r, warning=FALSE, message=FALSE}
# play_by_play <- readRDS("play_by_play2015_19.rds")
```


There were `r comma(sum(play_by_play$FGVariable[play_by_play$Season == 2019] == "Yes"))` field goals recorded in the data set provided for the 2019 season. Looking at the [NCAA site](https://stats.ncaa.org/rankings/conference_trends), there were actually almost 676K field goal attempts, but the percentages appear very similar, meaning there may be some games missing from our data, either from some of the games collected, or the data didn't satisfy the logic in the cleaning steps above.

## Morey Ball in the College Game?

```{r figurename, echo=FALSE, fig.cap="The game is changing rapidly. Source: Sprawlball, Kirk Goldsberry", out.width = '90%'}
knitr::include_graphics("https://pbs.twimg.com/media/D0hbAcYX0AAWqrQ.jpg")
```


Threes were the most frequent shot types in the game during the period analysed (2015-2019), with `r percent(mean(play_by_play$AttemptType[play_by_play$FGVariable == "Yes"] == "ThreePointJumper"))` of all field goals taken being three pointers. Points in the paint (layups, tip-ins and dunks) closely followed, with `r percent(mean(play_by_play$AttemptType[play_by_play$FGVariable == "Yes"] == "PaintPoints"))` of attempts coming from this valuable area. Two point jumpers made up the remainder, with `r percent(mean(play_by_play$AttemptType[play_by_play$FGVariable == "Yes"] == "TwoPointJumper"))` of the attempts. This was not always the case. if we used data dating from the start of the 2010 season, we would've found that points in the paint were the most frequent, with two pointers also having a greater share.

I might add the additional years in at some stage down the track.


```{r, warning=FALSE, message=FALSE, fig.width=12}
play_by_play %>% 
  group_by(AttemptType) %>% 
  summarise(n_shots = n()) %>% 
  filter(AttemptType != "NoAttempt") %>% 
  ggplot(aes(x= AttemptType, y= n_shots)) +
  geom_col(fill = plot_cols[2], colour = "grey") +
  geom_text(aes(label = comma(n_shots)), y=90000, colour = "black", size = 6) +
  scale_y_continuous(labels = c("0", "300,000", "600,000", "900,000", "1,200,000\nattempts")) +
  coord_flip() +
  ggtitle("MOREY BALL IN THE NCAA", subtitle = "Three pointers have also taken the NCAA by storm") +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank())  
```

It wasn't always the case though. Threes became the most frequent shot attempt only in the 2017 season, with attempts in the paint (lay-ups, dunks and tip-ins) previously the most frequent. Jumpers from inside the two point line have been steadily declining for some time - no doubt the effect of Moreyball.


```{r, warning=FALSE, message=FALSE}
p_tab <- play_by_play %>% 
  filter(AttemptType != "FreeThrow") %>% 
  group_by(AttemptType, Season) %>% 
  summarise(n_shots = n()) %>% 
  filter(AttemptType != "NoAttempt") %>%
  filter(Season == 2019) %>% ungroup()


play_by_play %>% 
  filter(AttemptType != "FreeThrow") %>% 
  group_by(AttemptType, Season) %>% 
  summarise(n_shots = n()) %>% 
  filter(AttemptType != "NoAttempt") %>% 
  ggplot(aes(x= Season, y= n_shots, colour = AttemptType, group = AttemptType)) +
  geom_line(size = 1) +
  geom_point(size = 2) +
  geom_text(data = p_tab, aes(label = AttemptType), hjust= 0, size=6) +
  scale_color_manual(values = plot_cols) +
  scale_x_continuous(labels = c(2015:2020), breaks = c(2015:2020), limits = c(2015, 2022)) +
  scale_y_continuous(labels = c("125,000", "150,000", "175,000", "200,000", "225,000", "250,000 attempts"), breaks = c(seq(from=125000, to= 250000, by= 25000)), limits = c(125000, 250000)) +
  ggtitle("THIS WASN'T ALWAYS THE CASE", subtitle = "Threes became the most popular shot in 2017,\nwhile the gap between threes and twos continues to widen") +
  theme_jason(legend_pos = "none") +
  theme(panel.grid.major.x = element_blank(), panel.grid.minor.x = element_blank(), axis.title.x = element_blank(), axis.title.y = element_blank())

```


## NCAA overall shooting averages

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(FGVariable == "Yes") %>%
  group_by(AttemptType, shot_outcome) %>% 
  summarise(n_attempts = n()) %>% 
  mutate(ShootingPercentage = percent(n_attempts / sum(n_attempts))) %>% 
  filter(shot_outcome == "Made") %>% select(-shot_outcome) %>% DT::datatable()

```

The overall FG% percentage was `r mean(play_by_play$shot_outcome[play_by_play$FGVariable == "Yes"] == "Made") %>% percent()` on `r sum(play_by_play$FGVariable == "Yes") %>% comma()` attempts. When we break this down further, it can be seen that shots in the paint (layups, dunks and tip-ins) were successful on almost 60% over more than 651k attempts, while on two-point jumpers, the percentage fell to 36% on 315k attempts. Suprisingly, tries on threes were only 1.3% less successful than 2-point jumpers, yet the potential payoff is 50% more points for taking the three. That's what the stat heads keep banging on about as the reason for this shift to threes and shots at the rim.


### Expected points

We can measure how many points each shot attempts expected to yield. To do that, I'll extract the elements of the `PaintVariable` and measure their percentages and shot values.

```{r, warning=FALSE, message=FALSE}
shot_values <- play_by_play %>% 
  filter(FGVariable == "Yes") %>% 
  mutate(EventType = str_remove(EventType, "made"), EventType = str_remove(EventType, "miss")) %>% 
  group_by(EventType, shot_outcome) %>% 
  summarise(n_attempts = n()) %>% 
  mutate(ShootingPercentage = n_attempts / sum(n_attempts),
         n_attempts = sum(n_attempts)) %>% 
  filter(shot_outcome == "Made") %>% select(-shot_outcome)

shot_values %>% 
  mutate(n_attempts = comma(n_attempts),
         ShootingPercentage = percent(ShootingPercentage)) %>% 
  rename(`Num Attempts` = n_attempts)%>% DT::datatable()
  

```


Dunks are by far the most efficient shot type, with the league-wide shooting percentage of 89.1%, yielding an expected points of 1.78 (2 points x 0.891) points, while tip-ins are made at a rate of almost 65.7% worth 1.3 points. It's pretty obvious to see why basketball analytics junkies are screaming from the rooftops for players to stop shooting jumpers from inside the three point line - these shot types have an expected points 0.72 points per attempt... considerably less than the expected 1.04 points for threes!

```{r, warning=FALSE, message=FALSE}
shot_values %>% 
  mutate(Point = as.numeric(str_extract(EventType, "[[:digit:]]"))) %>% 
  mutate(ExpectedPoints = ShootingPercentage * Point) %>% 
  ggplot(aes(x=reorder(EventType, ExpectedPoints), y= ExpectedPoints)) +
  geom_col(fill = plot_cols[2], colour = "grey") +
  geom_text(aes(label = round(ExpectedPoints, 2)), vjust =  1.2, colour = "white", size=6) +
  ggtitle("TWO POINT JUMPERS THE LEAST EFFICIENT SHOT TYPE", subtitle = "Dunks yield a massive 1.78 points per attempt,\n2-point jumpers less than half that") +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank(), axis.text.y = element_blank())
```

## Assists vs Solo Attempts

Field goals can be made either assisted, or un-assisted. Players that can create their own shots will usually see their skills transfer somewhat easier in different systems, while players (spot-up shooters) who require a facilitator will usually find their shot success closely tied to their facilitator and system. Lose a good point guard, and a great shooter can come back to the pack fairly quickly. It's the reason why NBA players like Steph Curry and James Harden are so valuable in today's NBA - great offensive players capable of creating for themselves.


It can be seen below that for the 2015 - 2019 Div 1 seasons, just over 17% of threes were un-assisted. Contrast this with two point jumpers, which were un-assisted on 68% of these made attempts. As expected, almost all tip-ins were un-assisted (I don't know how a tip in could be assisted anyway). Dunks and threes were the only sjot attempt types that were below the overall proportion of shot attempts being unassisted.

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(AssistedFGM != "None", shot_outcome == "Made") %>% 
  group_by(EventType, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>% 
  ggplot(aes(x=EventType, y= perc, fill = AssistedFGM)) +
  geom_hline(yintercept = mean(play_by_play$AssistedFGM[play_by_play$AssistedFGM != "None"] == "Solo"), linetype = 2) +
  geom_col(fill = plot_cols[2], colour = "grey") +
  geom_text(aes(label = ifelse(AssistedFGM == "Solo", percent(perc), "")), hjust = 1.2, colour = "white", size=6) +
  scale_y_continuous(labels = c("0%", "25%", "50%", "75%", "100% solo")) +
  annotate("text", x=5, y= 0.56, label = paste0(percent(mean(play_by_play$AssistedFGM[play_by_play$AssistedFGM != "None"] == "Solo")), " solo\nattempts overall"), size = 6) +
  coord_flip() +
  ggtitle("HERO BALL MORE FREQUENT FOR SOME SHOTS", subtitle = "Solo 2pt jump shots are much more frequent that 3pt jumpers") +
  theme_jason(legend_pos = "none") +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank())

```


Looking at this over time, there appears to be an increasing trend of unassisted jumpers, with two point jump shots and threes increasing over the period analysed. Additionally, all FGs have seen an increase in the proportion of made shots being unassisted leading in to the 2019 season. This appears to have flattened off somewhat though during the 2019 season. It will be interesting to see what happened in this current season.


```{r, warning=FALSE, message=FALSE}
solo_tab <- play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(Season, EventType, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>%
  filter(Season == 2019) %>% ungroup()


play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(Season, EventType, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>% 
  ggplot(aes(x= Season, y= perc, colour = EventType)) +
  geom_line(size= 1) +
  geom_point(size = 2) +
  geom_text(data = solo_tab, aes(label = EventType), hjust= 0, size=6) +
  scale_color_manual(values = plot_cols) +
  scale_x_continuous(labels = c(2015:2020), breaks = c(2015:2020), limits = c(2015, 2022)) +
  scale_y_continuous(labels = c("0%", "10%", "20%", "30%", "40%", "50%", "60%", "70%", "80%", "90%", "100% Solo"),
                     breaks = c(seq(0,1, .1)),
                     limits = c(0,1)) +
  ggtitle("HERE COMES HERO BALL?", subtitle = "Unassisted FGs are on the rise virtually across the board") +
  theme_jason(legend_pos = "none") +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank())
```

## Teamwork, or Going it Alone - A Team Perspective

The average proportion of solo attempts for teams is just under 50%. This follows a normal distribution, with all teams lying between 33% and 58%. 

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(EventTeamID, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>% arrange(desc(perc)) %>%
  ggplot(aes(x= perc)) +
  geom_histogram(fill = plot_cols[2], colour = "grey") +
  scale_x_continuous(labels = c("30%", "40%", "50%", "60% solo", ""), limits = c(0.3, 0.65)) +
  labs(y= "Number of Teams") +
  ggtitle("SOME TEAMS PREFER SOLO, OTHERS ASSISTS", subtitle = "Team solo FG percentages normally distributed") +
  theme_jason() +
  theme(axis.title.x = element_blank())
```


Looking at the teams with the highest proportion of their shots coming off solo attempts, we can see that there aren't many of the traditionally big schools.

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(EventTeamID, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>% ungroup() %>% 
  left_join(teams %>% select(TeamID, TeamName), by = c("EventTeamID" = "TeamID")) %>% arrange(desc(perc)) %>% 
  select(TeamName, PercentSolo = perc) %>% mutate(PercentSolo = percent(PercentSolo)) %>% head(10) %>% DT::datatable()
```


Contrast this with the lowest 10 schools, we have Michigan St and North Carolina on this list, with Michigan State only having 33% of their made shots unassisted.

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(EventTeamID, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>% ungroup() %>% 
  left_join(teams %>% select(TeamID, TeamName), by = c("EventTeamID" = "TeamID")) %>% arrange(perc) %>% 
  select(TeamName, PercentSolo = perc) %>% mutate(PercentSolo = percent(PercentSolo)) %>% head(10) %>% DT::datatable()

```

When we look at this at an individual season basis, it can be seen that there is greater single season variation in the percentage of made FGs being unassisted.

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(Season, EventTeamID, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>% arrange(desc(perc)) %>%
  ggplot(aes(x= perc)) +
  geom_histogram(fill = plot_cols[3], colour = "grey") +
  scale_x_continuous(labels = c("30%", "40%", "50%", "60% solo", ""), limits = c(0.3, 0.65)) +
  labs(y= "Number of Teams") +
  ggtitle("MORE VARIANCE IN INDIVIDUAL SEASONS", subtitle = "Some teams have had greater proportion of FGs\nas solo attempts in individual seasons") +
  annotate("rect", xmin = 0.58, xmax = Inf, ymin = 0, ymax = Inf, fill = plot_cols[1], alpha = 0.3) +
  annotate("rect", xmin = -Inf, xmax = 0.33, ymin = 0, ymax = Inf, fill = plot_cols[1], alpha = 0.3) +
  annotate("text", x=.38, y= 140, label = "Teams in individual seasons\nmore or less than the\noverall totals for 5 seasons", size = 5, colour = "grey40") +
  theme_jason() +
  theme(axis.title.x = element_blank())
```

There were 43 individual team seasons that had over 58.8% of their FGMs unassisted. The teams are listed below. None of the teams listed made particularly deep runs... maybe hero ball and team success doesn't equate at the college level...

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(Season, EventTeamID, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>%
  filter(perc > 0.588) %>% ungroup() %>% 
  left_join(teams %>% select(TeamID, TeamName), by = c("EventTeamID" = "TeamID")) %>% arrange(desc(perc)) %>% 
  select(Season, TeamName, PercentSolo = perc) %>% mutate(PercentSolo = percent(PercentSolo)) %>% DT::datatable()
```

Conversely, there are only six teams that had individual seasons less than the overall lowest percentage of solo FGMs of 33%, and interestingly, three of those were Michigan State under Tom Izzo, including the 2019 team that made it to the Tournament Final Four with the second lowest percentage of solo attempts at 30.61%, and the 2018 team that won their conference regular season title.

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(AssistedFGM != "None") %>% 
  group_by(Season, EventTeamID, AssistedFGM) %>% 
  summarise(n = n()) %>% 
  mutate(perc = n / sum(n)) %>% 
  filter(AssistedFGM == "Solo") %>%
  filter(perc < 0.33) %>% ungroup() %>% 
  left_join(teams %>% select(TeamID, TeamName), by = c("EventTeamID" = "TeamID")) %>% arrange(perc) %>% 
  select(Season, TeamName, PercentSolo = perc) %>% mutate(PercentSolo = percent(PercentSolo)) %>% DT::datatable()
```


## Teamwork, or Going it Alone - A Player Perspective

There are `r comma(play_by_play %>% filter(EventPlayerID == 0 | EventPlayerID2 == 0)  %>% nrow())` records where the `EventPlayerID` is equal to "0"... This is either an error, or a imputed value for missing data. The below player analysis will exclude these records.

```{r, warning=FALSE, message=FALSE}
shot_attempts <- play_by_play %>% 
  filter(EventPlayerID != 0 | EventPlayerID2 != 0) %>% # some strange data - remove these records
  filter(EventPlayerID != "2668") %>% # another strange occurrence...don't know any players named "Dont Use"
  filter(FGVariable == "Yes") %>% 
  group_by(EventPlayerID) %>% 
  summarise(n_attempts = n(),
            n_games = n_distinct(GameID),
            n_seasons = n_distinct(Season)) %>% ungroup() %>%
  mutate(avg_attempts = n_attempts / n_games) %>% 
  arrange(desc(n_attempts)) %>% 
  left_join(players, by = c("EventPlayerID" = "PlayerID")) %>% 
  mutate(TeamID = as.integer(TeamID)) %>% 
  left_join(teams %>% select(TeamID, TeamName), by = "TeamID")
```



On average, players took `r round(mean(shot_attempts$n_attempts))` shots since the 2015 season, with a median of `r round(median(shot_attempts$n_attempts))`. If players started their career in 2015 and stayed the full four years, then they would naturally skew this number up, while *one and dones* would be under-represented.


```{r, warning=FALSE, message=FALSE}
shot_attempts %>%
  ggplot(aes(x= n_attempts)) +
  geom_histogram(fill = plot_cols[2], colour = "grey") +
  geom_vline(xintercept = mean(shot_attempts$n_attempts), linetype = 2) +
  annotate("text", x=450, y= 1300, label = paste0("Average player\ntook ", round(mean(shot_attempts$n_attempts)), " shots"), colour = "grey40", size = 5) +
  labs(x= "Shot Attempts", y= "Number of players") +
  scale_x_continuous(labels = comma) +
  scale_y_continuous(labels = comma) +
  ggtitle("SOME VOLUME SHOOTERS SINCE 2015", subtitle = "One and dones won't have as many attempts a\nfour-year players") +
  theme_jason()
```

The 20 highest shot takers by volume, and by average are both displayed below. It can be seen that the players with the highest total shot numbers are dominated by seniors, with Jermaine Marrow the lone junior on this list. Contrast this with the highest average shot takers; we see underclassmen dominate this list, with a number of these players showing very promising signs in the NBA (Trae Young and All-Star, Kendric Nunn in the rookie of the year discussions, and Markelle Fultz and RJ Barrett showing promise).

Chris Clemons and Jermaine Marrow make the cust on both lists.

```{r, warning=FALSE, message=FALSE}
shot_attempts %>% 
  arrange(desc(n_attempts)) %>% head(20) %>% 
  ggplot(aes(x= reorder(paste0(FirstName, " ", LastName), n_attempts), y= n_attempts)) +
  geom_col(fill = plot_cols[2], colour = "grey") +
  geom_text(aes(label = paste("(", n_seasons, " seasons)")), y=250, colour = "white") +
  ggtitle("20 HIGHEST SHOT TAKERS", subtitle = "All players here bar Jermaine Marrow (3)\nplayed for the full four seasons") +
  labs(y= "Number of attempts") +
  coord_flip() +
  theme_jason() +
  theme(axis.title.y = element_blank())

shot_attempts %>% 
  arrange(desc(avg_attempts)) %>% head(20) %>% 
  ggplot(aes(x= reorder(paste0(FirstName, " ", LastName), avg_attempts), y= avg_attempts)) +
  geom_col(fill = plot_cols[3], colour = "grey") +
  geom_text(aes(label = paste("(", n_seasons, " seasons)")), y=3, colour = "white") +
  ggtitle("20 HIGHEST AVERAGE SHOT TAKERS", subtitle = "Underclassmen dominate this list, with only two\n3 or 4 year players") +
  labs(y= "Average attempts") +
  coord_flip() +
  theme_jason() +
  theme(axis.title.y = element_blank())

```


### What type of shots are they taking?

Looking at the players in the top 20 average FG attempts per game, we can see that ther is some variation in where they're getting the bulk of their shots: 

* Kendrick Nunn, Trae Young and Chris Clemmons (all currently in the NBA) got the majority of their shots from three point territory, as did others
* Markelle Fultz - the other player making a name in the NBA and former number 1 pick - had the majority of his shots come as the *least efficient* type, two-point jumpers... Darryl Morey shudders at the thought!
* RJ Barrett, the Knicks pick in last year's NBA draft had the majority of his shots coming inside the paint


```{r, warning=FALSE, message=FALSE}
top_20_avg_fga <- shot_attempts %>% 
  arrange(desc(avg_attempts)) %>% head(20) %>% pull(EventPlayerID)



# play_by_play %>%
#   filter(EventPlayerID %in% top_20_avg_fga) %>%
#   filter(FGVariable == "Yes") %>%
#   select(EventPlayerID, EventType, shot_outcome, AttemptType, AssistedFGM) %>%
#   left_join(players, by = c("EventPlayerID" = "PlayerID")) %>%
#   group_by(EventPlayerID, FirstName, LastName, AttemptType) %>%
#   summarise(n_attempts = n()) %>%
#   mutate(perc_shots = n_attempts / sum(n_attempts)) %>%  ungroup() %>%
#   ggplot(aes(x= paste0(FirstName, " ", LastName), y= AttemptType)) +
#   geom_point(aes(size = perc_shots), colour = plot_cols[2]) +
#   coord_flip() +
#   theme_jason()

play_by_play %>% 
  filter(EventPlayerID %in% top_20_avg_fga) %>% 
  filter(FGVariable == "Yes") %>% 
  select(GameID, EventPlayerID, EventType, shot_outcome, AttemptType, AssistedFGM) %>% 
  left_join(players, by = c("EventPlayerID" = "PlayerID")) %>% 
  group_by(GameID, EventPlayerID, FirstName, LastName, AttemptType) %>% 
  summarise(n_attempts = n()) %>% 
  mutate(perc_shots = n_attempts / sum(n_attempts)) %>%  ungroup() %>% 
  ggplot(aes(x= AttemptType, y= n_attempts, fill = AttemptType)) +
  geom_boxplot(colour = "grey") + 
  scale_fill_manual(values = plot_cols[c(1,4,5)]) +
  facet_wrap(~ paste0(FirstName, " ", LastName), scales = "free_y") +
  ggtitle("WHERE DO THEIR SHOTS COME FROM?", subtitle = "The per game distribution of shot types the top 20 average\nshot takers take") +
  theme_jason() +
  theme(axis.text.x = element_blank(), axis.title.x = element_blank(), axis.title.y = element_blank())
```

### Unassisted Proportions

We can further break down our shooting analysis for these top-20 shooters and explore how many of their made attempts were created by themselves.

Andre Spight lead the top-20, with 87% of his made attempts coming unassisted. Trae Young was an unstoppable beast even at Oklahoma, with 83% of his made attempts being solo attempts.

At the other end of the spectrum, RJ Barrett and Kendrick Nunn - both drafted lottery picks - came in the lowest of the top 20, with 53% and 48% respectively coming unassisted.

```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(EventPlayerID %in% top_20_avg_fga) %>% 
  filter(FGVariable == "Yes") %>% 
  filter(AssistedFGM != "None") %>% 
  select(GameID, EventPlayerID, EventType, shot_outcome, AttemptType, AssistedFGM) %>% 
  left_join(players, by = c("EventPlayerID" = "PlayerID")) %>% 
  group_by(EventPlayerID, FirstName, LastName, AssistedFGM) %>% 
  summarise(n_attempts = n()) %>% 
  mutate(perc_shots = n_attempts / sum(n_attempts)) %>%  ungroup() %>% 
  filter(AssistedFGM == "Solo") %>% 
  mutate(Trae = EventPlayerID == 8271) %>% 
  ggplot(aes(x= reorder(paste0(FirstName, " ", LastName),perc_shots), y= perc_shots, fill = Trae)) +
  geom_col(colour = plot_cols[8]) + 
  geom_text(aes(label = percent(round(perc_shots, 2))), hjust=1) +
  scale_fill_manual(values = c("lightgrey", plot_cols[1])) +
  scale_y_continuous(limits = c(0,1.1)) +
  annotate("text", x=16, y= .95, label= "Trae had the largest\nproportion of shots\nunassisted of the\nNBA stars", colour=plot_cols[8], size=5) +
  geom_curve(x = 17.5, y = 0.95, xend = 19, yend = 0.83, arrow = arrow(length = unit(0.02, "npc")), curvature = 0.2, colour=plot_cols[8]) +
  annotate("text", x=3, y= 0.75, label= "RJ and Kendrick relied\non others for\ntheir shots", colour=plot_cols[8], size=5) +
  geom_curve(x = 2, y = 0.7, xend = 1.5, yend = 0.55, arrow = arrow(length = unit(0.02, "npc")), curvature = -0.2, colour=plot_cols[8]) +
  coord_flip() +
  ggtitle("UNSTOPPABLE TRAE", subtitle = "The proportion of made FGs that were solo attempts for\nthe top 20 volume shooters") +
  theme_jason(legend_pos = "none") +
  theme(axis.title.y = element_blank(), axis.title.x = element_blank(), axis.text.x = element_blank(), 
        panel.grid.major = element_blank(), panel.grid.minor = element_blank())
```



### Bonus: Ja vs Zion shot types

The two most electrifying NBA rookies this season - Ja Morrant and Zion Williamson - had quite different college careers, both from a hype perspective and also a gameplay perspective. Ja was a drafted sophmore out of Murray State and wasn't uber-hyped coming in to Murray St as Zion Williamson, the consensus number one prospect who landed at Duke and took the world by storm - the annointed next one.

Remembering Morrant played two seasons, it's important to note that his freshman year in 2018 was nowhere near as spectacular. While his shot location was distributed similarly to 2019, his volume was far less, with 277 attempts in 2018 and 468 in 2019.

The below shows the differences in the disposition of the shots they both attempted during the 2019 season.


```{r, warning=FALSE, message=FALSE}
play_by_play %>% 
  filter(Season == 2019) %>% 
  filter(EventPlayerID %in% c(7022, 2825)) %>% 
  filter(FGVariable == "Yes") %>% 
  select(GameID, EventPlayerID, EventType, shot_outcome, AttemptType, AssistedFGM) %>% 
  left_join(players, by = c("EventPlayerID" = "PlayerID")) %>% 
  group_by(GameID, EventPlayerID, FirstName, LastName, AttemptType) %>% 
  summarise(n_attempts = n()) %>% 
  mutate(perc_shots = n_attempts / sum(n_attempts)) %>%  ungroup() %>% 
  ggplot(aes(x= AttemptType, y= n_attempts, fill = AttemptType)) +
  geom_boxplot(colour = "grey") + 
  scale_fill_manual(values = plot_cols[c(1,4,5)]) +
  facet_wrap(~ paste0(FirstName, " ", LastName), scales = "free_y") +
  ggtitle("JA ALSO GETS IN THE PAINT", subtitle = "Both Ja and Zion got the majority of their shots in the paint.\nOnly 2019 season analysed.") +
  theme_jason() +
  theme(axis.text.x = element_blank(), axis.title.x = element_blank(), axis.title.y = element_blank())
```

***

# NCAA Tournament Analysis

The first section of this kernel will explore some high level analysis of the NCAA tournament over the last 34 seasons. Specifically, I will look at the winningest schools and the biggest bridesmaides of the tournament.

Additionally, I will analyse which seed the winner has come from, and which are the winningest conferences.

## Who is the winningest school? Who has been the bridesmaid the most?

Stats don't lie! The major programs certainly fill out the top schools when it comes to championship games, and none more than Duke. Five titles and four runners-up results are the most number of championship games by far. UNC and the Huskies round out the top three titles with four apiece, while Michigan are the biggest bridesmaid.


```{r, , warning=FALSE, message=FALSE}
# Join team names to tourney compact dataset
tourney_stats_compact <- tourney_stats_compact %>%
  left_join(teams, by = c("WTeamID" = "TeamID")) %>%
  left_join(teams, by = c("LTeamID" = "TeamID"))

tourney_stats_compact <- tourney_stats_compact %>%
  rename(WTeamName = TeamName.x,
         LTeamName = TeamName.y)

tourney_stats_compact$season_day <- paste(tourney_stats_compact$Season, tourney_stats_compact$DayNum, sep = "_")


# then create a feature to label the round of the tournament
tourney_stats_compact <- tourney_stats_compact %>%
  mutate(TourneyRound = ifelse(DayNum %in% c(136, 137), "First Round", ifelse(DayNum %in% c(138, 139), "Second Round", ifelse(DayNum %in% c(143, 144), "Sweet 16", ifelse(DayNum %in% c(145, 146), "Elite 8", ifelse(DayNum == 152, "Final Four", "Championship Game")))))) %>%
  mutate(TourneyRound = factor(TourneyRound, levels = c("First Round", "Second Round", "Sweet 16", "Elite 8", "Final Four", "Championship Game")))

ncaa_champs <- tourney_stats_compact %>%
  group_by(Season) %>%
  summarise(max_days = max(DayNum)) %>%
  mutate(season_day = paste(Season, max_days, sep = "_")) %>%
  left_join(tourney_stats_compact, by = "season_day") %>% ungroup() %>%
  select(-Season.y) %>%
  rename(Season = Season.x)

win_plot <- ncaa_champs %>%
  group_by(WTeamName) %>%
  summarise(n = n()) %>%
  ggplot(aes(x=reorder(WTeamName,n), y=n)) +
  geom_bar(stat = "identity", fill = plot_cols[2], color = "grey") +
  labs(title = "NOT HARD TO IDENTIFY POWER SCHOOLS", subtitle = "Most Tourney Wins since 1985") +
  scale_y_continuous(labels = c("0", "1", "2", "3", "4", "5 titles")) +
  coord_flip() +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank())


lose_plot <- ncaa_champs %>%
  group_by(LTeamName) %>%
  summarise(n = n()) %>%
  ggplot(aes(x=reorder(LTeamName, n), y=n)) +
  geom_bar(stat = "identity", fill = plot_cols[3], colour = "grey") +
  labs(title = "", subtitle = "Most Tourney Runner-Ups since 1985") +
  scale_y_continuous(labels = c("0", "1", "2", "3", "4 titles")) +
  coord_flip() +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank())

grid.arrange(win_plot, lose_plot, ncol = 2)

```


## Conferences with the most wins

As expected, the ACC have the most titles with 10, closely followed by the Big East Conference with eight titles.

```{r, warning=FALSE, message=FALSE}
ncaa_champs %>%
  select(Season, TeamID = WTeamID) %>%
  left_join(team_conferences, by = c("Season", "TeamID")) %>%
  left_join(conferences, by = "ConfAbbrev") %>%
  count(Description) %>%
  ggplot(aes(x= reorder(Description, n), y= n)) +
  geom_col(fill = plot_cols[2], color = "grey") +
  geom_text(aes(label = n), hjust = 1, size = 6, color = "white") +
  labs(title = "POWER CONFERENCES LEAD THE WAY", subtitle = "Conferences with the most titles since 1985") +
  coord_flip() +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank(), axis.text.x = element_blank()) 
```


## Seeds with the most titles

Not surprisingly, the one seeds have won 22 titles since 1985 - by far the most common seed to win. The second seed has won on five occasions, while the third seed has won four times. Interestingly, the number 5 seed has not won a tournament in the period analysed. The "seed of death" perhaps.

```{r, warning=FALSE, message=FALSE}
tourney_seeds$Seed <- as.integer(str_extract_all(tourney_seeds$Seed, "[0-9]+"))

ncaa_champs %>%
  select(Season, TeamID = WTeamID) %>%
  left_join(tourney_seeds, by = c("Season", "TeamID")) %>%
  count(Seed, sort = T) %>%
  mutate(Seed = as.character(Seed)) %>%
  ggplot(aes(x= reorder(Seed, n), y= n)) +
  geom_segment(aes(x= Seed, xend = Seed, y= 0, yend = n), color = plot_cols[2], size = 1) +
  geom_point(size = 4, color = plot_cols[3]) +
  scale_y_continuous(labels = c("0", "5", "10", "15", "20 Titles", "")) +
  coord_flip() +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank()) +
  ggtitle("WHERE'S THE FIVE SEED?!", subtitle = "Seeds that have won the most titles")
  
```


## Seeding Performance in the Tourney

We would all assume that a teams seed would have strong predictive power on the results of games, but can we show how accurate this hypothesis has been in the past? I will narrow the analysis from the 2003 season to now.

The higher seed will win at roughly 75% of the time in the first round, while that number will fall to around 70% for both the second roundand Sweet 16. The winning percentage of the higher seed then falls off considerably during the Elite 8 to below 50%. 

The Final Four and Championship game have a higher proportion of games where the same seeds play. Still, the lower ranked team will only win around 20% of the time in the final four, and only approximately 5-10% of championship games.

```{r, warning=FALSE, message=FALSE}
seeds_performance <- tourney_stats_compact %>%
  filter(Season >= 2003) %>%
  left_join(tourney_seeds, by = c("Season", "WTeamID" = "TeamID")) %>%
  left_join(tourney_seeds, by = c("Season", "LTeamID" = "TeamID")) %>%
  rename(WinnerSeed = Seed.x, LoserSeed = Seed.y) %>%
  mutate(winner_higher_seed = ifelse(WinnerSeed < LoserSeed, "Higher Seed Wins", ifelse(LoserSeed < WinnerSeed, "Lower Seed Wins", "Same Seed"))) %>%
  mutate(winner_higher_seed = factor(winner_higher_seed, levels = c("Lower Seed Wins", "Same Seed", "Higher Seed Wins")))



seeds_performance %>%
  ggplot(aes(x=TourneyRound, fill = winner_higher_seed)) +
  geom_bar(stat = "count", position = "fill", color = "grey") +
  scale_fill_manual(values = c(plot_cols[3], "darkgrey", plot_cols[2])) +
  scale_y_continuous(labels = scales::percent) +
  ggtitle("Proportion of games won by Higher Seed since 2003", subtitle = "Final Four and title game have same ranked teams") +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank(), axis.text.x = element_text(angle = 45, vjust = .8, size = 10))
```


Other than the second round of the tournament since the 2003 season, the higher seed has been winning at a lower rate each season for the first four rounds of tournament play.

At no point during the first or second round has the higher seeds all progressed through to the next round. The Sweet 16 had all higher ranked teams win during the 2007 and 2016 seasons, with 2007 also seeing all the highest teams win their Elite 8 games.

```{r, warning=FALSE, message=FALSE}
seeds_performance %>%
  group_by(Season, TourneyRound, winner_higher_seed) %>%
  summarise(n = n()) %>%
  mutate(prop_higher_seed_wins = n / sum(n)) %>%
  filter(winner_higher_seed == "Higher Seed Wins") %>%
  filter(!TourneyRound %in% c("Final Four", "Championship Game")) %>%
  ggplot(aes(x= Season, y= prop_higher_seed_wins, group = TourneyRound)) +
  geom_line(size = 1, color = plot_cols[2]) +
  geom_point(color = plot_cols[2]) +
  ggtitle("HIGHER SEEDS NEVER ALL WON IN FIRST TWO ROUNDS", subtitle = "Higher seeds' winning percentage through the seasons") +
  scale_y_continuous(labels = scales::percent) +
  theme_bw() +
  facet_wrap(~ TourneyRound, ncol = 4) +
  theme_jason() +
  theme(axis.title.y = element_blank(),
        strip.background = element_rect(fill = plot_cols[3]), strip.text = element_text(colour = "white", face = "bold"))
```


***

# Massey Ordinals Rankings

This section will look at the Massey Ordinals data and try to see if this can be used as a potential feature in any predictive model.

The analysis below can be used for any rankings system, however I have selected Ken Pomeroy's and Jeff Sagarin's rankings to use.

Specifically, I want to analyse how often the higher ranked team would win during the tourney. I have selected the last ranking of the season for each team and used this as the team's ranking.

## Rankings and winning percentages?


As can be seen, the better Pomeroy ranked team won on average 71.9% of the time in tourney games during 2003-2019. The 2008 season saw the highest percentage of better ranked teams winning at 81% of games, while 2014 was the worst seasons for better ranked teams, with them winning only 65% of the time.

Sagarin rankings were fairly similar, with an average performance of 71.7%, just below Pomeroy's rankings.

Pomeroy rankings also appeared to have slightly variability than Sagarin's. Sagarin's performance in 2011 (61.9%) and 2014 (63.5%) were the lowest two performance of the two rankings systems since 2003.

```{r, warning=FALSE, message=FALSE}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Pomeroy Rankings
#~~~~~~~~~~~~~~~~~~~~~~~~~~~
massey_pom_end <- read_csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MMasseyOrdinals.csv") %>% # read in data
  filter(SystemName == "POM") %>% # filter out only Pomeroy rankings
  group_by(Season, TeamID) %>%
  filter(RankingDayNum == max(RankingDayNum)) %>% ungroup() %>% # select the latest date of the season
  select(Season, TeamID, OrdinalRank)


rankings_tourney_analysis_pom <- tourney_stats_compact %>%
  filter(Season >= 2003) %>%
  left_join(massey_pom_end, by = c("Season", "WTeamID" = "TeamID")) %>%
  rename(WinnerRank = OrdinalRank) %>%
  left_join(massey_pom_end, by = c("Season", "LTeamID" = "TeamID")) %>%
  rename(LoserRank = OrdinalRank) %>%
  filter(DayNum >= 136) %>%
  # create a feature that classifies whether the winner was higher or lower ranked
  mutate(WinnerHigher_yes_no = ifelse(WinnerRank < LoserRank, "Winner Ranked Better", "Loser Ranked Better")) 


rankings_tourney_summary_pom <- rankings_tourney_analysis_pom %>%
  group_by(Season, WinnerHigher_yes_no) %>%
  summarise(n = n()) %>%
  mutate(prop = round(n / sum(n), 4))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Now Sagarin Rankings
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

massey_sagarin_end <- read_csv("../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MDataFiles_Stage1/MMasseyOrdinals.csv") %>% # read in data
  filter(SystemName == "SAG") %>% # filter out only Sagarin rankings
  group_by(Season, TeamID) %>%
  filter(RankingDayNum == max(RankingDayNum)) %>% ungroup() %>% # select the latest date of the season
  select(Season, TeamID, OrdinalRank)



rankings_tourney_analysis_sag <- tourney_stats_compact %>%
  filter(Season >= 2003) %>%
  left_join(massey_sagarin_end, by = c("Season", "WTeamID" = "TeamID")) %>%
  rename(WinnerRank = OrdinalRank) %>%
  left_join(massey_sagarin_end, by = c("Season", "LTeamID" = "TeamID")) %>%
  rename(LoserRank = OrdinalRank) %>%
  filter(DayNum >= 136) %>%
  # create a feature that classifies whether the winner was higher or lower ranked
  mutate(WinnerHigher_yes_no = ifelse(WinnerRank < LoserRank, "Winner Ranked Better", "Loser Ranked Better")) 


rankings_tourney_summary_sag <- rankings_tourney_analysis_sag %>%
  group_by(Season, WinnerHigher_yes_no) %>%
  summarise(n = n()) %>%
  mutate(prop = round(n / sum(n), 4))


pom <- rankings_tourney_summary_pom %>%
  ggplot(aes(x= factor(Season), y= prop, fill = WinnerHigher_yes_no)) +
  geom_bar(stat = "identity", position = "fill", color = "black") +
  geom_text(data = subset(rankings_tourney_summary_pom, WinnerHigher_yes_no == "Winner Ranked Better"), aes(label = percent(prop)), hjust = 1, colour = "white") +
  scale_fill_manual(values = c("lightgrey", plot_cols[2])) +
  scale_y_continuous(labels = scales::percent) +
  labs(x= "Season") +
  ggtitle("WHICH OF THE BIG STAT HEADS RANKS TEAMS BETTER?", subtitle = "Pomeroy Ranking Performance") +
  coord_flip() +
  theme_jason(legend_pos = "none") +
  theme(axis.title.x = element_blank())


sag <- rankings_tourney_summary_sag %>%
  ggplot(aes(x= factor(Season), y= prop, fill = WinnerHigher_yes_no)) +
  geom_bar(stat = "identity", position = "fill", color = "black") +
  geom_text(data = subset(rankings_tourney_summary_sag, WinnerHigher_yes_no == "Winner Ranked Better"), aes(label = percent(prop)), hjust = 1, colour = "white") +
  scale_fill_manual(values = c("lightgrey", plot_cols[3])) +
  scale_y_continuous(labels = scales::percent) +
  labs(x= "") +
  ggtitle("", subtitle = "Sagarin Ranking Performance") +
  coord_flip() +
  theme_jason(legend_pos = "none") +
  theme(axis.title.x = element_blank())


grid.arrange(pom, sag, ncol = 2)

```



## Rankings as the tourney progresses

The next question is to see whether rankings play a bigger part at different stages of the tournament.

Sagarin rankings appear to be better performing during the first three rounds of the tournament, while Pomeroy rankings perform better during the last three rounds.

It appears as though higher ranked teams win games at a lower rate as the tournament progresses through the stages. Interestingly, the *Elite 8* round sees the Pomeroy higher ranked team only win at just over 50% of the time, while Sagarin higher ranked teams only win at 50% of the time at this stage. 

```{r, warning=FALSE, message=FALSE}
pom <- rankings_tourney_analysis_pom %>%
  ggplot(aes(x= TourneyRound, fill = WinnerHigher_yes_no)) +
  geom_bar(stat = "count", position = "fill", color = "grey") +
  scale_fill_manual(values = c("lightgrey", plot_cols[2])) +
  scale_y_continuous(labels = scales::percent) +
  ggtitle("RATINGS MASTERS PERFORMANCE BY ROUND OF TOURNEY", subtitle = "Pomeroy Ranking Performance") +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank(), axis.text.x = element_text(angle = 45, vjust = .8, size = 10))


sag <- rankings_tourney_analysis_sag %>%
  ggplot(aes(x= TourneyRound, fill = WinnerHigher_yes_no)) +
  geom_bar(stat = "count", position = "fill", color = "black") +
  scale_fill_manual(values = c("lightgrey", plot_cols[3])) +
  scale_y_continuous(labels = scales::percent) +
  ggtitle("", subtitle = "Sagarin Ranking Performance") +
  theme_jason() +
  theme(axis.title.x = element_blank(), axis.title.y = element_blank(), axis.text.x = element_text(angle = 45, vjust = .8, size = 10))


grid.arrange(pom, sag, ncol = 2)

```


It appears as though Pomeroy ratings are a better guide, so from this point on when analysing rankings, I will be refering to **Pomeroy** rankings.

## Rankings and Margins

There is a moderately positive relationship between rankings and the margin suring tourney games. The winning margins tend to get larger as there is a greater discrepancy between the winner's and loser's rankings. Conversely, the upsets (where the winner's ranking is lower than their opponent) tend to be associated with lower margins.

```{r, warning=FALSE, message=FALSE}
rankings_tourney_analysis_pom <- rankings_tourney_analysis_pom %>%
  mutate(RankDiff = LoserRank - WinnerRank,
         Margin = WScore - LScore) 

cor_label <- round(cor(rankings_tourney_analysis_pom$RankDiff, rankings_tourney_analysis_pom$Margin),4)

rankings_tourney_analysis_pom %>%
  ggplot(aes(x= RankDiff, y= Margin)) +
  geom_point(aes(colour = ifelse(RankDiff < 0, "Upset", "Favourite"))) +
  geom_smooth(color = "steelblue", se = FALSE, linetype = 2) +
  annotate("text", label = paste("Correlation: ",cor_label, sep = ""), x= -100, y= 50, fontface = "bold") +
  scale_color_manual(values = c(plot_cols[2], "lightgrey")) +
  labs(x= "Ranking Difference", y= "Winning Margin") +
  ggtitle("THE HIGHER THE RANKING GAP, HIGHER THE MARGIN", subtitle = "There is a relationship between the winning margin and\nranking difference") +
  theme_jason() +
  theme()

```

***



# Averages per season

This analysis now moves on to analysing the average team stats per regular season. The individual team stats were first summarised for each season, and then the average for each season was calculated off this.


## Pre-Processing

I won't go in to the detail of the pre-processing steps I've used. It's outlined in this [kernel](https://www.kaggle.com/jaseziv83/pre-processing-to-get-you-started)

```{r, warning=FALSE, message=FALSE}
## calculate possessions per game statistic: field goal attempts + 0.475 x free throw attempts - offensive rebounds + turnovers

# regular season
reg_season_stats <- reg_season_stats %>%
  mutate(WPoss = WFGA + (WFTA * 0.475) + WTO - WOR,
         LPoss = LFGA + (LFTA * 0.475) + LTO - LOR)


# Tourney
tourney_stats <- tourney_stats %>%
  mutate(WPoss = WFGA + (WFTA * 0.475) + WTO - WOR,
         LPoss = LFGA + (LFTA * 0.475) + LTO - LOR)


#---------- tidy data for regular season totals ----------#

# First I will define a function that will take the detailed results data and reshape it so that it results in a dataframe where 
# each observation is a team for that season and their totals statistics for that season. It will also calculate the statistics allowed
# for the season. This function only requires one parameter to be passed to it: either the regular season or Tourney detailed data.

# IMPORTANT: #
# The data required for this function to work is either the regular season or tourney detailed stats, and the "teams" dataset

reshape_detailed_results <- function(detailed_dataset) {
  
  season_team_stats_tot <- rbind(
    detailed_dataset %>%
      select(Season, DayNum, TeamID=WTeamID, Score=WScore, OScore=LScore, WLoc, NumOT, Poss=WPoss, FGM=WFGM, FGA=WFGA, FGM3=WFGM3,  FGA3=WFGA3, FTM=WFTM, FTA=WFTA, OR=WOR,
             DR=WDR, Ast=WAst, TO=WTO, Stl=WStl, Blk=WBlk, PF=WPF, OPoss=LPoss, OFGM=LFGM, OFGA=LFGA, OFGM3=LFGM3, OFGA3=LFGA3, OFTM=LFTM, OFTA=LFTA, O_OR=LOR, ODR=LDR,
             OAst=LAst, OTO=LTO, OStl=LStl, OBlk=LBlk, OPF=LPF) %>%
      mutate(Winner=1),
    
    detailed_dataset %>%
      select(Season, DayNum, TeamID=LTeamID, Score=LScore, OScore=WScore, WLoc, NumOT, Poss=LPoss, FGM=LFGM, FGA=LFGA, FGM3=LFGM3,  FGA3=LFGA3, FTM=LFTM, FTA=LFTA, OR=LOR,
             DR=LDR, Ast=LAst, TO=LTO, Stl=LStl, Blk=LBlk, PF=LPF, OPoss=WPoss, OFGM=WFGM, OFGA=WFGA, OFGM3=WFGM3, OFGA3=WFGA3, OFTM=WFTM, OFTA=WFTA, O_OR=WOR, ODR=WDR,
             OAst=WAst, OTO=WTO, OStl=WStl, OBlk=WBlk, OPF=WPF) %>%
      mutate(Winner=0)) %>%
    group_by(Season, TeamID) %>%
    summarise(GP = n(),
              wins = sum(Winner),
              TotPoints = sum(Score),
              TotPointsAllow = sum(OScore),
              NumOT = sum(NumOT),
              TotPos = sum(Poss),
              TotFGM = sum(FGM),
              TotFGA = sum(FGA),
              TotFGM3 = sum(FGM3),
              TotFGA3 = sum(FGA3),
              TotFTM = sum(FTM),
              TotFTA = sum(FTA),
              TotOR = sum(OR),
              TotDR = sum(DR),
              TotAst = sum(Ast),
              TotTO = sum(TO),
              TotStl = sum(Stl),
              TotBlk = sum(Blk),
              TotPF = sum(PF),
              TotPossAllow = sum(OPoss),
              TotFGMAllow = sum(OFGM),
              TotFGAAllow = sum(OFGA),
              TotFGM3Allow = sum(OFGM3),
              TotFGA3Allow = sum(OFGA3),
              TotFTMAllow = sum(OFTM),
              TotFTAAllow = sum(OFTA),
              TotORAllow = sum(O_OR),
              TotDRAllow = sum(ODR),
              TotAstAllow = sum(OAst),
              TotTOAllow = sum(OTO),
              TotStlAllow = sum(OStl),
              TotBlkAllow = sum(OBlk),
              TotPFAllow = sum(OPF))
  
}

## Store the results to a dataframe
season_team_stats_tot <- reshape_detailed_results(reg_season_stats)

## calculate win percentage
season_team_stats_tot$WinPerc <- season_team_stats_tot$wins / season_team_stats_tot$GP



#---------- Create a dataframe of season averages for each team ----------#

# Next I will define a function that takes in the totals dataframe from the above function and calculate a season averages dataset.
# this function also only requires one parameter to be passed to it, the totals dataframe.

calculate_detailed_averages <- function(totals_dataframe) {
  
  averages <- totals_dataframe
  
  cols <- names(averages[,c(5:35)])
  
  for (eachcol in cols) {
    averages[,eachcol] <- round(averages[,eachcol] / averages$GP,2)
    
  }
  
  averages <- averages %>%
    rename(AvgPoints = TotPoints, AvgPointsAllow=TotPointsAllow, AvgOT=NumOT, AvgPoss=TotPos, AvgFGM=TotFGM,  AvgFGA=TotFGA, AvgFGM3=TotFGM3, AvgFGA3=TotFGA3, AvgFTM=TotFTM,
           AvgFTA=TotFTA, AvgOR=TotOR, Avg_DR=TotDR, AvgAst=TotAst, AvgTO=TotTO, AvgStl=TotStl, Avg_Blk=TotBlk, AvgPF=TotPF, AvgPossAllow=TotPossAllow, AvgFGMAllow=TotFGMAllow, 
           AvgFGAAllow=TotFGAAllow,  AvgFGM3Allow=TotFGM3Allow, AvgFGA3Allow=TotFGA3Allow,  AvgFTMAllow=TotFTMAllow, AvgFTAAllow=TotFTAAllow, 
           AvgORAllow=TotORAllow, AvgDRAllow=TotDRAllow,  AvgAstAllow=TotAstAllow, AvgTOAllow=TotTOAllow, AvgStlAllow=TotStlAllow,  AvgBlkAllow=TotBlkAllow,
           AvgPFAllow=TotPFAllow) %>%
    mutate(PointsPerPoss = AvgPoints / AvgPoss,
           PointsPerPossAllow = AvgPointsAllow / AvgPossAllow)
  
  return(averages)
  
}


# create an averages dataframe
season_team_stats_averages <- calculate_detailed_averages(season_team_stats_tot)


```

**Points per game**

The average points per game had a decline of over 2 points per game between 2003-2013, to then rebound since then (other than a dip in 2015) to a new high in 2018 of 72.9 points per game. The 2019 season saw a dip again though, to below 72 points per game.

**Possessions per game**

Similarly, the possessions per game follow a similar trend - makes sense as it's pretty hard to score without having the ball. It will be interesting to see if possessions goes up in the 2020 season after the shot clock has been shortened in certain situations.

**Three pointers made and attempted**

It's a fairly well known trend, but the average number of threes attempted and made is steadily increasing. This trend continued in the 2019 season. It will be interesting to see the 2020 data once released, as the NCAA instituted a change this season that pushed the three-point line back to the international distance.

**Average Free Throws made and attempted**

Other than a peak in 2014, the average free throws attempted per season had remained relatively stable up until 2016, where both FTM and FTAs have been decreasing.

**Average Assists**

There was a dip in the average number of assists in 2015, but it too is rebounding, however dropped in 2019.

**Average Defensive Rebounds**

There are on average more defensive rebounds occurring. Probably a result of the increase in field goals attempted.


```{r, warning=FALSE, message=FALSE, fig.width=12, fig.height=9}
a1 <- season_team_stats_averages %>%
  group_by(Season) %>%
  summarise(AvgPoints = mean(AvgPoints)) %>%
  ggplot(aes(x= Season, y= AvgPoints, group = 1)) +
  geom_line(color = plot_cols[2], size = 1) +
  geom_point(size = 2, color = plot_cols[2]) +
  labs(subtitle = "Average Points Per Game reached\na new high in 2018") +
  scale_y_continuous(labels = c("", "68", "70", "72 pts/gm", "")) +
  theme_jason() +
  theme(axis.title.y = element_blank())

a2 <- season_team_stats_averages %>%
  group_by(Season) %>%
  summarise(AvgPoss = mean(AvgPoss)) %>%
  ggplot(aes(x= Season, y= AvgPoss, group = 1)) +
  geom_line(color = plot_cols[2], size = 1) +
  geom_point(size = 2, color = plot_cols[2]) +
  labs(subtitle = "Average Possessions per season\ngoing up") +
  scale_y_continuous(labels = c("66", "67", "68", "69", "70", "71 poss/gm")) +
  theme_jason() +
  theme(axis.title.y = element_blank())

a3 <- season_team_stats_averages %>% ungroup() %>%
  select(Season, AvgFGA3, AvgFGM3) %>%
  gather(key = "Stat", value = "Average", -Season) %>%
  group_by(Season, Stat) %>%
  summarise(Average = mean(Average)) %>%
  ggplot(aes(x= Season, y= Average, group = Stat, colour = Stat)) +
  geom_line(size = 1) +
  geom_point(size = 2) +
  scale_color_manual(values = c(plot_cols[2], plot_cols[3])) +
  labs(subtitle = "Average threes made and attempted\nare increasing") +
  theme_jason() +
  theme(axis.title.y = element_blank())

a4 <- season_team_stats_averages %>% ungroup() %>%
  select(Season, AvgFTA, AvgFTM) %>%
  gather(key = "Stat", value = "Average", -Season) %>%
  group_by(Season, Stat) %>%
  summarise(Average = mean(Average)) %>%
  ggplot(aes(x= Season, y= Average, group = Stat, colour = Stat)) +
  geom_line(size = 1) +
  geom_point(size = 2) +
  scale_color_manual(values = c(plot_cols[2], plot_cols[3])) +
  labs(subtitle = "Free Throws attempted and made\ndecreasing recently") +
  theme_jason() +
  theme(axis.title.y = element_blank())

a5 <- season_team_stats_averages %>%
  group_by(Season) %>%
  summarise(AvgAst = mean(AvgAst)) %>%
  ggplot(aes(x= Season, y= AvgAst, group = 1)) +
  geom_point(size = 2, color = plot_cols[2]) +
  geom_line(color = plot_cols[2], size = 1) +
  labs(subtitle = "Average Assists per season had\na big dip in 2015") +
  scale_y_continuous(labels = c("12.4", "12.8", "13.2", "13.6 ass/gm")) +
  theme_jason() +
  theme(axis.title.y = element_blank())

a6 <- season_team_stats_averages %>% ungroup() %>%
  select(Season, AvgOR, Avg_DR) %>%
  gather(key = "Stat", value = "Average", -Season) %>%
  group_by(Season, Stat) %>%
  summarise(Average = mean(Average)) %>%
  ggplot(aes(x= Season, y= Average, group = Stat, colour = Stat)) +
  geom_line(size = 1) +
  geom_point(size = 2) +
  scale_color_manual(values = c(plot_cols[2], plot_cols[3])) +
  labs(subtitle = "Defensive Rebounds are\nincreasing since 2013") +
  theme_jason() +
  theme(axis.title.y = element_blank())

grid.arrange(a1, a2, a5, a3, a4, a6, ncol = 3)
```


***

# Advanced Stats

In this section, I will analyse the impact of advanced stats on a teams performance.

The first subsection will deal with per-game advanced stats, while the second will look at season-aggregated advanced stats.

As a lot of you are probably aware, since the popularisation of sabermetrics and integration of advanced analytics into other sports, there are better ways of measuring a team's expected success. These per game advanced analytics are displayed below. These metrics all show a considerable difference when comparing wins and losses in regular season play between 2003 and 2018.

The calculations of the displayed advanced stats are as follows:

$$\text{Possessions} \ = \text{ 0.96 x (FGA + Turnovers + (0.475 x FTA) - Offensive Rebounds }$$

$$\text{Offensive Rating} \ = \text{ 100 x (Score / Possessions)}$$

$$\text{Defensive Rating} \ = \text{ 100 x (Opponent's Score / Possessions)}$$

$$\text{Strength of Schedule} \ = \text{ 100 x (Offensive Rating - Defensive Rating)}$$

$$\text{Performance Impact Estimator (PIE)} \ = \text{ Score + FGM + FTM - FGA - FTA + Defensive Rebounds + (0.5 * Offensive Rebounds) + Assists + Steals + (0.5 * Blocks) - PF - Turnovers}$$

$$\text{Team Impact Estimator (TIE)} \ = \text{ PIE / (PIE + Opponent's PIE) }$$

$$\text{Assist ratio} \ = \text{ 100 * Assists / (FGA + (0.475 * FTA) + Asistst + Turnovers))}$$

$$\text{Turnover ratio} \ = \text{ 100 * Turnovers / (FGA + (0.475 * FTA) + Assists + Turnovers)}$$

$$\text{True Shooting %} \ = \text{ 100 * Team Points / (2 * (FGA + (0.475 * FTA)))}$$

$$\text{Effective FG%} \ = \text{ (FGM + 0.5 * Threes Made) / FGA}$$

$$\text{Free Throw rate} \ = \text{ FTA / FGA}$$

$$\text{Offensive Rebound %} \ = \text{ Offensive Rebounds / (Offensive Rebounds + Opponent's Defensive Rebounds)}$$

$$\text{Defensive Rebound %} \ = \text{ Defensive Rebounds / (Defensive Rebounds + Opponent's Offensive Rebounds)}$$

$$\text{Total Rebound %} \ = \text{ (Defensive Rebounds + Offensive Rebounds) / (Defensive Rebounds + Offensive Rebounds + Opponent's Defensive Rebounds + Opponent's Offensive Rebounds)}$$


## Per Game Advanced Stats

```{r}
advanced_stats_per_game <- rbind(
  reg_season_stats %>%
    select(Season, DayNum, TeamID=WTeamID, Score=WScore, OScore=LScore, Poss=WPoss, OPoss=LPoss, WLoc, NumOT, FGM=WFGM, FGA=WFGA, FGM3=WFGM3,  FGA3=WFGA3, FTM=WFTM, FTA=WFTA, OR=WOR, DR=WDR, Ast=WAst, TO=WTO, Stl=WStl, Blk=WBlk, PF=WPF, OFGM=LFGM, OFGA=LFGA, OFGM3=LFGM3, OFGA3=LFGA3, OFTM=LFTM, OFTA=LFTA, O_OR=LOR, ODR=LDR, OAst=LAst, OTO=LTO, OStl=LStl, OBlk=LBlk, OPF=LPF) %>%
    mutate(Winner=1),

  reg_season_stats %>%
    select(Season, DayNum, TeamID=LTeamID, Score=LScore, OScore=WScore, Poss=LPoss, OPoss=WPoss, WLoc, NumOT, FGM=LFGM, FGA=LFGA, FGM3=LFGM3,  FGA3=LFGA3, FTM=LFTM, FTA=LFTA, OR=LOR, DR=LDR, Ast=LAst, TO=LTO, Stl=LStl, Blk=LBlk, PF=LPF, OFGM=WFGM, OFGA=WFGA, OFGM3=WFGM3, OFGA3=WFGA3, OFTM=WFTM, OFTA=WFTA, O_OR=WOR, ODR=WDR, OAst=WAst, OTO=WTO, OStl=WStl, OBlk=WBlk, OPF=WPF) %>%
    mutate(Winner=0)) %>%
  mutate(PtsDiff = Score - OScore)


advanced_stats_per_game <- advanced_stats_per_game %>%
  mutate(OffRtg = 100 * (Score / Poss),
         DefRtg = 100 * (OScore / OPoss),
         SoS = OffRtg - DefRtg,
         Pie = Score + FGM + FTM - FGA - FTA + DR + (0.5 * OR) + Ast + Stl + (0.5 * Blk) - PF - TO,
         OPie = OScore + OFGM + OFTM - OFGA - OFTA + ODR + (0.5 * O_OR) + OAst + OStl + (0.5 * OBlk) - OPF - OTO,
         Tie = Pie / (Pie + OPie) * 100,
         AstRatio = 100 * Ast / (FGA + (0.475 * FTA) + Ast + TO),
         TORatio = 100 * TO / (FGA + (0.475 * FTA) + Ast + TO),
         TSPerc = 100 * Score / (2 * (FGA + (0.475 * FTA))),
         EFGPerc = 100* (FGM + 0.5 * FGM3) / FGA,
         FTRate = FTA / FGA,
         OffRebPerc = OR / (OR + ODR),
         DefRebPerc = DR / (DR + O_OR),
         TotRebPerc = (DR + OR) / (DR + OR + ODR + O_OR)) %>%
  select(Season, DayNum, TeamID, Score, OScore, WLoc, NumOT, Winner, Poss, OffRtg, DefRtg, SoS, Pie, OPie, Tie, AstRatio, TORatio, TSPerc, EFGPerc, FTRate, OffRebPerc, DefRebPerc, TotRebPerc)

```


It is clear to see that there is a relationship between most of the advanced metrics calculated and wins. Higher `Offensive Rating`, `Assist Ratio`, `True Shooting Percentage`, `Effective FG%`, `Free Throw rate`, `Offensive and Defensive Rebounding%` and `Total Rebounding%` all appear to lead to a greater chance of winning, while a lower `Defensive Rating` is also related to wins. The `Strength of Schedule` and `Team Impact Estimator` metrics appear to have a very strong relationship between wins and losses.

```{r, warning=FALSE, message=FALSE, fig.width=12}
adv_plots <- function(variable, plot_name) {
  
  advanced_stats_per_game %>%
  ggplot(aes(fill = factor(Winner))) +
  geom_density(aes_string(x= variable), alpha = 0.5) +
  scale_fill_manual(values = c(plot_cols[3], plot_cols[2])) +
  labs(subtitle=plot_name) +
  theme_jason() +
  theme(legend.position = "none", axis.title.y = element_blank())
}

off_rat <- adv_plots("OffRtg", "Offensive Rating")

def_rat <- adv_plots("DefRtg", "Defensive Rating")
  
sos <- adv_plots("SoS", "Strength of Schedule")

TIE <- adv_plots("Tie", "Team Impact Estimator")

ast_ratio <- adv_plots("AstRatio", "Assist Ratio") 

to_ratio <- adv_plots("TORatio", "Turnover Ratio")

ts_perc <- adv_plots("TSPerc", "True Shooting Percentage")

eff_fg_perc <- adv_plots("EFGPerc", "Effective FG%")

ft_rate <- adv_plots("FTRate", "Free Throw Rate")

off_reb <- adv_plots("OffRebPerc", "Offensive Rebound%")

def_reb <- adv_plots("DefRebPerc", "Defensive Rebound%")

tot_reb <- adv_plots("TotRebPerc", "TotalRebound%")

grid.arrange(off_rat, def_rat, sos, TIE, ast_ratio, to_ratio, ts_perc, eff_fg_perc, ft_rate, off_reb, def_reb, tot_reb, ncol = 4, top = "Blue fill indicates winning team")

```

## Season Advanced and Box Score Stats and Wins

This section of the analysis will look at the advanced stats for a team's performance over the season and plot the relationship with each stat with the total wins for the season. Highlighted points plot the NCAA champion for that season in orange to see where the champion sat compared to the other schools.


```{r, warning=FALSE, message=FALSE}
# regular season
# reg_season_stats <- reg_season_stats %>%
#   mutate(WPoss = WFGA + (WFTA * 0.475) + WTO - WOR,
#          LPoss = LFGA + (LFTA * 0.475) + LTO - LOR)

season_team_stats_tot <- reshape_detailed_results(reg_season_stats)


advanced_stats_season <- season_team_stats_tot %>%
  mutate(WinPerc = wins / GP,
         OffRtg = 100 * (TotPoints / TotPos),
         DefRtg = 100 * (TotPointsAllow / TotPossAllow),
         SoS = OffRtg - DefRtg,
         Pie = TotPoints + TotFGM + TotFTM - TotFGA - TotFTA + TotDR + (0.5 * TotOR) + TotAst + TotStl + (0.5 * TotBlk) - TotPF - TotTO,
         OPie = TotPointsAllow + TotFGMAllow + TotFTMAllow - TotFGAAllow - TotFTAAllow + TotDRAllow + (0.5 * TotORAllow) + TotAstAllow + TotStlAllow + (0.5 * TotBlkAllow) - TotPFAllow - TotTOAllow,
         Tie = Pie / (Pie + OPie) * 100,
         AstRatio = 100 * TotAst / (TotFGA + (0.475 * TotFTA) + TotAst + TotTO),
         TORatio = 100 * TotTO / (TotFGA + (0.475 * TotFTA) + TotAst + TotTO),
         TSPerc = 100 * TotPoints / (2 * (TotFGA + (0.475 * TotFTA))),
         FTRate = TotFTA / TotFGA,
         ThreesShare = TotFGA3 / TotFGA,
         OffRebPerc = TotOR / (TotOR + TotDRAllow),
         DefRebPerc = TotDR / (TotDR + TotORAllow),
         TotRebPerc = (TotDR + TotOR) / (TotDR + TotOR + TotDRAllow + TotORAllow)) %>%
  select(Season, TeamID, TotPoints, TotPointsAllow, wins, WinPerc, OffRtg, DefRtg, SoS, Pie, OPie, Tie, AstRatio, TORatio, TSPerc, FTRate, ThreesShare, OffRebPerc, DefRebPerc, TotRebPerc) %>%
  left_join(teams %>% select(TeamID, TeamName), by = "TeamID")

ncaa_champs <- ncaa_champs %>% 
  mutate(season_winner = paste(Season, WTeamID, sep = "_"))

advanced_stats_season <- advanced_stats_season %>%
  mutate(season_winner = paste(Season, TeamID, sep = "_"),
         win_yes_no = ifelse(season_winner %in% ncaa_champs$season_winner, "Champs", "Not"))

```

### Advanced Stats and Wins

There is a strong positive correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$OffRtg), 4)`) between a teams offensive rating and the total number of wins for the season. The majority of the champions in each season were close rto the highest offensive rating teams. Connecticut appear to be somewhat of an exception - each of their championhip seasons having a slightly lower offensive rating than a few teams.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= OffRtg, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= OffRtg, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= OffRtg, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("OFFENSIVE RATING AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$OffRtg), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


Conversely, there is a moderately strong negative correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$DefRtg), 4)`) between a teams defensive rating adn the number of wins for the season. Syracuse in '03, Connecticut in '11, Duke in '15, UNC in '17 and Villanova last year bucked the trend somewhat.

Wofford's defensive rating was similar to that of some past champions (UNC '17 and Duke '15).

```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= DefRtg, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= DefRtg, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= DefRtg, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("DEFENSIVE RATING AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$DefRtg), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a very strong positive relationship (`r round(cor(advanced_stats_season$wins, advanced_stats_season$SoS), 4)`) between a team's strength of schedule (net rating) and their wins total for the season. Connecticut in 2011 had the lowest strength of schedule of all the champions since 2003.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= SoS, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= SoS, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= SoS, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("STRENGTH OF SCHEDULE AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$SoS), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a very strong positive relationship (`r round(cor(advanced_stats_season$wins, advanced_stats_season$Tie), 4)`) between a team's TIE and their wins total for the season. Connecticut in 2011 had the lowest TIE of all the champions since 2003.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= Tie, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= Tie, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= Tie, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("TEAM IMPORTANCE EFFICIENCY AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$Tie), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a moderately positive correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$AstRatio), 4)`) between a team's assist ratio and their wins. Duke in '10, Kentucky in '12 and Connecticut in '11 (again) and '14 go against this somewhat.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= AstRatio, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= AstRatio, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= AstRatio, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("ASSIST RATIO AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$AstRatio), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a moderately negative (`r round(cor(advanced_stats_season$wins, advanced_stats_season$TORatio), 4)`) correlation between a team's turnover ratio and wins.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= TORatio, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= TORatio, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= TORatio, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("TURNOVER RATIO AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$TORatio), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a fairly strong positive correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$TSPerc), 4)`) between a team's true shooting percentage and their wins, although being at the top of the pile hasn't been all that important to the eventual champions.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= TSPerc, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= TSPerc, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= TSPerc, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("TRUE SHOOTING PERCENTAGE AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$TSPerc), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a weak positive correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$FTRate), 4)`) between a team's free throw rate and their wins for the season. The eventual champs have had both good and not so good seasons in this stat.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= FTRate, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= FTRate, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= FTRate, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("FREE THROW RATE AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$FTRate), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is no correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$ThreesShare), 4)`) between the percentage of shots taken that are three point attempts and total wins for the season. Villanova however have been at the higher end of this metric during their two championship seasons.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= ThreesShare, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= ThreesShare, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= ThreesShare, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("THREE POINTERS SHARE AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$ThreesShare), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)

```


There is a weak positive correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$OffRebPerc), 4)`) between the offensive rebounding percentage and total wins for the season. Most champions were fairly strong in this measure, none more so than UNC in 2017. Villanova's last two championship runs showed that it wasn't vital to them, nor was it important to Virginia last year.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= OffRebPerc, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= OffRebPerc, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= OffRebPerc, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("OFFENSIVE REBOUNDING % AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$OffRebPerc), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)

```


There is a weak positive correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$DefRebPerc), 4)`) between the defensive rebounding percentage and total wins for the season. The eventual champions weren't overy dominant in this statistic.


```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= DefRebPerc, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= DefRebPerc, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= DefRebPerc, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("DEFENSIVE REBOUNDING % AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$DefRebPerc), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)

```


There is a fairly strong positive correlation (`r round(cor(advanced_stats_season$wins, advanced_stats_season$TotRebPerc), 4)`) between the total rebounding percentage and total wins for the season. It is certainly a stronger correlation than offensive and defensive rebounding percentages individually. Most champions were dominant in this category. Wofford is also fairly dominant in this stat...

```{r, warning=FALSE, message=FALSE, fig.width=10}
advanced_stats_season %>%
  ggplot() +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Not"), aes(x= TotRebPerc, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= TotRebPerc, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(advanced_stats_season, win_yes_no == "Champs"), aes(x= TotRebPerc, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("TOTAL REBOUNDING % AND WINS", subtitle = paste0("Correlation of ", round(cor(advanced_stats_season$wins, advanced_stats_season$TotRebPerc), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)

```

### Box Score Stats and Wins

There is a moderately strong positive correlation (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgPoints), 4)`) between the average points per game for a season and the team's wins total. Connecticut's championship seasons showed that you don't need to be the highest scoring team to win it all, while Virginia probably further bucked the trend, averaging just over 70 points per game.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages <- season_team_stats_averages %>%
  mutate(season_winner = paste(Season, TeamID, sep = "_"),
         win_yes_no = ifelse(season_winner %in% ncaa_champs$season_winner, "Champs", "Not")) %>%
  left_join(teams %>% select(TeamID, TeamName), by = "TeamID")


season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= AvgPoints, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgPoints, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgPoints, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE POINTS SCORED AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgPoints), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)


```


There is a not a relationship (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgPoss), 4)`) between the average number of possessions per game and the team's wins total. Interestingly, Virginia's champoinship last season saw them have the lowest possessions per game.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= AvgPoss, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgPoss, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgPoss, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE POSSESSIONS AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgPoss), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a not a relationship (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgFGA3), 4)`) between the average number of threes attempted per game and the team's wins total.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= AvgFGA3, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgFGA3, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgFGA3, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE THREES ATTEMPTED AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgFGA3), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There appears to be a weak positive (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgFGM3), 4)`) relationship between the average number of threes made per game and the team's wins total.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= AvgFGM3, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgFGM3, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgFGM3, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE THREES MADE AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgFGM3), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There appears to be a weak positive (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgOR), 4)`) relationship between the average number of offensive rebounds per game and the team's wins total. Virginia last season were at the lower end of teams offensive rebounding numbers.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= AvgOR, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgOR, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgOR, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE OFFENSIVE REBOUNDS AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgOR), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a stronger positive relationship (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$Avg_DR), 4)`) between the average number of defensive debounds per game and the team's wins total than there is for the previously analysed offensive rebounds. Virginia last year were middle of the pack.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= Avg_DR, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= Avg_DR, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= Avg_DR, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE DEFENSIVE REBOUNDS AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$Avg_DR), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a moderately positive correlation (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$Avg_Blk), 4)`) between the average number of blocks per game and team wins for the season. Kentucky in 2012 and Connecticut in 2004 really stood out, while other winners have not relied on this defensive stat, including Virginia last season.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= Avg_Blk, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= Avg_Blk, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= Avg_Blk, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE BLOCKS AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$Avg_Blk), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)
```


There is a weak positive correlation (`r round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgStl), 4)`) between the average number of steals per game and team wins for the season. The overally champs have not really relied on this stat either in their championship years.

```{r, warning=FALSE, message=FALSE, fig.width=10}
season_team_stats_averages %>%
  ggplot() +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Not"), aes(x= AvgStl, y= wins), alpha = 0.5, color = "lightgrey") +
  geom_point(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgStl, y= wins), color = plot_cols[2]) +
  geom_text(data = subset(season_team_stats_averages, win_yes_no == "Champs"), aes(x= AvgStl, y= wins, label = TeamName), nudge_y = 4, colour = plot_cols[2]) +
  ggtitle("AVERAGE STEALS AND WINS", subtitle = paste0("Correlation of ", round(cor(season_team_stats_averages$wins, season_team_stats_averages$AvgStl), 4))) +
  theme_jason() +
  theme(legend.position = "none") +
  facet_wrap(~Season)

```

***

# Tournament vs Regular Season Stats Analysis


```{r, warning=FALSE, message=FALSE}
# create a variable to distinguish between the regular season and tournament stats
reg_season_stats$Type <- "RegularSeason"
tourney_stats$Type <- "Tournament"

# join the regular season and tourney detailed stats
joined_reg_tourney <- rbind(reg_season_stats, tourney_stats)


```

This section will explore the differences in the key statistics between regular season and tournament games for **winning teams**.

One would this that games would be played differently under the pressure-cooker environmet of tourney play, so let's see...

## Points

Overall, there doesn't appear to be much of a difference in in the Winning team score and margin between the regular season and tournament play.

```{r, warning=FALSE, message=FALSE}
a <- joined_reg_tourney %>%
  ggplot(aes(x= WScore, fill = Type)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  ggtitle("POINTS & MARGINS IN THE TOURNEY vs REGULAR SEASON", subtitle = "Winning Team Points and margins in the regular \nseason and tourney roughly the same") +
  labs(x= "Winning Team Score", y= "") +
  theme_jason() +
  theme(legend.position = "top", legend.title = element_blank())

b <- joined_reg_tourney %>%
  mutate(Margin = WScore - LScore) %>%
  ggplot(aes(x= Margin, fill = Type)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  labs(y= "") +
  theme_jason() + 
  theme(legend.position = "none")

grid.arrange(a, b)
```

When breaking out the analysis for each of the years analysed, 2008, 2009, 2015, 2018 and 2019 stand out as years where the distributions of points margins differ between the regular seasons and tourney play, with these years all having slightly higher winning margins in tournament games.

```{r, warning=FALSE, message=FALSE}
joined_reg_tourney %>%
  mutate(Margin = WScore - LScore) %>%
  ggplot(aes(x= Margin, fill = Type)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  ggtitle("MARGINS IN THE TOURNEY vs REGULAR SEASON THROUGH THE YEARS", subtitle = "Margins are slightly higher during the tourney") +
  labs(y= "") +
  theme_jason() + 
  theme(legend.position = "top", legend.title = element_blank(), strip.text = element_text(face = "bold")) + 
  facet_wrap(~ Season)
```


## Field Goals

The winning team will attempt roughly the same amount of field goals in the regular season as they will during tournament play.

```{r, warning=FALSE, message=FALSE}
a <- joined_reg_tourney %>%
  ggplot(aes(x= WFGA, fill = Type)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  ggtitle("FGA TOURNEY vs REGULAR SEASON", subtitle = "Field Goal Attempts by winning team in the regular \nseason and tourney roughly the same") +
  labs(x= "Winning Team FG Attempted", y= "") +
  theme_jason() +
  theme(legend.position = "top", legend.title = element_blank())

b <- joined_reg_tourney %>%
  ggplot(aes(x= WFGM, fill = Type)) +
  geom_density(alpha = 0.5, adjust = 1.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  ggtitle("FGM TOURNEY vs REGULAR SEASON", subtitle = "Winning Team has more slightly more\nField Goals Made during the tourney") +
  labs(x= "Winning Team FG Made", y= "") +
  theme_jason() +
  theme(legend.position = "none")

grid.arrange(a,b)

```

The 2017 and 2018 seasons had more field goals attempted by the winning team during the tournament games, while 2014 and 2019 had more field goal attempts by the winning team during the regular season than the tourney.

```{r, warning=FALSE, message=FALSE}
joined_reg_tourney %>%
  ggplot(aes(x= WFGA, fill = Type)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  ggtitle("FGAs TOURNEY vs REGULAR SEASON THROUGH THE YEARS", subtitle = "Field Goal Attempts by winning team in the regular \nseason and tourney roughly the same") +
  labs(x= "Winning Team FG Attempted", y= "") +
  theme_jason() +
  theme(legend.position = "top", legend.title = element_blank(), strip.text = element_text(face = "bold")) +
  facet_wrap(~ Season)
```


## Rebounds

Offensive rebounds for winning teams have been slightly higher during the regular season games, where as winning teams have had more defensive rebounds during tournaments. 

```{r, warning=FALSE, message=FALSE}
a <- joined_reg_tourney %>%
  ggplot(aes(x= WOR, fill = Type)) +
  geom_density(alpha = 0.5, adjust = 1.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  ggtitle("OFF REB TOURNEY vs REGULAR SEASON", subtitle = "Winning team has slightly more Offensive Rebounds \nduring the regular season") +
  labs(x= "Winning Team Offensive Rebounds", y= "") +
  theme_jason() +
  theme()

b <- joined_reg_tourney %>%
  ggplot(aes(x= WDR, fill = Type)) +
  geom_density(alpha = 0.5, adjust = 1.5) +
  scale_fill_manual(values = c(plot_cols[2], plot_cols[3])) +
  ggtitle("DEF REB TOURNEY vs REGULAR SEASON", subtitle = "Winning Team has slightly more Defensive Rebounds \nduring the tourney") +
  labs(x= "Winning Team Defensive Rebounds", y= "") +
  theme_jason(legend_pos = "none") +
  theme()

grid.arrange(a, b)  
```

***

# Relationship between statistics and wins

***

# Bonus Material - Court Drawing!

**How to draw a court!**

I came across this brilliant piece of code by [Ed Küpfer](https://gist.github.com/edkupfer/6354964) and thought I'd share it here with a few modifications. Hopefully it will make plotting event location data easier for R users.


```{r, warning=FALSE, message=FALSE}
library(ggplot2)


draw_court <- function(line_col="black", court_col="white") {
  ggplot(data=data.frame(x=1,y=1),aes(x,y))+
    ###outside box:
    geom_path(data=data.frame(x=c(-25,-25,25,25,-25),y=c(-47,47,47,-47,-47)), colour = line_col)+
    ###halfcourt line:
    geom_path(data=data.frame(x=c(-25,25),y=c(0,0)), colour = line_col)+
    ###halfcourt semicircle:
    geom_path(data=data.frame(x=c(-6000:(-1)/1000,1:6000/1000),y=c(sqrt(6^2-c(-6000:(-1)/1000,1:6000/1000)^2))),aes(x=x,y=y), colour = line_col)+
    geom_path(data=data.frame(x=c(-6000:(-1)/1000,1:6000/1000),y=-c(sqrt(6^2-c(-6000:(-1)/1000,1:6000/1000)^2))),aes(x=x,y=y), colour = line_col)+
    ###solid FT semicircle above FT line:
    geom_path(data=data.frame(x=c(-6000:(-1)/1000,1:6000/1000),y=c(28-sqrt(6^2-c(-6000:(-1)/1000,1:6000/1000)^2))),aes(x=x,y=y), colour = line_col)+
    geom_path(data=data.frame(x=c(-6000:(-1)/1000,1:6000/1000),y=-c(28-sqrt(6^2-c(-6000:(-1)/1000,1:6000/1000)^2))),aes(x=x,y=y), colour = line_col)+
    ###dashed FT semicircle below FT line:
    geom_path(data=data.frame(x=c(-6000:(-1)/1000,1:6000/1000),y=c(28+sqrt(6^2-c(-6000:(-1)/1000,1:6000/1000)^2))),aes(x=x,y=y),linetype='dashed', colour = line_col)+
    geom_path(data=data.frame(x=c(-6000:(-1)/1000,1:6000/1000),y=-c(28+sqrt(6^2-c(-6000:(-1)/1000,1:6000/1000)^2))),aes(x=x,y=y),linetype='dashed', colour = line_col)+
    ###key:
    geom_path(data=data.frame(x=c(-8,-8,8,8,-8),y=c(47,28,28,47,47)), colour = line_col)+
    geom_path(data=data.frame(x=-c(-8,-8,8,8,-8),y=-c(47,28,28,47,47)), colour = line_col)+
    ###box inside the key:
    geom_path(data=data.frame(x=c(-6,-6,6,6,-6),y=c(47,28,28,47,47)), colour = line_col)+
    geom_path(data=data.frame(x=c(-6,-6,6,6,-6),y=-c(47,28,28,47,47)), colour = line_col)+
    ###restricted area semicircle:
    geom_path(data=data.frame(x=c(-4000:(-1)/1000,1:4000/1000),y=c(41.25-sqrt(4^2-c(-4000:(-1)/1000,1:4000/1000)^2))),aes(x=x,y=y), colour = line_col)+
    geom_path(data=data.frame(x=c(-4000:(-1)/1000,1:4000/1000),y=-c(41.25-sqrt(4^2-c(-4000:(-1)/1000,1:4000/1000)^2))),aes(x=x,y=y), colour = line_col)+
    ###rim:
    geom_path(data=data.frame(x=c(-750:(-1)/1000,1:750/1000,750:1/1000,-1:-750/1000),y=c(c(41.75+sqrt(0.75^2-c(-750:(-1)/1000,1:750/1000)^2)),c(41.75-sqrt(0.75^2-c(750:1/1000,-1:-750/1000)^2)))),aes(x=x,y=y), colour = line_col)+
    geom_path(data=data.frame(x=c(-750:(-1)/1000,1:750/1000,750:1/1000,-1:-750/1000),y=-c(c(41.75+sqrt(0.75^2-c(-750:(-1)/1000,1:750/1000)^2)),c(41.75-sqrt(0.75^2-c(750:1/1000,-1:-750/1000)^2)))),aes(x=x,y=y), colour = line_col)+
    ###backboard:
    geom_path(data=data.frame(x=c(-3,3),y=c(43,43)),lineend='butt', colour = line_col)+
    geom_path(data=data.frame(x=c(-3,3),y=-c(43,43)),lineend='butt', colour = line_col)+
    ###three-point line:
    geom_path(data=data.frame(x=c(-22,-22,-22000:(-1)/1000,1:22000/1000,22,22),y=c(47,47-169/12,41.75-sqrt(23.75^2-c(-22000:(-1)/1000,1:22000/1000)^2),47-169/12,47)),aes(x=x,y=y), colour = line_col)+
    geom_path(data=data.frame(x=c(-22,-22,-22000:(-1)/1000,1:22000/1000,22,22),y=-c(47,47-169/12,41.75-sqrt(23.75^2-c(-22000:(-1)/1000,1:22000/1000)^2),47-169/12,47)),aes(x=x,y=y), colour = line_col)+
    ###fix aspect ratio to 1:1
    coord_fixed() +
    theme_minimal() +
    theme(panel.grid = element_blank(), axis.text = element_blank(), axis.title = element_blank(), panel.background = element_rect(fill = court_col))
}
```

## Applying the function

**Standard colour**

```{r, warning=FALSE, message=FALSE}
draw_court()
```

**Different colour scheme**
```{r, warning=FALSE, message=FALSE}
draw_court(line_col = "white", court_col = "tan3")

draw_court(line_col = "white", court_col = "black")
```