--- title: 'Right, Left, Shoot: March Madness EDA' date: '`r Sys.Date()`' runtime: shiny output: html_document: fig_caption: true toc: true fig_width: 7 fig_height: 4.5 theme: paper highlight: tango code_folding: hide --- ```{r setup, include=FALSE} knitr::opts_chunk$set(echo = TRUE) ```
# Overview ## Setup We load a few libraries for data visualization here. ```{r} # general visualisation library('ggplot2') # visualisation library('scales') # visualisation library('patchwork') # visualisation library('RColorBrewer') # visualisation library('corrplot') # visualisation # general data manipulation library('dplyr') # data manipulation library('readr') # input/output library('vroom') # input/output library('skimr') # overview library('tibble') # data wrangling library('tidyr') # data wrangling library('stringr') # string manipulation library('forcats') # factor manipulation ``` ## Loading our data ```{r echo=FALSE} if (dir.exists("/kaggle")){ path <- "/kaggle/input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/" } else { path <- "" } subpath <- "MDataFiles_Stage1/" ``` ```{r} teams <- vroom(str_c(path, subpath, "MTeams.csv"), col_types = cols()) seasons <- vroom(str_c(path, subpath, "MSeasons.csv"), col_types = cols()) seeds <- vroom(str_c(path, subpath, "MNCAATourneySeeds.csv"), col_types = cols()) regular_res <- vroom(str_c(path, subpath, "MRegularSeasonCompactResults.csv"), col_types = cols()) bracket_res <- vroom(str_c(path, subpath, "MNCAATourneyCompactResults.csv"), col_types = cols()) events19 <- vroom(str_c(path, "MEvents2019.csv"), col_types = cols()) players <- vroom(str_c(path, "MPlayers.csv"), col_types = cols()) ``` ## Previous events ```{r} ev15 <- vroom(str_c(path, "MEvents2015.csv"), col_types = cols()) ev16 <- vroom(str_c(path, "MEvents2016.csv"), col_types = cols()) ev17 <- vroom(str_c(path, "MEvents2017.csv"), col_types = cols()) ev18 <- vroom(str_c(path, "MEvents2018.csv"), col_types = cols()) ``` # Summaries ## General items {.tabset .tabset-fade .tabset-pills} ### Teams ```{r} summary(teams) ``` ### Seasons ```{r} summary(seasons) ``` ### Players ```{r} summary(players) ``` ## Events over the years {.tabset .tabset-fade .tabset-pills} ### A brief helper ```{r} library('kableExtra') # will be useful ``` ### 2015 ```{r} summary(ev15) ``` ### 2016 ```{r} summary(ev16) ``` ### 2017 ```{r} summary(ev17) ``` ### 2018 ```{r} summary(ev18) ``` ### 2019 ```{r} summary(events19) ``` ## Data Samples ### Using kable {.tabset .tabset-fade} #### Teams ```{r} teams %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} teams %>% tail(5) %>% kable() %>% kable_styling() ``` #### Seasons ```{r} seasons %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} seasons %>% tail(5) %>% kable() %>% kable_styling() ``` #### Players ```{r} players %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} players %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2015 ```{r} ev15 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} ev15 %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2016 ```{r} ev16 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} seasons %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2017 ```{r} ev17 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} ev17 %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2018 ```{r} ev18 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} ev18 %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2019 ```{r} events19 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} events19 %>% tail(5) %>% kable() %>% kable_styling() ``` ### Where is the missing data? We should first see what exactly is missing before proceeding to (evil laughs) **devastate it utterly!** ```{r} library(tidyverse) library(ggplot2) library(caret) install.packages("caretEnsemble") library(caretEnsemble) library(psych) library(Amelia) library(mice) library(GGally) library(rpart) library(randomForest) ```{r} missmap(teams) ``` ```{r} missmap(seasons) ``` ```{r} missmap(players) ``` ```{r} missmap(regular_res) ``` ```{r} missmap(bracket_res) ``` ```{r} missmap(ev15) ``` ```{r} missmap(ev16) ``` ```{r} missmap(ev17) ``` ```{r} missmap(ev18) ``` ```[r] missmap(ev19) ``` ## Eliminating missing data We are going to use the package `mice` to eliminate the missing data. First, we must load the library: ```{r} library(mice) ``` Now, we must remove missing data: ```{r} mice_teams <- mice(teams[, c("TeamID","TeamName","FirstD1Season","LastD1Season")], method='rf') mice_complete1 <- complete(mice_teams) ``` ```{r} teams$TeamID <- mice_complete1$TeamID teams$TeamName <- mice_complete1$TeamName teams$FirstD1Season <- mice_complete1$FirstD1Season teams$LastD1Season<- mice_complete1$LastD1Season ``` ```{r} mice_S <- mice(seasons[, c("DayZero","Season", "RegionW","RegionX", "RegionY", "RegionZ")], method='rf') mice_complete1 <- complete(mice_S) ``` ```{r} seasons$DayZero <- mice_S$DayZero seasons$Season <- mice_S$Season seasons$RegionW <- mice_S$RegionW seasons$RegionX <- mice_S$RegionX seasons$RegionY <- mice_S$RegionY seasons$RegionZ <- mice_S$RegionZ ``` ```{r} PL <- mice(players[, c("PlayerID","LastName","FirstName", "TeamID")], method='rf') mice_complete1 <- complete(PL) ``` ## Relationships with treemaps {.tabset .tabset-fade .tabset-pills} ### Helper ```{r} library(treemap) treemapper = function(data, x, y) { tm <- treemap(data, index = x, vSize = y) } ``` ### Seasons {.tabset .tabset-fade .tabset-pills} #### Regular Season Results {.tabset .tabset-fade .tabset-pills} ##### Winner Score and Loser score ```{r} value_data = regular_res %>% select(WScore) %>% group_by(WScore) %>% summarise(LScore = n())%>% filter(LScore < 4) ``` ```{r} treemapper(value_data, 'WScore', 'LScore') ``` ```{r} value_data = regular_res %>% select(LScore) %>% group_by(LScore) %>% summarise(WScore = n())%>% filter(WScore < 4) ``` ```{r} treemapper(value_data, 'LScore', 'WScore') ``` #### Bracketed Results {.tabset .tabset-fade .tabset-pills} ##### Winner Score and Loser score ```{r} value_data = bracket_res %>% select(WScore) %>% group_by(WScore) %>% summarise(LScore = n())%>% filter(LScore < 4) ``` ```{r} treemapper(value_data, 'WScore', 'LScore') ``` ##### Location ##### Winners and Loser ```{r} value_data = bracket_res %>% select(WTeamID) %>% group_by(WTeamID) %>% summarise(LTeamID = n())%>% filter(LTeamID < 4) ``` ```{r} treemapper(value_data, 'WTeamID', 'LTeamID') ``` ```{r} value_data = bracket_res %>% select(LTeamID) %>% group_by(LTeamID) %>% summarise(WTeamID = n())%>% filter(WTeamID < 4) ``` ```{r} treemapper(value_data, 'LTeamID', 'WTeamID') ``` # Correlations with corrgram In this part of my data analysis, I will use the correlogram package to create correlograms. ## Loading corrgram ```{r} library(corrgram) ``` ## Analysis 1: Bracketed and Regular Results ### Bracketed results ```{r} corrgram(bracket_res, order=TRUE, lower.panel=panel.shade, upper.panel=panel.pie, text.panel=panel.txt, main="Bracketed Results") ``` #### Another analysis ```{r} library(corrgram) col.corrgram <- function(ncol){ colorRampPalette(c("darkgoldenrod4", "burlywood1", "darkkhaki", "darkgreen"))(ncol)} corrgram(bracket_res, order=TRUE, lower.panel=panel.shade, upper.panel=panel.pie, text.panel=panel.txt, main="More") ``` ### Regular results ```{r} corrgram(regular_res, order=TRUE, lower.panel=panel.shade, upper.panel=panel.pie, text.panel=panel.txt, main="Regular Results") ``` #### Another analysis ```{r} library(corrgram) col.corrgram <- function(ncol){ colorRampPalette(c("darkgoldenrod4", "burlywood1", "darkkhaki", "darkgreen"))(ncol)} corrgram(regular_res, order=TRUE, lower.panel=panel.shade, upper.panel=panel.pie, text.panel=panel.txt, main="another one") ``` --- Out of everything, we can see two main things over here:
  1. In both bracketed and regular season results, we can view that there is an extremely strong correlation between the winner and the loser's score.
  2. We can also see that in regular results, there is absolutely no correlation between LTeamID and NumScore.
### Takeaways: Correlations between bracketed and regular results #### Top 3 correlations in regular seasons
  1. WScore + LScore
  2. Season + DayNum
  3. Season + LScore
#### Top 3 correlations in bracketed seasons
  1. WScore + LScore
  2. Season + DayNum
  3. Season + LScore
## Analysis 2: Teams ```{r} corrgram(teams, order=TRUE, lower.panel=panel.shade, upper.panel=panel.pie, text.panel=panel.txt, main="Teams") ``` ## Takeaways 2: Teams ### Top 3 correlations in teams
  1. TeamID + LastD1Season
  2. TeamID + FirstD1Season
  3. FirstD1Season + LastD1Season
## Analysis 3: Seeds ```{r} corrgram(seeds, order=TRUE, lower.panel=panel.shade, upper.panel=panel.pie, text.panel=panel.txt, main="Bracketed Results") ``` --- ## Takeaways 3: Seasons ### Top correlation
  1. Season + TeamID
# Individual Feature Analysis We're going to use a regression analysis here. ## First analysis: Teams {.tabset .tabset-fade } ### Preparations ```{r} install.packages("ggeffects") install.packages("ggalluvial") library(ggalluvial) library(ggeffects) library(viridis) library(knitr) library(kableExtra) library(countrycode) library(highcharter) library(tidyverse) library(magrittr) ``` ### Starting off ```{r} teams %>% select(FirstD1Season, LastD1Season, TeamName, TeamID) %>% drop_na() %>% filter(FirstD1Season == "1985" | FirstD1Season == "2020") %>% group_by(FirstD1Season, LastD1Season, TeamName, TeamID) %>% summarize(freq = n()) %>% ungroup() %>% ggplot(aes(y = freq, axis1 = FirstD1Season, axis2 = LastD1Season, axis3 = TeamName, axis4 = TeamID)) + geom_alluvium(aes(fill = FirstD1Season), width = 1/12) + geom_stratum(width = 1/12, fill = "black", color = "grey") + geom_label(stat = "stratum", label.strata = TRUE) + scale_x_discrete(limits = c("First Season", "Last Season", "TeamName", "Team ID"), expand = c(.11, .01)) + labs(x = "", y = "") + theme_minimal() + theme(legend.position="none") ``` So we can see **a positive bunch** of uniques in the TeamName column. This is something that was expected. Let's try a switcharound to see what we get with the other variables, maybe it will be possible to have some fun and/or have some bets for you bookies in there. ```{r} teams %>% select(FirstD1Season, LastD1Season, TeamID) %>% drop_na() %>% filter(LastD1Season == "1985" | LastD1Season == "2020") %>% group_by(LastD1Season, FirstD1Season, TeamID) %>% summarize(freq = n()) %>% ungroup() %>% ggplot(aes(y = freq, axis1 = LastD1Season, axis2 = FirstD1Season, axis4 = TeamID)) + geom_alluvium(aes(fill = FirstD1Season), width = 1/12) + geom_stratum(width = 1/12, fill = "black", color = "grey") + geom_label(stat = "stratum", label.strata = TRUE) + scale_x_discrete(limits = c("First Season", "Last Season", "Team ID"), expand = c(.11, .01)) + labs(x = "", y = "") + theme_minimal() + theme(legend.position="none") ``` Also, now we get a chance to look at regular results and bracket results. (briefly). A more indepth explanation is coming soon. First, we'll look at the winning teams. #### Winners ```{r} regular_res %>% ggplot(aes(x=WTeamID)) + geom_histogram(alpha = 0.5, fill = "#5EB296", colour = "#4D4D4D") + scale_x_continuous(labels = comma) + scale_y_continuous(labels = comma) + ggtitle("Winning Team Ids ", subtitle = "We are going to look at legendary winners through the years") + labs(x= "Winning Team", y= "Count") ``` --- #### Insights from winning teams: * One team has a close lead when it comes to wins. (approximately 6,600 wins) * Another team has a niche when it comes to the least wins, as it has only 4,200. * The range of the data is: $range = max - min $ = 6600 - 4200 $ = 4400 #### Losers Now, a brief look at the legendary losers. ```{r} regular_res %>% ggplot(aes(x=LTeamID)) + geom_histogram(alpha = 0.5, fill = "#5EB296", colour = "#4D4D4D") + scale_x_continuous(labels = comma) + scale_y_continuous(labels = comma) + ggtitle("Losing Team Ids ", subtitle = "We are going to look at legendary losers through the years") + labs(x= "Winning Team", y= "Count") ``` #### Insights from losing teams: ### Target 1: Bracketed Results ```{r} library(tidyverse) library(gridExtra) library(knitr) library(magrittr) library(ggExtra) ``` ```{r} # Join team names to tourney compact dataset tourney_stats_compact <- bracket_res %>% 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 = "steelblue", color = "black") + theme_minimal()+ labs(title = "Most Tourney Wins since 1985", x= "Winner", y= "Titles") + coord_flip() lose_plot <- ncaa_champs %>% group_by(LTeamName) %>% summarise(n = n()) %>% ggplot(aes(x=reorder(LTeamName, n), y=n)) + geom_bar(stat = "identity", fill = "orange", colour = "black") + theme_minimal()+ labs(title = "Most Tourney Bridesmaids since 1985", x= "Runner-up", y= "Titles") + coord_flip() grid.arrange(win_plot, lose_plot, ncol = 2) ``` --- Now we're going to work with the main focus of ths kernel: **analyzing the bracketed and regular season results**. My aim is to create a prime analysis for the bracketed and regular results. # The Primary Analysis: Part 1 In the primary analysis, we will mainly look at the results in the regular and bracketed seasons. ## Part 1: Regular seasons So, in this part of our analysis, we shall look at the regular season results of years long gone. ### An introduction The tournament consists of several rounds. They are currently named, in order of first to last: * The First Four * The First Round (the Round of 64) * The Second Round (the Round of 32) * The Regional Semi-finals (participating teams are known popularly as the "Sweet Sixteen") * The Regional Finals (participating teams are known commonly as the "Elite Eight") * The National Semi-finals (participating teams are referred to officially as the "Final Four") * The National Championship The tournament is single-elimination, which increases the chance of an underdog and lower-seeded "Cinderella team" advancing to subsequent rounds. Although these lower-ranked teams are forced to play stronger teams, they need only one win to advance (instead of needing to win a majority of games in a series, as in professional basketball). The University of Dayton Arena, which has hosted all First Four games since the round's inception in 2011, as well as its precursor, the single "play-in" game held from 2001 to 2010. As of 2019, the arena has hosted 123 tournament games, the most of any venue. First held during 2011, the First Four are games between the four lowest-ranked at-large teams and the four lowest-ranked automatic-bid (conference-champion) teams. ### A brief reminder or two #### Events for 2015 ```{r} ev15 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} ev15 %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2016 ```{r} ev16 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} seasons %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2017 ```{r} ev17 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} ev17 %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2018 ```{r} ev18 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} ev18 %>% tail(5) %>% kable() %>% kable_styling() ``` #### Events for 2019 ```{r} events19 %>% head(5) %>% kable() %>% kable_styling() ``` ```{r} events19 %>% tail(5) %>% kable() %>% kable_styling() ``` ### A pairplot to look at each season {.tabset .tabset-fade .tabset-pills} We're going to use the function `ggpairs` from ggplot2 to look at the data concerning each season. #### 2015 ```{r} ggpairs(head(ev15)) ``` #### 2016 ```{r} ggpairs(head(ev16)) ``` #### 2017 ```{r} ggpairs(head(ev17)) ``` #### 2018 ```{r} ggpairs(head(ev18)) ``` #### 2019 ```{r} ggpairs(head(events19)) ``` ### What scores do we have? ```{r} regular_res %>% ggplot(aes(x=LScore)) + geom_histogram(alpha = 0.5, fill = "#5EB296", colour = "#4D4D4D") + scale_x_continuous(labels = comma) + scale_y_continuous(labels = comma) + ggtitle("Loser's Score", subtitle = "What did the losers do?") + labs(x= "Loser Score", y= "Count") ``` ```{r} regular_res %>% ggplot(aes(x=WScore)) + geom_histogram(alpha = 0.5, fill = "#5EB296", colour = "#4D4D4D") + scale_x_continuous(labels = comma) + scale_y_continuous(labels = comma) + ggtitle("Winning Score ", subtitle = "Winners are doing better") + labs(x= "Winning Score", y= "Count") ``` #### Observations We see that: * A lot of victories have a score of about 75 to 80. * A lot of losses have a score of about 50. ### Using corrplot {.tabset .tabset-fade} We will use the library `corrplot` to visualize correlations between the data for: * Teams * Seasons * (main) Bracketed and regular results * Seeds * Events over the years #### Import ```{r} library(corrplot) ``` #### Bracketed results {.tabset .tabset-fade} We are going to use different variables to test the correlation of bracketed results: specifically WScore and LScore. ##### WScore-based corrplot We are going to use WScore as the base for this correlation plot. ```{r} numericVars <- which(sapply(bracket_res, is.numeric)) #index vector numeric variables numericVarNames <- names(numericVars) #saving names vector for use later on cat('There are', length(numericVars), 'numeric variables') ## There are 37 numeric variables all_numVar <- bracket_res[, numericVars] cor_numVar <- cor(all_numVar, use="pairwise.complete.obs") #correlations of all numeric variables #sort on decreasing correlations with SalePrice cor_sorted <- as.matrix(sort(cor_numVar[,'WScore'], decreasing = TRUE)) #select only high corelations CorHigh <- names(which(apply(cor_sorted, 1, function(x) abs(x)>0.5))) cor_numVar <- cor_numVar[CorHigh, CorHigh] corrplot.mixed(cor_numVar, tl.col="black", tl.pos = "lt") ``` ##### LScore-based corrplot We are going to use LScore as the base for this correlation plot. ```{r} numericVars <- which(sapply(bracket_res, is.numeric)) #index vector numeric variables numericVarNames <- names(numericVars) #saving names vector for use later on cat('There are', length(numericVars), 'numeric variables') all_numVar <- bracket_res[, numericVars] cor_numVar <- cor(all_numVar, use="pairwise.complete.obs") #correlations of all numeric variables #sort on decreasing correlations with SalePrice cor_sorted <- as.matrix(sort(cor_numVar[,'LScore'], decreasing = TRUE)) #select only high corelations CorHigh <- names(which(apply(cor_sorted, 1, function(x) abs(x)>0.5))) cor_numVar <- cor_numVar[CorHigh, CorHigh] corrplot.mixed(cor_numVar, tl.col="black", tl.pos = "lt") ``` --- #### Takeaways 1. **WScore and LScore both have exactly the same correlation.** #### Regular results {.tabset .tabset-fade} We are going to use different variables to test the correlation of regular results: specifically WScore and LScore. ##### WScore-based corrplot We are going to use WScore as the base for this correlation plot. ```{r} numericVars <- which(sapply(regular_res, is.numeric)) #index vector numeric variables numericVarNames <- names(numericVars) #saving names vector for use later on cat('There are', length(numericVars), 'numeric variables') ## There are 37 numeric variables all_numVar <- bracket_res[, numericVars] cor_numVar <- cor(all_numVar, use="pairwise.complete.obs") #correlations of all numeric variables #sort on decreasing correlations with SalePrice cor_sorted <- as.matrix(sort(cor_numVar[,'WScore'], decreasing = TRUE)) #select only high corelations CorHigh <- names(which(apply(cor_sorted, 1, function(x) abs(x)>0.5))) cor_numVar <- cor_numVar[CorHigh, CorHigh] corrplot.mixed(cor_numVar, tl.col="black", tl.pos = "lt") ``` ##### LScore-based corrplot We are going to use LScore as the base for this correlation plot. ```{r} numericVars <- which(sapply(regular_res, is.numeric)) #index vector numeric variables numericVarNames <- names(numericVars) #saving names vector for use later on cat('There are', length(numericVars), 'numeric variables') all_numVar <- bracket_res[, numericVars] cor_numVar <- cor(all_numVar, use="pairwise.complete.obs") #correlations of all numeric variables #sort on decreasing correlations with SalePrice cor_sorted <- as.matrix(sort(cor_numVar[,'LScore'], decreasing = TRUE)) #select only high corelations CorHigh <- names(which(apply(cor_sorted, 1, function(x) abs(x)>0.5))) cor_numVar <- cor_numVar[CorHigh, CorHigh] corrplot.mixed(cor_numVar, tl.col="black", tl.pos = "lt") ``` --- #### Takeaways * Same as the previous one. ## Event correlation for previous years {.tabset .tabset-fade} We are going to visualize the event correlation for previous years. We are going to use different variables to test the correlation of bracketed results for events. --- #### Takeaways **Note: The following section will not just be used for the Analytics competitions, but also for the NCAAM competition. I will be using LightGBM to predict and make observations from lightGBM predictions.** # Solutions This part contains my solution for the NCAAM competition.
It uses: * LightGBM * XGBoost stacked together. ## Credits for the solution * Larxel: https://www.kaggle.com/andrewmvd/lightgbm-in-r * Andrew Lukyanenko: https://www.kaggle.com/artgor/march-madness-2020-ncaam-eda-and-baseline ## Imports ```{r} library(lightgbm) library(xgboost) library(MLmetrics) library(data.table) library(Matrix) ``` ```{r} set.seed(257) ``` Working on it.