{"cells":[{"metadata":{},"cell_type":"markdown","source":"# Madness at Home and on the Court - Part 1\n\n*Authors: [Emilien Etchevers](https://www.kaggle.com/emimis), [Kieran Janin](https://www.kaggle.com/kieranjanin), [Michael Karpe](https://www.kaggle.com/mika30), [Remi Le Thai](https://www.kaggle.com/remilethai), [Haley Wohlever](https://www.kaggle.com/haleywohlever)*\n\n# Contents\n\n*In this notebook*\n\n- [Introduction](#Introduction) <br>\n- [NCAA March Madness Data Analysis](#NCAAMarchMadnessData)<br>\n  * [Seeding and Entertainment](#SeedingandEntertainment)<br>\n  * [Madness through Unpredictability](#MadnessthroughUnpredictability)<br>\n  * [Entertainment due to Closeness of Games](#EntertainmentduetoClosenessofGames)\n  \n    \n*In the* [*second notebook*](https://www.kaggle.com/mika30/madness-at-home-and-on-the-court-part-2): \n\n- [Tweets on NCAA Data Analysis](#TweetsonNCAAData)<br>\n  * [Temporal Evolution of Engagement](#TemporalEvolutionofEngagement)<br>\n  * [Team Mentions Count in Tweets](#TeamMentionsCountinTweets)<br>\n  * [Sentiment Analysis for Tweets on NCAA](#SentimentAnalysisforTweetsonNCAA)\n- [Conclusion](#Conclusion)\n\n\n# 1. Introduction\n\nMarch Madness is a period of excitement for everyone: from the die-hard fan to the serial gambler, this NCAA tournament has something for all. One of the major draws of the competition is its intangible and intoxicating element of unpredictability: with the closely packed games and high end teams, there’s always a chance for an upset, for an unexpected streak, or for a “Cinderella story.” We set out here to try to uncover whether or not these seemingly unpredictable moments could be anticipated? What truly contributes to the “madness” of a game and to this season of collegiate basketball?\n\nOur first challenge in this endeavor was attempting to define “madness.” Are we referring to the intensity of the game? the moves of each player on the court? Or are we referring to the crowd’s reaction to the outcome of a match? to the fan’s entertainment back home? Rather than limit our exploration, we decided to consider both possibilities. To do this effectively, we separated our work into two distinct categories: 1) that of empirical and “objective” madness that arises from the teams’ past game statistics and match events, and 2) that of emotional and “subjective” madness that comes from the enthusiasm of the fans while watching a game. This second type of madness is evaluated in a separate notebook which follows this one. Depending on who you ask, madness can have many meanings, but here we focus on it as the entertainment and pleasure that unites everyone around a great game of basketball.\n\n\n# 2. NCAA March Madness Data Analysis\n\nFor exploring the objective madness in this competition, the main data source at our disposal is the NCAA data provided through Kaggle. This data source is full of detailed and relevant information for the 2015 to 2019 seasons, from team and player names down to precisely recorded details on events that occur during each match!\n\n## 2.1. Seeding and Entertainment\n\nThe main question we explored is: can entertainment be linked to a team’s seed? In the extreme case of this is whether, by default, watching a seed 1 team compete will inherently be more enjoyable than watching a seed 16 team compete? We did this by first looking at specific events that occur during matches and working to see whether certain events were correlated with certain seeds.\n\nTo perform this analysis, we start by loading useful packages as well as the relevant data. We opted to use some pre-processing performed by [JasonVizkovic](https://www.kaggle.com/jaseziv83) in his Notebook: [Moreyball in the College Game...A Full NCAA EDA.](https://www.kaggle.com/jaseziv83/moreyball-in-the-college-game-a-full-ncaa-eda) It was particularly useful for helping us to isolate definite scoring attempts, understand whether they were assisted or not, and more."},{"metadata":{"trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"library(tidyverse)\nlibrary(scales)\nlibrary(grid)\nlibrary(gridExtra)\nlibrary(knitr)\nlibrary(ggExtra)\nlibrary(zoo) ## curve AUC\noptions(warn=-1)\nfig <- function(width, heigth){\n     options(repr.plot.width = width, repr.plot.height = heigth)\n}\n\ntourney_seeds <- read.csv(\"../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data/MDataFiles_Stage1/MNCAATourneySeeds.csv\", stringsAsFactors = FALSE)\n#~~~~~~~~~~~~~~~~~~~~~~~\n# Read in data\n#~~~~~~~~~~~~~~~~~~~~~~~\nplay_by_play <- data.frame()\n\n# loop through each seasons PlayByPlay folders and read in in the play by play files\nfor(each in list.files('../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data')[str_detect(list.files('../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data/'), \"MEvents\")]) {\n  df <- read_csv(paste0('../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data/', each))\n  \n  \n  # Grouped shooting variables ----------------------------------------------\n  # there are some shooting variables that can probably be condensed - tip ins and dunks\n  paint_attempts_made <- c(\"made2_dunk\", \"made2_lay\", \"made2_tip\") \n  paint_attempts_missed <- c(\"miss2_dunk\", \"miss2_lay\", \"miss2_tip\") \n  paint_attempts <- c(paint_attempts_made, paint_attempts_missed)\n  # create variables for field goals made, and also field goals attempted (which includes the sum of FGs made and FGs missed)\n  FGM <- c(\"made2_dunk\", \"made2_jump\", \"made2_lay\",  \"made2_tip\",  \"made3_jump\")\n  FGA <- c(FGM, \"miss2_dunk\", \"miss2_jump\" ,\"miss2_lay\",  \"miss2_tip\",  \"miss3_jump\")\n  # variable for three-pointers\n  ThreePointer <- c(\"made3_jump\", \"miss3_jump\")\n  #  Two point jumper\n  TwoPointJump <- c(\"miss2_jump\", \"made2_jump\")\n  # Free Throws\n  FT <- c(\"miss1_free\", \"made1_free\")\n  # all shots\n  AllShots <- c(FGA, FT)\n  \n  \n  # Feature Engineering -----------------------------------------------------\n  # paste the two even variables together for FGs as this is the format for last years comp data\n  df <- df %>%\n    mutate_if(is.factor, as.character) %>% \n    mutate(EventType = ifelse(str_detect(EventType, \"miss\") | str_detect(EventType, \"made\") | str_detect(EventType, \"reb\"), paste0(EventType, \"_\", EventSubType), EventType))\n  \n  # change the unknown for 3s to \"jump\" and for FTs \"free\"\n  df <- df %>% \n    mutate(EventType = ifelse(str_detect(EventType, \"3\"), str_replace(EventType, \"_unk\", \"_jump\"), EventType),\n           EventType = ifelse(str_detect(EventType, \"1\"), str_replace(EventType, \"_unk\", \"_free\"), EventType))\n  \n  \n  df <- df %>% \n    # create a variable in the df for whether the attempts was made or missed\n    mutate(shot_outcome = ifelse(grepl(\"made\", EventType), \"Made\", ifelse(grepl(\"miss\", EventType), \"Missed\", NA))) %>%\n    # identify if the action was a field goal, then group it into the attempt types set earlier\n    mutate(FGVariable = ifelse(EventType %in% FGA, \"Yes\", \"No\"),\n           AttemptType = ifelse(EventType %in% paint_attempts, \"PaintPoints\", \n                                ifelse(EventType %in% ThreePointer, \"ThreePointJumper\", \n                                       ifelse(EventType %in% TwoPointJump, \"TwoPointJumper\", \n                                              ifelse(EventType %in% FT, \"FreeThrow\", \"NoAttempt\")))))\n  \n  \n  # Rework DF so only shots are included and whatever lead to the shot --------\n  df <- df %>% \n    mutate(GameID = paste(Season, DayNum, WTeamID, LTeamID, sep = \"_\")) %>% \n    group_by(GameID, ElapsedSeconds) %>% \n    mutate(EventType2 = lead(EventType),\n           EventPlayerID2 = lead(EventPlayerID)) %>% ungroup()\n  \n  \n  df <- df %>% \n    mutate(FGVariableAny = ifelse(EventType %in% FGA | EventType2 %in% FGA, \"Yes\", \"No\")) %>% \n    filter(FGVariableAny == \"Yes\") \n  \n  \n  # create a variable for if the shot was made, but then the second event was also a made shot\n  df <- df %>% \n    mutate(Alert = ifelse(EventType %in% FGM & EventType2 %in% FGM, \"Alert\", \"OK\")) %>% \n    # only keep \"OK\" observations\n    filter(Alert == \"OK\") \n  # replace NAs with somerhing\n  df$EventType2[is.na(df$EventType2)] <- \"no_second_event\"\n  \n  \n  # create a variable for if there was an assist on the FGM:\n  df <- df %>% \n    mutate(AssistedFGM = ifelse(EventType %in% FGM & EventType2 == \"assist\", \"Assisted\", \n                                ifelse(EventType %in% FGM & EventType2 != \"assist\", \"Solo\", \n                                       ifelse(EventType %in% FGM & EventType2 == \"no_second_event\", \"Solo\", \"None\"))))\n  \n  # # because the FGA culd be either in `EventType` (more likely) or `EventType2` (less likely), need\n  # # one variable to indicate the shot type\n  \n  # create final output\n  df <- df %>% ungroup()\n  play_by_play <- bind_rows(play_by_play, df)\n  \n  rm(df);gc()\n}","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Now, as our goal is to analyze different game events using seeds as an input, it is first necessary for us to associate each event to the seed of the team that performed it."},{"metadata":{"trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"play_by_play$tot_score<-play_by_play$WFinalScore + play_by_play$LFinalScore\n\nSeeded_pbp <- play_by_play %>% \n  select(EventType,TeamID = EventTeamID,shot_outcome,Season, tot_score) %>%\n  merge(tourney_seeds, by = c(\"Season\", \"TeamID\")) \n\nSeeded_pbp$Region<-str_sub(Seeded_pbp$Seed,1,1)\nSeeded_pbp$Seed<-str_sub(Seeded_pbp$Seed,2,str_length(Seeded_pbp$Seed))\nSeeded_pbp<-subset(Seeded_pbp,(str_sub(Seeded_pbp$Seed,-1,-1)!=\"b\")&(str_sub(Seeded_pbp$Seed,-1,-1)!=\"c\"))\nSeeded_pbp$Seed<-str_sub(Seeded_pbp$Seed,1,2)\n\nRecapShots <- Seeded_pbp %>%\n  group_by(Seed,EventType) %>%\n  filter (shot_outcome =='Missed' | shot_outcome =='Made') %>%\n  count(shot_outcome)\n\nRecapShots$EventType<-as.factor(str_sub(RecapShots$EventType,5,str_length(RecapShots$EventType)))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Once this is done, we can now plot the number of times each event was performed by a given team. This is done in the hope to uncover some interesting trends: do the highest seeded teams rely on 3-pointers, as Moreyball would predict? do lower seeded teams prefer to rely on safer, 2-point shots?"},{"metadata":{"trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"fig(18,8)\npts1<- filter(RecapShots, EventType==\"1_free\") %>%\n  group_by(EventType) %>%\n  ggplot(aes(x=Seed,y=n, fill = shot_outcome)) + geom_bar(stat='identity')  + xlab(\"Free throws\") \npts2 <- filter(RecapShots, EventType==\"2_dunk\") %>%\n  group_by(EventType) %>%\n  ggplot(aes(x=Seed,y=n, fill = shot_outcome)) + geom_bar(stat='identity')  + xlab(\"Dunks\") \npts3 <- filter(RecapShots, EventType==\"2_tip\") %>%\n  group_by(EventType) %>%\n  ggplot(aes(x=Seed,y=n, fill = shot_outcome)) + geom_bar(stat='identity')  + xlab(\"Tip-ins\") \npts4 <- filter(RecapShots, EventType==\"2_lay\") %>%\n  group_by(EventType) %>%\n  ggplot(aes(x=Seed,y=n, fill = shot_outcome)) + geom_bar(stat='identity')  + xlab(\"Lay-ins\") \npts5 <- filter(RecapShots, EventType==\"2_jump\") %>%\n  group_by(EventType) %>%\n  ggplot(aes(x=Seed,y=n, fill = shot_outcome)) + geom_bar(stat='identity')  + xlab(\"2-point jump shots\") \npts6 <- filter(RecapShots, EventType==\"3_jump\") %>%\n  group_by(EventType) %>%\n  ggplot(aes(x=Seed,y=n, fill = shot_outcome)) + geom_bar(stat='identity')  + xlab(\"3-point jump shots\") \n\ngrid.arrange(pts1,pts2,pts3,pts4,pts5,pts6,nrow=2,ncol=3)","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"9eddb6ae-ad05-4693-8cf3-e4c538b12d56","_cell_guid":"1dc17b5c-9e36-4b39-9136-8fb1957eb001","trusted":true},"cell_type":"markdown","source":"Looking at these results, there appears to be no significant difference in the actions performed by each seed except for two: dunks and tip-ins. This finding is particularly interesting because these types of actions are also seen to be the most point-efficient shots in the game! Looking at the average points per attempt, a dunk and a tip-in bring respectively about 1.8 and 1.3 points per attempt (see chart below, credits again to JasonVizkovic).\n\nOne may therefore think that a characterization of a good team is its willingness to attempt dunks as often as possible. It must be noted, however, that this type of action requires careful team strategy as it is much harder to set up than a 3-point attempt. It would then seem that maybe it is not a team dunking often that makes it good, but that a good team is able to dunk often. The question of a team's priorities during game play then arises. We can assume that, as the ultimate goal of a team is to win, they prioritize using the most efficient actions possible to score points and do not take into consideration the potential entertainment value of those actions."},{"metadata":{"_uuid":"8bed80e8-c5e2-476f-ac90-6d74e294831f","_cell_guid":"89ada76e-b07e-45bc-824a-f2d918ce2d22","trusted":true,"_kg_hide-input":true,"_kg_hide-output":false},"cell_type":"code","source":"fig(8,6)\n#Effectiveness\nshot_values <- play_by_play %>% \n  filter(FGVariable == \"Yes\") %>% \n  mutate(EventType = str_remove(EventType, \"made\"), EventType = str_remove(EventType, \"miss\")) %>% \n  group_by(EventType, shot_outcome) %>% \n  summarise(n_attempts = n()) %>% \n  mutate(ShootingPercentage = n_attempts / sum(n_attempts),\n         n_attempts = sum(n_attempts)) %>% \n  filter(shot_outcome == \"Made\") %>% select(-shot_outcome)\n\nshot_values %>% \n  mutate(Point = as.numeric(str_extract(EventType, \"[[:digit:]]\"))) %>% \n  mutate(ExpectedPoints = ShootingPercentage * Point) %>% \n  ggplot(aes(x=reorder(EventType, ExpectedPoints), y= ExpectedPoints)) +\n  ylab(\"Average Points per atempt\") + xlab(\"Type of attempt\") +\n  geom_col(fill = \"#9067A7\", colour = \"grey\") +\n  geom_text(aes(label = round(ExpectedPoints, 1)), vjust =  1.2, colour = \"white\", size=6)","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"91e99d7e-e491-4f63-bb32-e4a92fd56bf7","_cell_guid":"de016f51-bf9f-456a-a842-7df652eab2f0","trusted":true},"cell_type":"markdown","source":"Another potentially revealing aspect of an interesting game is the total points scored during the match. Do higher seeds, with their honed offensive abilities to crush their opponents, increase the average number of points in a match? Or, on the contrary, do higher seeds often find themselves in stalemates with teams that have extremely effective defensive strategies? Read on as we attempt to examine this in what follows!"},{"metadata":{"_uuid":"3e095d94-f57e-43e2-a180-939fd912fe4f","_cell_guid":"4b4569f2-1efc-4007-bc8e-60da7cf555b4","trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"Teams1<-unique(play_by_play %>% group_by(Season,WTeamID,LTeamID) %>% select(Season,WTeamID,LTeamID,WFinalScore,LFinalScore))\nTeams2<-data.frame(Teams1)\n\nSeeded_t1 <- Teams1 %>% \n  merge(tourney_seeds, by.x = c(\"Season\", \"WTeamID\"), by.y=c(\"Season\", \"TeamID\")) \nSeeded_t2 <- Teams2 %>% \n  merge(tourney_seeds, by.x = c(\"Season\", \"LTeamID\"), by.y=c(\"Season\", \"TeamID\")) \n\nSeeded_t1$Region<-str_sub(Seeded_t1$Seed,1,1)\nSeeded_t1$Seed<-str_sub(Seeded_t1$Seed,2,str_length(Seeded_t1$Seed))\nSeeded_t1<-subset(Seeded_t1,(str_sub(Seeded_t1$Seed,-1,-1)!=\"b\")&(str_sub(Seeded_t1$Seed,-1,-1)!=\"c\"))\nSeeded_t1$Seed<-str_sub(Seeded_t1$Seed,1,2)\nSeeded_t2$Region<-str_sub(Seeded_t2$Seed,1,1)\nSeeded_t2$Seed<-str_sub(Seeded_t2$Seed,2,str_length(Seeded_t2$Seed))\nSeeded_t2<-subset(Seeded_t2,(str_sub(Seeded_t2$Seed,-1,-1)!=\"b\")&(str_sub(Seeded_t2$Seed,-1,-1)!=\"c\"))\nSeeded_t2$Seed<-str_sub(Seeded_t2$Seed,1,2)\n\nSeeded_t<-rbind(Seeded_t1,Seeded_t2)\nSeeded_t$TotScore <- as.numeric(Seeded_t$WFinalScore + Seeded_t$LFinalScore)","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"e4e12a2d-96f7-4fa1-bb8e-a926868b1413","_cell_guid":"50feb29f-b09a-4368-bab6-fb9dc2355977","trusted":true},"cell_type":"markdown","source":"After having isolated each match and calculated its total score, we compute the averages for each seed."},{"metadata":{"_uuid":"dfa9ee6e-ab0b-4736-a0ec-af580e4e1471","_cell_guid":"efbf67d0-b89b-4176-8c00-c6d237c8af2a","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"#Mean of points in game, per seed (sum )\nSeeded_t$Seed<-as.numeric(Seeded_t$Seed)\nsds<-seq(1,16)\nmeans_Seed<-c()\nfor (i in sds) {\n  means_Seed[i]=mean(filter(Seeded_t,Seeded_t$Seed==i)$TotScore)\n}\nsuppressMessages(print(data.frame(sds,means_Seed) %>%\n  ggplot(aes(sds,means_Seed)) + geom_point() + expand_limits(y=c(0,200)) + geom_smooth(method=\"lm\", se=FALSE, color=\"red\")))","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"13d64a3e-19a9-41c3-b400-bcf464f9213f","_cell_guid":"84be021f-7331-461f-9125-55fef505fbf0","trusted":true},"cell_type":"markdown","source":"Surprisingly, we see that this average is pretty much constant over all seeds! We then consider that the two scenarios described previously would present themselves through a high variance for higher seeds. Alternatively, perhaps the unpredictability of teams with a lower seed could increase the standard error. However, we notice that again, that there seems to be no clear trend in either direction based on our analysis."},{"metadata":{"_uuid":"3988428e-06f7-4eef-b7c7-6f7fc3a6e497","_cell_guid":"2907e5b1-eca1-414e-a91e-93e6d95b9c14","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"stds_Seed<-c()\nfor (i in sds) {\n  stds_Seed[i]=sd(filter(Seeded_t,Seeded_t$Seed==i)$TotScore) \n}\nsuppressMessages(print(data.frame(sds,stds_Seed) %>%\n  ggplot(aes(sds,stds_Seed)) + geom_point() + expand_limits(y=c(0,30))+ geom_smooth(method=\"lm\", se=FALSE, color=\"green\")))","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"e719d4c3-1344-4bc7-b252-117590232dc1","_cell_guid":"024fc16e-fc3a-4878-afaf-07a0004356af","trusted":true},"cell_type":"markdown","source":"We have looked at the total points scored in the game, which seemed to be relatively consistent across the board. But maybe that is not the case for each individual team."},{"metadata":{"_uuid":"81e8a2c7-aa9d-4a46-826e-b39b8b2178a8","_cell_guid":"d6f5b175-a43c-424b-8f93-ac8793973080","trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"#check by teams\nTeams<-Teams1 %>% merge(tourney_seeds, by.x=c(\"Season\",\"WTeamID\"),by.y = c(\"Season\",\"TeamID\"))\nnames(Teams)[names(Teams)==\"Seed\"]<-\"WSeed\"\nTeams<-Teams %>% merge(tourney_seeds, by.x=c(\"Season\",\"LTeamID\"),by.y = c(\"Season\",\"TeamID\"))\nnames(Teams)[names(Teams)==\"Seed\"]<-\"LSeed\"\n\nTeams$WRegion<-str_sub(Teams$WSeed,1,1)\nTeams$WSeed<-str_sub(Teams$WSeed,2,str_length(Teams$WSeed))\nTeams<-subset(Teams,(str_sub(Teams$WSeed,-1,-1)!=\"b\")&(str_sub(Teams$WSeed,-1,-1)!=\"c\"))\nTeams$WSeed<-str_sub(Teams$WSeed,1,2)\nTeams$LRegion<-str_sub(Teams$LSeed,1,1)\nTeams$LSeed<-str_sub(Teams$LSeed,2,str_length(Teams$LSeed))\nTeams<-subset(Teams,(str_sub(Teams$LSeed,-1,-1)!=\"b\")&(str_sub(Teams$LSeed,-1,-1)!=\"c\"))\nTeams$LSeed<-str_sub(Teams$LSeed,1,2)","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"60f357d2-4e19-432b-85df-3fbe2cf050db","_cell_guid":"e33e73f2-c6a4-4a45-bca8-7a907ffe9d0e","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"fig(17,6)\nTeams$WSeed<-as.numeric(Teams$WSeed)\nTeams$LSeed<-as.numeric(Teams$LSeed)\nmnseed<-c()\nmnswseed<-c()\nmnslseed<-c()\nfor (i in sds) {\n  mnseed[i]<-(sum(filter(Teams,Teams$WSeed==i)$WFinalScore)+sum(filter(Teams,Teams$LSeed==i)$LFinalScore))/(nrow(filter(Teams,Teams$WSeed==i))+nrow(filter(Teams,Teams$LSeed==i)))\n  mnswseed[i]=mean(filter(Teams,Teams$WSeed==i)$WFinalScore)\n  mnslseed[i]=mean(filter(Teams,Teams$LSeed==i)$LFinalScore)\n}\ndf1<-data.frame(sds,mnswseed,mnslseed)\ndf2<-tidyr::pivot_longer(df1, cols=c('mnswseed','mnslseed'), names_to='variable', values_to=\"value\")\nr1 <- lm(mnswseed ~ sds, data = df1)\nr2 <- lm(mnslseed ~sds, data = df1)\n\np1 <- data.frame(sds,mnseed) %>% ggplot(aes(sds,mnseed)) + geom_bar(stat='identity') +geom_col(fill='orange') +ggtitle(\"Mean Score per match for each seed\")+ theme(plot.title = element_text(size=14, face=\"bold\"))\np2 <- ggplot(df2, aes(sds, value, fill=variable)) + geom_bar(stat='identity', position='dodge')+ scale_fill_discrete(labels=c(\"Mean Score Lose\",\"Mean Score Win\"))+ggtitle(\"Mean Score in case of loss/win, \\nper seed\")+ theme(plot.title = element_text(size=14, face=\"bold\")) + geom_abline(slope=r2$coefficients[2],intercept = r2$coefficients[1],size=1,color='dark red')\n\ngrid.arrange(p1,p2,ncol=2)","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"7c4c6817-9059-4390-921c-3034f720c8c8","_cell_guid":"b536467a-89f0-4c09-bb94-5eb2eab60633","trusted":true},"cell_type":"markdown","source":"As expected, our analysis reveals that teams with higher seeds tend to score more on average than lower ranking teams. What is surprising, however, is that, when comparing games in which the outcome is as expected (a higher ranked seed beats a lower ranked seed), everyone seems to win with as many points! However, when a lower seeded team loses, it will have a much lower average score than when a higher seeded team loses. This can be understood by the fact that, to win, a team will require a given number of points (at least enough to beat the other team!); however, when losing, there is no limit on how little they can lose with! Teams that don't function as well will therefore tend to lose by larger margins, but will not necessarily win with smaller scores.\n\nFinally, we look at the correlation between a team's seed and its predisposition for engaging in unasisted actions - in other words, in its reliance on sparks of genius from a select subset of its players rather than the collaboration between all of its members."},{"metadata":{"_uuid":"76875933-05b9-47c0-92ca-d3fe34211681","_cell_guid":"6faacfe4-6a90-4296-9923-aeb912befad8","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"fig(8,6)\nSeeded_a <- play_by_play %>% \n  select(EventType,TeamID = EventTeamID,shot_outcome,Season, tot_score,AssistedFGM) %>%\n  filter(play_by_play$AssistedFGM!=\"None\") %>%\n  merge(tourney_seeds, by = c(\"Season\", \"TeamID\"))\n\nSeeded_a$Region<-str_sub(Seeded_a$Seed,1,1)\nSeeded_a$Seed<-str_sub(Seeded_a$Seed,2,str_length(Seeded_a$Seed))\nSeeded_a<-subset(Seeded_a,(str_sub(Seeded_a$Seed,-1,-1)!=\"b\")&(str_sub(Seeded_a$Seed,-1,-1)!=\"c\"))\nSeeded_a$Seed<-str_sub(Seeded_a$Seed,1,2)\n\nAssists <-Seeded_a %>% group_by(Seed) %>% count(AssistedFGM)\n\nfor (i in sds){\n  Assists$n[2*i-1]=(Assists$n[2*i-1])/(Assists$n[2*i-1]+Assists$n[2*i])\n  Assists$n[2*i]=1-Assists$n[2*i-1]\n}\n\nreg<-lm(n~as.numeric(Seed), data = filter(Assists,AssistedFGM!=\"Assisted\"))\n\n\nAssists %>% ggplot(aes(x=Seed , y=n, fill=AssistedFGM)) + geom_bar(stat='identity') + geom_abline(slope=reg$coefficients[2],intercept = reg$coefficients[1],size=1,color='green')","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"efa5d697-96e1-4791-9ee6-b0814115a53e","_cell_guid":"d47dacaf-106d-46d3-bf15-3331ba1340b8","trusted":true},"cell_type":"markdown","source":"As is seen above, when looking at the proportion of assisted to unassisted actions a team takes during a game, it appears that a lower seeded team will tend to rely more on unassisted plays. Intuitively, this makes sense: a higher seeded team is equipped with a complete squad of outstanding players who can work in concert to carry out powerful team plays and score in effective ways (such as the dunks we saw earlier!). However, a lower seeded team will need to hope their main player performs well on its solo plays. This also explains the higher number of long distance 3-point shots which are less effective in general and can be taken as a sign of the team running out of options during an offensive play."},{"metadata":{"_uuid":"16139440-ae1a-49ed-a47f-471c8be10afd","_cell_guid":"de271fcf-686b-4578-9a5e-5973718f3c17","trusted":true},"cell_type":"markdown","source":"## 2.2. Madness through Unpredictability"},{"metadata":{},"cell_type":"markdown","source":"As we mentioned, one of the main contributers to \"madness\" is the unpredictability of matches during the tournament. If all outcomes were guaranteed from the start, no one would enjoy watching the competition, and the name \"March Madness\" would likely not be appropriate! In order to look into what influences a team being predicted to win or lose or game, we use the [winning model of the 2018 March Madness Predictions competition](https://github.com/fakyras/ncaa_women_2018), built by [Raddar](https://www.kaggle.com/raddar), and try to evaluate what were the most important features in its decision-making. Particularly, we will try to differentiate between situations that lead to predictions of a tight game, and situations that lead to predictions of a landslide victory.\n\nWe therefore begin by creating predictions for this year's tournament, using the 2020 analytics competition data."},{"metadata":{"trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"library(dplyr)\nlibrary(xgboost)\nlibrary(lme4)\n\nregresults <- read.csv(\"../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data/MDataFiles_Stage1/MRegularSeasonDetailedResults.csv\")\nresults <- read.csv(\"../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data/MDataFiles_Stage1/MNCAATourneyDetailedResults.csv\")\nsub <- read.csv(\"../input/google-cloud-ncaa-march-madness-2020-division-1-mens-tournament/MSampleSubmissionStage1_2020.csv\")\nseeds <- read.csv(\"../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data/MDataFiles_Stage1/MNCAATourneySeeds.csv\")\n\nseeds$Seed = as.numeric(substring(seeds$Seed,2,4))\n\n\n### Collect regular season results - double the data by swapping team positions\n\nr1 = regresults[, c(\"Season\", \"DayNum\", \"WTeamID\", \"WScore\", \"LTeamID\", \"LScore\", \"NumOT\", \"WFGA\", \"WAst\", \"WBlk\", \"LFGA\", \"LAst\", \"LBlk\")]\nr2 = regresults[, c(\"Season\", \"DayNum\", \"LTeamID\", \"LScore\", \"WTeamID\", \"WScore\", \"NumOT\", \"LFGA\", \"LAst\", \"LBlk\", \"WFGA\", \"WAst\", \"WBlk\")]\nnames(r1) = c(\"Season\", \"DayNum\", \"T1\", \"T1_Points\", \"T2\", \"T2_Points\", \"NumOT\", \"T1_fga\", \"T1_ast\", \"T1_blk\", \"T2_fga\", \"T2_ast\", \"T2_blk\")\nnames(r2) = c(\"Season\", \"DayNum\", \"T1\", \"T1_Points\", \"T2\", \"T2_Points\", \"NumOT\", \"T1_fga\", \"T1_ast\", \"T1_blk\", \"T2_fga\", \"T2_ast\", \"T2_blk\")\nregular_season = rbind(r1, r2)\n\n\n### Collect tourney results - double the data by swapping team positions\n\nt1 = results[, c(\"Season\", \"DayNum\", \"WTeamID\", \"LTeamID\", \"WScore\", \"LScore\")] %>% mutate(ResultDiff = WScore - LScore)\nt2 = results[, c(\"Season\", \"DayNum\", \"LTeamID\", \"WTeamID\", \"LScore\", \"WScore\")] %>% mutate(ResultDiff = LScore - WScore)\nnames(t1) = c(\"Season\", \"DayNum\", \"T1\", \"T2\", \"T1_Points\", \"T2_Points\", \"ResultDiff\")\nnames(t2) = c(\"Season\", \"DayNum\", \"T1\", \"T2\", \"T1_Points\", \"T2_Points\", \"ResultDiff\")\ntourney = rbind(t1, t2)\n\n\n### Fit GLMM on regular season data (selected march madness teams only) - extract random effects for each team\n\nmarch_teams = select(seeds, Season, Team = TeamID)\nX =  regular_season %>% \n  inner_join(march_teams, by = c(\"Season\" = \"Season\", \"T1\" = \"Team\")) %>% \n  inner_join(march_teams, by = c(\"Season\" = \"Season\", \"T2\" = \"Team\")) %>% \n  select(Season, T1, T2, T1_Points, T2_Points, NumOT) %>% distinct()\nX$T1 = as.factor(X$T1)\nX$T2 = as.factor(X$T2)\n\nquality = list()\nfor (season in unique(X$Season)) {\n  glmm = glmer(I(T1_Points > T2_Points) ~  (1 | T1) + (1 | T2), data = X[X$Season == season & X$NumOT == 0, ], family = binomial) \n  random_effects = ranef(glmm)$T1\n  quality[[season]] = data.frame(Season = season, Team_Id = as.numeric(row.names(random_effects)), quality = exp(random_effects[,\"(Intercept)\"]))\n}\nquality = do.call(rbind, quality)\n\n\n### Regular season statistics\n\nseason_summary = \n  regular_season %>%\n  mutate(win14days = ifelse(DayNum > 118 & T1_Points > T2_Points, 1, 0),\n         last14days = ifelse(DayNum > 118, 1, 0)) %>% \n  group_by(Season, T1) %>%\n  summarize(\n    WinRatio14d = sum(win14days) / sum(last14days),\n    PointsMean = mean(T1_Points),\n    PointsMedian = median(T1_Points),\n    PointsDiffMean = mean(T1_Points - T2_Points),\n    FgaMean = mean(T1_fga), \n    FgaMedian = median(T1_fga),\n    FgaMin = min(T1_fga), \n    FgaMax = max(T1_fga), \n    AstMean = mean(T1_ast), \n    BlkMean = mean(T1_blk), \n    OppFgaMean = mean(T2_fga), \n    OppFgaMin = min(T2_fga)  \n  )\n\nseason_summary_X1 = season_summary\nseason_summary_X2 = season_summary\nnames(season_summary_X1) = c(\"Season\", \"T1\", paste0(\"X1_\",names(season_summary_X1)[-c(1,2)]))\nnames(season_summary_X2) = c(\"Season\", \"T2\", paste0(\"X2_\",names(season_summary_X2)[-c(1,2)]))\n\n\n### Combine all features into a data frame\n\ndata_matrix =\n  tourney %>% \n  left_join(season_summary_X1, by = c(\"Season\", \"T1\")) %>% \n  left_join(season_summary_X2, by = c(\"Season\", \"T2\")) %>%\n  left_join(select(seeds, Season, T1 = TeamID, Seed1 = Seed), by = c(\"Season\", \"T1\")) %>% \n  left_join(select(seeds, Season, T2 = TeamID, Seed2 = Seed), by = c(\"Season\", \"T2\")) %>% \n  mutate(SeedDiff = Seed1 - Seed2) %>%\n  left_join(select(quality, Season, T1 = Team_Id, quality_march_T1 = quality), by = c(\"Season\", \"T1\")) %>%\n  left_join(select(quality, Season, T2 = Team_Id, quality_march_T2 = quality), by = c(\"Season\", \"T2\"))\n\n\n### Prepare xgboost \n\nfeatures = setdiff(names(data_matrix), c(\"Season\", \"DayNum\", \"T1\", \"T2\", \"T1_Points\", \"T2_Points\", \"ResultDiff\"))\ndtrain = xgb.DMatrix(as.matrix(data_matrix[, features]), label = data_matrix$ResultDiff)\n\ncauchyobj <- function(preds, dtrain) {\n  labels <- getinfo(dtrain, \"label\")\n  c <- 5000 \n  x <-  preds-labels\n  grad <- x / (x^2/c^2+1)\n  hess <- -c^2*(x^2-c^2)/(x^2+c^2)^2\n  return(list(grad = grad, hess = hess))\n}\n\nxgb_parameters = \n  list(objective = cauchyobj, \n       eval_metric = \"mae\",\n       booster = \"gbtree\", \n       eta = 0.02,\n       subsample = 0.35,\n       colsample_bytree = 0.7,\n       num_parallel_tree = 10,\n       min_child_weight = 40,\n       gamma = 10,\n       max_depth = 3)\n\nN = nrow(data_matrix)\nfold5list = c(\n  rep( 1, floor(N/5) ),\n  rep( 2, floor(N/5) ),\n  rep( 3, floor(N/5) ),\n  rep( 4, floor(N/5) ),\n  rep( 5, N - 4*floor(N/5) )\n)\n\n\n### Build cross-validation model, repeated 10-times\n\niteration_count = c()\nsmooth_model = list()\n\nfor (i in 1:10) {\n  \n  ### Resample fold split\n  set.seed(i)\n  folds = list()  \n  fold_list = sample(fold5list)\n  for (k in 1:5) folds[[k]] = which(fold_list == k)\n  \n  set.seed(120)\n  xgb_cv = \n    xgb.cv(\n      params = xgb_parameters,\n      data = dtrain,\n      nrounds = 3000,\n      verbose = 0,\n      nthread = 12,\n      folds = folds,\n      early_stopping_rounds = 25,\n      maximize = FALSE,\n      prediction = TRUE\n    )\n  iteration_count = c(iteration_count, xgb_cv$best_iteration)\n  \n  ### Fit a smoothed GAM model on predicted result point differential to get probabilities\n  smooth_model[[i]] = smooth.spline(x = xgb_cv$pred, y = ifelse(data_matrix$ResultDiff > 0, 1, 0))\n  \n}\n\n\n### Build submission models\n\nsubmission_model = list()\n\nfor (i in 1:10) {\n  set.seed(i)\n  submission_model[[i]] = \n    xgb.train(\n      params = xgb_parameters,\n      data = dtrain,\n      nrounds = round(iteration_count[i]*1.05),\n      verbose = 0,\n      nthread = 12,\n      maximize = FALSE,\n      prediction = TRUE\n    )\n}\n\n\n### Run predictions\n\nsub$Season = 2019\nsub$T1 = as.numeric(substring(sub$ID,6,9))\nsub$T2 = as.numeric(substring(sub$ID,11,14))\n\nZ = sub %>% \n  left_join(season_summary_X1, by = c(\"Season\", \"T1\")) %>% \n  left_join(season_summary_X2, by = c(\"Season\", \"T2\")) %>%\n  left_join(select(seeds, Season, T1 = TeamID, Seed1 = Seed), by = c(\"Season\", \"T1\")) %>% \n  left_join(select(seeds, Season, T2 = TeamID, Seed2 = Seed), by = c(\"Season\", \"T2\")) %>% \n  mutate(SeedDiff = Seed1 - Seed2) %>%\n  left_join(select(quality, Season, T1 = Team_Id, quality_march_T1 = quality), by = c(\"Season\", \"T1\")) %>%\n  left_join(select(quality, Season, T2 = Team_Id, quality_march_T2 = quality), by = c(\"Season\", \"T2\"))\n\ndtest = xgb.DMatrix(as.matrix(Z[, features]))\n\nprobs = list()\nfor (i in 1:10) {\n  preds = predict(submission_model[[i]], dtest)\n  probs[[i]] = predict(smooth_model[[i]], preds)$y\n}\nZ$Pred = Reduce(\"+\", probs) / 10\n\n### Better be safe than sorry\nZ$Pred[Z$Pred <= 0.025] = 0.025\nZ$Pred[Z$Pred >= 0.975] = 0.975\n\n### Anomaly event happened only once before - be brave\nZ$Pred[Z$Seed1 == 16 & Z$Seed2 == 1] = 0\nZ$Pred[Z$Seed1 == 15 & Z$Seed2 == 2] = 0\nZ$Pred[Z$Seed1 == 14 & Z$Seed2 == 3] = 0\nZ$Pred[Z$Seed1 == 13 & Z$Seed2 == 4] = 0\nZ$Pred[Z$Seed1 == 1 & Z$Seed2 == 16] = 1\nZ$Pred[Z$Seed1 == 2 & Z$Seed2 == 15] = 1\nZ$Pred[Z$Seed1 == 3 & Z$Seed2 == 14] = 1\nZ$Pred[Z$Seed1 == 4 & Z$Seed2 == 13] = 1\n\npredictions<-data.frame(Z)\n","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"As we are attempting to evaluate what makes a game close or not, we choose \"stereotypical\" games from the prediction charts we have created. \"Stereotypical\" games are those which are either extremeley unbalanced or extremely close. We do this in the hope of seeing patterns emerge. In particular, we select the \"central\" 10% of predictions (games where team1 was predicted to win between 45 and 55 percent of time) and the \"extreme\" 10% of predictions (games where team1 was predicted to win either between 0 and 5 percent of times, or between 95 and 100 percent of time)."},{"metadata":{"_uuid":"21bd0879-5730-486e-a341-8198ec648add","_cell_guid":"57eb0f22-e4a0-406b-81c4-899b13abdfe4","trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"predictions$NotCloseGame <- ifelse((predictions$Pred<0.05) | (predictions$Pred>0.95),1,0)\npredictions$CloseGame <- ifelse(predictions$Pred>0.45 & predictions$Pred<0.55,1,0)\n\ninteresting_pred<-filter(predictions, predictions$NotCloseGame==1 | predictions$CloseGame==1)","execution_count":null,"outputs":[]},{"metadata":{"_uuid":"de416d23-b34a-4883-a10b-e8cbcd4078c7","_cell_guid":"481c4cbf-591a-4e56-b1f9-6777be1fd863","trusted":true},"cell_type":"markdown","source":"It's important for us to be careful here. Even though the percentages are the same, the number of games in each interval might not be. We check this below."},{"metadata":{"_uuid":"5eb00f2b-8c96-4e4e-87af-17440e5cab93","_cell_guid":"14a801de-53d2-49c3-8a55-9b1f52425849","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"print(paste0(\"There are \",sum(predictions$NotCloseGame),\" matches with win probabilities between 0% and 5%, or between 95% and 100%\"))\nprint(paste0(\"There are \",sum(predictions$CloseGame),\" matches with win probabilities between 45% and 55%\"))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"And indeed we see that there is a large difference in the number of games within each percentile! If we were working with a normal distribution of probability rates, this would be understandable. What we have here, while not exaclty a normal distribution, still has the property of having a higher density of games predicted in the center percentiles (see below). "},{"metadata":{"_uuid":"02179d5e-46c5-4811-815b-9aafd371f64b","_cell_guid":"1fc261aa-98e2-41fd-84db-4f243b26ab0b","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"fig(8,6)\nggplot(predictions, aes(Pred)) + geom_density(fill=\"pink\") + geom_vline(xintercept=0.05) + xlab(\"Winning probability distribution\") + geom_vline(xintercept=0.95) + geom_vline(xintercept=0.45) + geom_vline(xintercept=0.55)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"To avoid any problems, we choose to instead define intervals with a similar number of games. For this, we take an arbitrary number of games (let's select 2500 games, as that value is between the two we had before), and estimate the best thresholds for the categorical boundaries such that each category will have this number of games."},{"metadata":{"_uuid":"d103a0cc-8993-4356-b4bf-aac15b691cf3","_cell_guid":"30e42d7f-6a9a-4da0-ad47-af9e15988236","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"for (d in seq(0,0.5,by=0.001)) {\n  if (sum(ifelse((predictions$Pred<d) | (predictions$Pred>(1-d)),1,0))>=2500){\n    thresh_ext=d\n    break\n  }\n}\n\nfor (d in seq(0,0.5,by=0.001)) {\n  if (sum(ifelse((predictions$Pred>(0.5-d)) & (predictions$Pred<(0.5+d)),1,0))>=2500){\n    thresh_int=d\n    break\n  }\n}\n\npredictions$NotCloseGame <- ifelse((predictions$Pred<thresh_ext) | (predictions$Pred>(1-thresh_ext)),1,0)\npredictions$CloseGame <- ifelse((predictions$Pred>(0.5-thresh_int)) & (predictions$Pred<(0.5+thresh_int)),1,0)\ninteresting_pred<-filter(predictions, predictions$NotCloseGame==1 | predictions$CloseGame==1)\n\nprint(paste0(\"We take \",100*thresh_ext,\"% of values on each side\"))\nprint(paste0(\"We take \",200*thresh_int,\"% of the central values\"))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"For each of the features of the prediction model, we then plot the corresponding densities of games (both for \"central\" and \"extreme\" games), and see what differences can be observed."},{"metadata":{"_uuid":"82dda9df-2169-45d5-b6de-5d50dc2603c4","_cell_guid":"de6fa5ff-04cc-4dad-bd12-d04d423cfd5e","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"fig(18,13)\ngrid.newpage() \npushViewport(viewport(layout = grid.layout(6, 5)))\nfor (col in (6:33)){\n  density<-ggplot(interesting_pred, aes(interesting_pred[,col], fill=factor(CloseGame)))+geom_density(alpha=0.5)+xlab(names(predictions)[col])+ guides(fill=guide_legend(title=\"Is this a close game?\"))+ scale_fill_discrete(breaks=c(\"1\",\"0\"),labels=(c(\"Yes\",\"No\")))\n  print(density, vp = viewport(layout.pos.row = 1+(col-5)%/%5, layout.pos.col = 1+(col-5)%%5))\n}\n\ndensity<-ggplot(interesting_pred, aes(interesting_pred[,34], fill=factor(CloseGame)))+geom_density(alpha=0.5)+xlab(names(predictions)[34])+ guides(fill=guide_legend(title=\"Is this a close game?\"))+ scale_fill_discrete(breaks=c(\"1\",\"0\"),labels=(c(\"Yes\",\"No\")))\nprint(density, vp = viewport(layout.pos.row = 1, layout.pos.col = 1))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Looking at these results, for most of the features, there doesn't appear to be a significant difference between a very close game and a landslide victory. The only feature that seems to directly influence the prediction is the seed. However, it is interesting to notice that, while a team having a high seed almost always means that it will win, the reverse is not true. Teams with low seeds do not have such a high number of uneven games. We can explain this by the fact that, while a higher seeded team will need to always perform well to achieve great results, what characterizes a lower seeded team is not necessarily its repeated bad performances, but rather its inconsistency. This result is also reflected in the \"quality_march\" features (representing the estimated strength of each team during the last month before the competition), as high quality teams create games which are less close in general.\n\nHowever, we must also notice that the previous analysis only takes into account features concerning particular teams, while what should matter is actually the difference between the two teams! We set out to evaluate this below. Here, the x-axis represents the absolute difference between each team in a given match, for the considered feature. In particular, this means the density concentrated to the left of the plot indicates a low difference in terms of that feature."},{"metadata":{"_uuid":"f66c81d4-31d8-4d1d-a66f-d8401d7c7832","_cell_guid":"89b9ac5d-5478-4b86-8aa2-912a5d5a6f73","trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"fig(18,13)\ngrid.newpage() \npushViewport(viewport(layout = grid.layout(5, 3)))\nfor (col in (6:17)){\n  density<-ggplot(interesting_pred, aes(abs(interesting_pred[,col]-interesting_pred[,col+12]), fill=factor(CloseGame)))+geom_density(alpha=0.5)+xlab(str_sub(names(predictions)[col],-str_length(names(predictions)[col])+3,-1))+ guides(fill=guide_legend(title=\"Is this a close game?\"))+ scale_fill_discrete(breaks=c(\"1\",\"0\"),labels=(c(\"Yes\",\"No\")))\n  print(density, vp = viewport(layout.pos.row = 1+(col-5)%/%3, layout.pos.col = 1+(col-5)%%3))\n}\n\ndensity<-ggplot(interesting_pred, aes(abs(interesting_pred[,30]-interesting_pred[,31]), fill=factor(CloseGame)))+geom_density(alpha=0.5)+xlab(names(predictions[32]))+ guides(fill=guide_legend(title=\"Is this a close game?\"))+ scale_fill_discrete(breaks=c(\"1\",\"0\"),labels=(c(\"Yes\",\"No\")))\nprint(density, vp = viewport(layout.pos.row = 5, layout.pos.col = 2))\n\ndensity<-ggplot(interesting_pred, aes(abs(interesting_pred[,33]-interesting_pred[,34]), fill=factor(CloseGame)))+geom_density(alpha=0.5)+xlab(str_sub(names(predictions)[33],1,str_length(names(predictions)[33])-3))+ guides(fill=guide_legend(title=\"Is this a close game?\"))+ scale_fill_discrete(breaks=c(\"1\",\"0\"),labels=(c(\"Yes\",\"No\")))\nprint(density, vp = viewport(layout.pos.row = 1, layout.pos.col = 1))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Here, we see that in most cases, the difference in particular features does not sufficiently explain the decision of the predictor. On the other hand, apart from the seed difference and team quality, which we have already identified as highly influential in terms of the predictions, we also see that the difference in average number of points is a good indicator of which way a game will tip. This fits with our basic intuition, and with the results seen in the previous section where we saw that higher seeded teams tend to score a higher number of points!\n\nIn terms of madness, these results do show how unpredictable this whole tournament is. Most of the indicators we would use to characterize teams are not effecient in estimating the winner of a given match. That our analysis reinforces the underlying unpredictability of the games also shows how unique and exciting this period of time is for NCAA fans looking for exitement and a good gamble!"},{"metadata":{},"cell_type":"markdown","source":"## 2.3. Entertainment Due to the Closeness of the Games"},{"metadata":{},"cell_type":"markdown","source":"Once again, the purpose of using objective data in Part 1 is to investigate the entertainment due to the play-by-play actions during a game and the ultimate closeness of a match. Those who attend a nail-biter experience the amazing tension generated by the suspense of not knowing the outcome. Those who attend a game that has an outcome that is basically known from the start can still have fun but don't experience the same heightened \"madness\" that comes from a close match. Unpredictability is magic in the sporting world. As the game moves on, the spectators identify themselves with the players of their favorite team, syncing their eyes, thoughts, and even their breath! When immersed in this type of situation, any single action can be decisive, and the beauty is that it can come from both sides of the court! Complaining, screaming, standing up: these are the natural manifestations of the \"madness\" of a close basketball game.\n\nHere, we want to obtain a better understanding of the influence of the seed difference on the closeness of a game.\n\nA common assumption is that the closeness of a play is only dependent of the seed differences: when they are high, the game is not close and its results can be inferred even before the game actually takes place, and when they are low, the game is intense throughout the play period. In other words, if suspense is the main driver of the entertainment, madness can only happen in matches between closely seeded teams (whether that's two higher seeded teams facing off or two lower seeded teams going head to head). But is this assumption true? Which metrics should be used to quantify the closeness of a game? How does the difference in seeds drive the closeness throughout a game? And does the trend remain constant over the years or evolve with each season?\n\nThese questions will be addressed by continuing to read on. Specifically, we are going to assess the validity of this assuumed trend with three metrics associated with the closeness of a given game: the number of leadership \"switches,\" the last moment the winning team experiences an equal or a lower score than its opponent, and the history of the score range. While it is always possible to explore more complex and subtle metrics, we believe these three are able to capture the necessary information and allow us to easily interpret the main features of the closeness of a game.\n\nThis part is divided into two subparts. First, we will describe how we used the NCAA dataset for the Men's competition to build a dataset from which to gather data for a given game (the seed difference of the team involved as well as the three metrics described above). We will describe the case for the season 2015 first which can be scaled into a global routine involving all the seasons. Secondly, we will use the results obtained to evaluate the initial assumption above."},{"metadata":{"_kg_hide-input":true,"_kg_hide-output":true,"trusted":true},"cell_type":"code","source":"library(zoo)\n\nyextract <- function(string){ \nstr_sub(string, -8,-5)\n} \n\n\n\nMEventsfile=\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2/MEvents2015.csv\" ####################### CAN BE ADAPTED\nTourneySeedfile=\"../input/march-madness-analytics-2020/2020DataFiles/2020DataFiles/2020-Mens-Data/MDataFiles_Stage1/MNCAATourneySeeds.csv\"  \ninfomatch <- read.csv(MEventsfile,stringsAsFactors = FALSE)\n\nSeasonConsidered=as.numeric(yextract(MEventsfile))\nseeds <- read.csv(TourneySeedfile, stringsAsFactors = FALSE)\n","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"### Step 1 : Building a data set with associated the three closeness metric for a given game\n\nTo achieve this goal, we have exploited the Event files which contain the time history play-by-play. These files do not strictly represent the time history of a play, but do contain all the relevant information to reconstruct the time history of a given game. More specifically, we have used the Season, the Day play, and the Winning and Losing Team ID to uniquely identify a play. Then, we have linked this play with its team seed difference, which can be derived using the Tourney seed File.\n\nPractically, two tables have been built: (1) recap_SC which identifies with MatchID all the games during the season with their associated difference of seeds and (2) game_SC which includes all the time history of the MatchID game during the season.\n"},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"numextract <- function(string){ \nstr_extract(string, \"\\\\-*\\\\d+\\\\.*\\\\d*\")\n} \n## Create recap_SC (SC= Season Considered)\n## Table with all the games during the season. Contains the difference of Seeds for each match\nseeds_SC=subset(seeds,Season==SeasonConsidered)\nmysample <- infomatch %>% select(\"Season\",\"WTeamID\",\"LTeamID\",\"DayNum\")\nmysample=unique(mysample)\n\nrecap_SC=merge(mysample,seeds_SC,by.x=\"WTeamID\",by.y=\"TeamID\")\nrecap_SC=select(recap_SC,\"Season\"=\"Season.x\",\"WSeed\"=\"Seed\",\"WTeamID\",\"LTeamID\",\"DayNum\")\nrecap_SC=merge(recap_SC,seeds_SC,by.x=\"LTeamID\",by.y=\"TeamID\")\nrecap_SC=select(recap_SC,\"Season\"=\"Season.x\",\"DayNum\",\"WTeamID\",\"LTeamID\",\"WSeed\",\"LSeed\"=\"Seed\")\nrecap_SC$DiffSeed=abs(as.numeric(numextract(recap_SC$WSeed))-as.numeric(numextract(recap_SC$LSeed)))\nrecap_SC=recap_SC[order(recap_SC$WTeamID),]\nrecap_SC$MatchID <- seq.int(nrow(recap_SC))\n\n## Create game_SC (SC= Season Considered)\n## Table with all the history of the game during the season.  Associated with Match ID\nbuffer=select(infomatch,\"Season\",\"DayNum\",\"WTeamID\",\"LTeamID\",\"WFinalScore\",\"LFinalScore\",\"WCurrentScore\",\"LCurrentScore\",\"ElapsedSeconds\")\ngame_SC=merge(buffer,recap_SC,by=c(\"Season\",\"DayNum\",\"WTeamID\",\"LTeamID\"))\ngame_SC=select(game_SC,\"MatchID\",\"WTeamID\",\"LTeamID\",\"WFinalScore\",\"LFinalScore\",\"WCurrentScore\",\"LCurrentScore\",\"ElapsedSeconds\")\ngame_SC=game_SC[order(game_SC$WTeamID,game_SC$MatchID,game_SC$ElapsedSeconds),]\ngame_SC[\"DiffCurrentScore\"]=game_SC$WCurrentScore-game_SC$LCurrentScore\ngame_SC=unique(game_SC)\n\ngame_SC %>% head (5)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Once this table is built, we will use it to compute, for each play, the three metrics described above.\n\nThe first metric represents the number of leadership switches, Nb_Switch. In other words, the number of times throughout a game the winning team switches. This can be inferred by looking at the sign of the score difference between the team one and team two, and counting the number of times the sign goes from positive to negative or from 0 to negative. Thus, Nb_Switch will count the number of times one team changed from winning (with a higher or the same score as the other team) to losing (with a lower score than the other team).\n\nThe second metric is the last moment the winning team experiences an equal or a lower score than its opponent, LastSwitch. This metric can estimated from the last moment the score difference is either null or negative. Since the data provided did not have the same period for each game, we have normalized the latter in our plots.\n\nThe third and last metric gives an indication of the narrowness of the score range, AUC. It derived from the area of the time history of the score difference. The more imbalanced is the score, the higher AUC will be. Conversely, if the score difference is confined within small range, the AUC will be low.\n\nTo clearly understand what these metrics reveal, we have illustrated in the code below four basic game scenarios. We display the results on a table with the metrics defined above.  "},{"metadata":{"trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"fig(18,14)\ngrid.newpage() \npushViewport(viewport(layout = grid.layout(3, 2)))\ntest_recap_SC=data.frame(MatchID=c(1,2,3,4,5),DiffSeed=c(0,10,5,1,2))\ntest_game_SC=data.frame(MatchID=c(rep(1,10),rep(2,10),rep(3,10),rep(4,10),rep(5,10)),DiffCurrentScore=c(rep(0,10),c(0:9),c(-1,1,-1,1,-1,1,-1,1,-1,1),c(1,0,1,0,0,0,0,0,0,0),c(1,0,-1,0,1,0,1,1,1,1)),ElapsedSeconds=c(c(10,20,30,40,50,60,70,80,90,100),c(10,20,30,40,50,60,70,80,90,100),c(10,20,30,40,50,60,70,80,90,100),c(10,20,30,40,50,60,70,80,90,100),c(10,20,30,40,50,60,70,80,90,100)))\n\ntest_result_SC=data.frame(MatchID=test_recap_SC$MatchID,DiffSeed=test_recap_SC$DiffSeed)\n\nc=0\nfor (gameID in test_result_SC$MatchID){\n    c=c+1\n    my_match=subset(test_game_SC, MatchID==gameID)\n    x <- my_match$ElapsedSeconds\n    y <- abs(my_match$DiffCurrentScore)\n    id <- order(x)\n    AUC <- sum(diff(x[id])*rollmean(y[id],2))\n    Nb_Switch=sum(diff(sign(my_match$DiffCurrentScore)) != 0)\n\n    Sign=sign(my_match$DiffCurrentScore)\n\n    Is_last=1\n    count_lose_leadership=0\n\n    for (id_Sign in 1:length(Sign)){\n    if (Sign[id_Sign]<=0){\n      Is_last=id_Sign\n    }\n    if (id_Sign<length(Sign) & Sign[id_Sign]>=0 & Sign[id_Sign+1]<0){\n      count_lose_leadership=count_lose_leadership+1\n    }\n    }\n\n    LastSwitch=my_match$ElapsedSeconds[Is_last] ## LastSwitch represents the last moment where the W team has the same OR a lower score than the L team\n    Nb_Switch=count_lose_leadership ## Nb_Switch counts the number of time the W team loses the leadership , ie 0 -> Negative diff OR Positive diff -> Negatif diff\n    test_result_SC$Nb_Switch[gameID]=Nb_Switch\n    test_result_SC$AUC[gameID]=AUC\n    test_result_SC$LastSwitch[gameID]=LastSwitch\n\n\n    plot=ggplot(data = my_match, aes(x = ElapsedSeconds))+geom_point(aes(y = DiffCurrentScore), color = \"darkred\") +geom_hline(yintercept=0, color=\"orange\", size=1) +geom_vline(xintercept=max(max(my_match$ElapsedSeconds))/3, color=\"orange\", size=1)+ geom_vline(xintercept=2*max(max(my_match$ElapsedSeconds))/3, color=\"orange\", size=1)\n    print(plot,vp = viewport(layout.pos.row = 1+(c-1)%/%2, layout.pos.col =1+(c+1)%%2))\n\n}\ntest_result_SC","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Now that we know what we are computing, we can implement these metrics for each game:"},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"#DISPLAY\n### Create result_SC.\n### For each game, the area under the curve, the number of winner Switch and the time associated with the Last Switch\nresult_SC=data.frame(Season=SeasonConsidered,MatchID=recap_SC$MatchID,DiffSeed=recap_SC$DiffSeed)\n\nfor (gameID in result_SC$MatchID){\n  my_match=subset(game_SC, MatchID==gameID)\n  x <- my_match$ElapsedSeconds\n  y <- abs(my_match$DiffCurrentScore)\n  id <- order(x)\n  AUC <- sum(diff(x[id])*rollmean(y[id],2))\n  \n  Sign=sign(my_match$DiffCurrentScore)\n  Is_last=1\n  count_lose_leadership=0\n\n  for (id_Sign in 1:length(Sign)){\n    if (Sign[id_Sign]<=0){\n      Is_last=id_Sign\n    }\n    if (id_Sign<length(Sign) & Sign[id_Sign]>=0 & Sign[id_Sign+1]<0){\n      count_lose_leadership=count_lose_leadership+1\n    }\n  }\n  \n  LastSwitch=my_match$ElapsedSeconds[Is_last]/my_match$ElapsedSeconds[length(my_match$ElapsedSeconds)] ## LastSwitch represents the last moment where the W team has the same OR a lower score than the L team\n  Nb_Switch=count_lose_leadership ## Nb_Switch counts the number of time the W team lose the leadership , ie 0 -> Negative diff OR Positive diff -> Negatif diff\n  result_SC$Nb_Switch[gameID]=Nb_Switch\n  result_SC$AUC[gameID]=AUC\n  result_SC$LastSwitch[gameID]=LastSwitch\n}\n\nresult_SC %>%head(5)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"A record of the time history of each game can be made to better understand any outliers or surprising upcoming results."},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"grid.newpage() \npushViewport(viewport(layout = grid.layout(2, 2)))\nk=0\nwhile (k<4){\nk=k+1\ngameID<-result_SC$MatchID[k]\nmy_match=subset(game_SC, MatchID==gameID)\n# ggplot(data = my_match, aes(x = ElapsedSeconds))+geom_line(aes(y = WCurrentScore), color = \"darkred\") + geom_line(aes(y = LCurrentScore), color=\"steelblue\", linetype=\"twodash\")\nplot=ggplot(data = my_match, aes(x = ElapsedSeconds))+geom_point(aes(y = DiffCurrentScore), color = \"darkred\") +geom_hline(yintercept=0, color=\"orange\", size=1) +geom_vline(xintercept=max(max(my_match$ElapsedSeconds))/3, color=\"orange\", size=1)+ geom_vline(xintercept=2*max(max(my_match$ElapsedSeconds))/3, color=\"orange\", size=1)\nprint(plot,vp = viewport(layout.pos.row = 1+(k-1)%/%2, layout.pos.col =1+(k+1)%%2))    \n}\n","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Finally, we gather for a given season the three metrics per play:\n"},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"fig(18,5)\ngrid.newpage() \npushViewport(viewport(layout = grid.layout(1, 3)))\ns2015=result_SC\ng1 <- ggplot(data=s2015, aes(s2015$DiffSeed, s2015$Nb_Switch))\ng1<-g1 +labs(subtitle=\"Count how many times the winner loses leadership\", y=\"Number of times\", x=\"Seeds difference between the teams\",  title=\"Winner loss of score leadership per game 2015\")+geom_point()\nprint(g1,vp = viewport(layout.pos.row = 1, layout.pos.col =1))\ng2 <- ggplot(data=s2015,aes(s2015$DiffSeed, s2015$LastSwitch))\ng2<-g2  +labs(subtitle=\"Last Moment where the final winner has a score equal or lower than its opponent's\",  y=\"Game period (%)\", x=\"Seeds difference between the teams\",title=\"Game Leadership for the season 2015\")+geom_hline(yintercept=1/3, color=\"orange\", size=1)+ geom_hline(yintercept=2/3, color=\"orange\", size=1)+geom_point()\nprint(g2,vp = viewport(layout.pos.row = 1, layout.pos.col =2))\ng3 <- ggplot(data=s2015, aes(s2015$DiffSeed, s2015$AUC))\ng3<-g3 + labs(subtitle=\"Area under the curve\", y=\"AUC\", x=\"Seeds difference between the teams\", title=\"Closiness of the results for the season 2015\")+geom_point(aes(color=\"game\"))\nprint(g3,vp = viewport(layout.pos.row = 1, layout.pos.col =3))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Here we have presented the case of the 2015 season. Again, this routine can be easily scaled by incorporating it into a loop which iterates over all available seasons."},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"df_total = data.frame()\nfor (MEventsfile in c(\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2/MEvents2015.csv\",\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2/MEvents2016.csv\",\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2/MEvents2017.csv\",\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2/MEvents2018.csv\",\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2/MEvents2019.csv\")){\n \n## Read the file\ninfomatch <- read.csv(MEventsfile,stringsAsFactors = FALSE)\nSeasonConsidered=as.numeric(yextract(MEventsfile))\n\n## Create recap_SC (SC= Season Considered)\n## Table with all the games during the season. Contains the difference of Seeds for each match\nseeds_SC=subset(seeds,Season==SeasonConsidered)\nmysample <- infomatch %>% select(\"Season\",\"WTeamID\",\"LTeamID\",\"DayNum\")\nmysample=unique(mysample)\n\nrecap_SC=merge(mysample,seeds_SC,by.x=\"WTeamID\",by.y=\"TeamID\")\nrecap_SC=select(recap_SC,\"Season\"=\"Season.x\",\"WSeed\"=\"Seed\",\"WTeamID\",\"LTeamID\",\"DayNum\")\nrecap_SC=merge(recap_SC,seeds_SC,by.x=\"LTeamID\",by.y=\"TeamID\")\nrecap_SC=select(recap_SC,\"Season\"=\"Season.x\",\"DayNum\",\"WTeamID\",\"LTeamID\",\"WSeed\",\"LSeed\"=\"Seed\")\nrecap_SC$DiffSeed=abs(as.numeric(numextract(recap_SC$WSeed))-as.numeric(numextract(recap_SC$LSeed)))\nrecap_SC=recap_SC[order(recap_SC$WTeamID),]\nrecap_SC$MatchID <- seq.int(nrow(recap_SC))\n\n## Create game_SC (SC= Season Considered)\n## Table with all the history of the game during the season.  Associated with Match ID\nbuffer=select(infomatch,\"Season\",\"DayNum\",\"WTeamID\",\"LTeamID\",\"WFinalScore\",\"LFinalScore\",\"WCurrentScore\",\"LCurrentScore\",\"ElapsedSeconds\")\ngame_SC=merge(buffer,recap_SC,by=c(\"Season\",\"DayNum\",\"WTeamID\",\"LTeamID\"))\ngame_SC=select(game_SC,\"MatchID\",\"WTeamID\",\"LTeamID\",\"WFinalScore\",\"LFinalScore\",\"WCurrentScore\",\"LCurrentScore\",\"ElapsedSeconds\")\ngame_SC=game_SC[order(game_SC$WTeamID,game_SC$MatchID,game_SC$ElapsedSeconds),]\ngame_SC[\"DiffCurrentScore\"]=game_SC$WCurrentScore-game_SC$LCurrentScore\ngame_SC=unique(game_SC)\n\n### Create result_SC.\n### For each game, the area under the curve, the number of winner Switch and the time associated with the Last Switch\nresult_SC=data.frame(Season=SeasonConsidered,MatchID=recap_SC$MatchID,DiffSeed=recap_SC$DiffSeed)\n\nfor (gameID in result_SC$MatchID){\n  my_match=subset(game_SC, MatchID==gameID)\n  x <- my_match$ElapsedSeconds\n  y <- abs(my_match$DiffCurrentScore)\n  id <- order(x)\n  AUC <- sum(diff(x[id])*rollmean(y[id],2))\n  \n  Sign=sign(my_match$DiffCurrentScore)\n  Is_last=1\n  count_lose_leadership=0\n\n  for (id_Sign in 1:length(Sign)){\n    if (Sign[id_Sign]<=0){\n      Is_last=id_Sign\n    }\n    if (id_Sign<length(Sign) & Sign[id_Sign]>=0 & Sign[id_Sign+1]<0){\n      count_lose_leadership=count_lose_leadership+1\n    }\n  }\n  \n  LastSwitch=my_match$ElapsedSeconds[Is_last]/my_match$ElapsedSeconds[length(my_match$ElapsedSeconds)] ## LastSwitch represents the last moment where the W team has the same OR a lower score than the L team\n  Nb_Switch=count_lose_leadership ## Nb_Switch counts the number of time the W team lose the leadership , ie 0 -> Negative diff OR Positive diff -> Negatif diff\n  result_SC$Nb_Switch[gameID]=Nb_Switch\n  result_SC$AUC[gameID]=AUC\n  result_SC$LastSwitch[gameID]=LastSwitch\n  df <- data.frame(result_SC)\n}\n\n    \n    df_total <- rbind(df_total,df)\n\n} #final for\n\ns2015=subset(df_total,df_total$Season==2015)\ns2016=subset(df_total,df_total$Season==2016)\ns2017=subset(df_total,df_total$Season==2017)\ns2018=subset(df_total,df_total$Season==2018)\ns2019=subset(df_total,df_total$Season==2019)\n\nfig(18,25)\ngrid.newpage() \npushViewport(viewport(layout = grid.layout(5, 3)))\n\ng1 <- ggplot(data=s2015, aes(s2015$DiffSeed, s2015$Nb_Switch))\ng1<-g1 +labs(subtitle=\"Count how many times the winner loses leadership\", y=\"Number of times\", x=\"Seeds difference between the teams\",  title=\"Winner loss of score leadership per game 2015\")+geom_point()\nprint(g1,vp = viewport(layout.pos.row = 1, layout.pos.col =1))\ng2 <- ggplot(data=s2015,aes(s2015$DiffSeed, s2015$LastSwitch))\ng2<-g2  +labs(subtitle=\"Last Moment where the final winner has a score equal or lower than its opponent's\",  y=\"Game period (%)\", x=\"Seeds difference between the teams\",title=\"Game Leadership for the season 2015\")+geom_hline(yintercept=1/3, color=\"orange\", size=1)+ geom_hline(yintercept=2/3, color=\"orange\", size=1)+geom_point()\nprint(g2,vp = viewport(layout.pos.row = 1, layout.pos.col =2))\ng3 <- ggplot(data=s2015, aes(s2015$DiffSeed, s2015$AUC))\ng3<-g3 + labs(subtitle=\"Area under the curve\", y=\"AUC\", x=\"Seeds difference between the teams\", title=\"Closiness of the results for the season 2015\")+geom_point(aes(color=\"game\"))\nprint(g3,vp = viewport(layout.pos.row = 1, layout.pos.col =3))\n\ng1 <- ggplot(data=s2016, aes(s2016$DiffSeed, s2016$Nb_Switch))\ng1<-g1 +labs(subtitle=\"Count how many times the winner loses leadership\", y=\"Number of times\", x=\"Seeds difference between the teams\",  title=\"Winner loss of score leadership per game 2016\")+geom_point()\nprint(g1,vp = viewport(layout.pos.row = 2, layout.pos.col =1))\ng2 <- ggplot(data=s2016,aes(s2016$DiffSeed, s2016$LastSwitch))\ng2<-g2  +labs(subtitle=\"Last Moment where the final winner has a score equal or lower than its opponent's\",  y=\"Game period (%)\", x=\"Seeds difference between the teams\",title=\"Game Leadership for the season 2016\")+geom_hline(yintercept=1/3, color=\"orange\", size=1)+ geom_hline(yintercept=2/3, color=\"orange\", size=1)+geom_point()\nprint(g2,vp = viewport(layout.pos.row = 2, layout.pos.col =2))\ng3 <- ggplot(data=s2016, aes(s2016$DiffSeed, s2016$AUC))\ng3<-g3 + labs(subtitle=\"Area under the curve\", y=\"AUC\", x=\"Seeds difference between the teams\", title=\"Closiness of the results for the season 2016\")+geom_point(aes(color=\"game\"))\nprint(g3,vp = viewport(layout.pos.row = 2, layout.pos.col =3))\n\ng1 <- ggplot(data=s2017, aes(s2017$DiffSeed, s2017$Nb_Switch))\ng1<-g1 +labs(subtitle=\"Count how many times the winner loses leadership\", y=\"Number of times\", x=\"Seeds difference between the teams\",  title=\"Winner loss of score leadership per game 2017\")+geom_point()\nprint(g1,vp = viewport(layout.pos.row = 3, layout.pos.col =1))\ng2 <- ggplot(data=s2017,aes(s2017$DiffSeed, s2017$LastSwitch))\ng2<-g2  +labs(subtitle=\"Last Moment where the final winner has a score equal or lower than its opponent's\",  y=\"Game period (%)\", x=\"Seeds difference between the teams\",title=\"Game Leadership for the season 2017\")+geom_hline(yintercept=1/3, color=\"orange\", size=1)+ geom_hline(yintercept=2/3, color=\"orange\", size=1)+geom_point()\nprint(g2,vp = viewport(layout.pos.row = 3, layout.pos.col =2))\ng3 <- ggplot(data=s2017, aes(s2017$DiffSeed, s2017$AUC))\ng3<-g3 + labs(subtitle=\"Area under the curve\", y=\"AUC\", x=\"Seeds difference between the teams\", title=\"Closiness of the results for the season 2017\")+geom_point(aes(color=\"game\"))\nprint(g3,vp = viewport(layout.pos.row = 3, layout.pos.col =3))\n\ng1 <- ggplot(data=s2018, aes(s2018$DiffSeed, s2018$Nb_Switch))\ng1<-g1 +labs(subtitle=\"Count how many times the winner loses leadership\", y=\"Number of times\", x=\"Seeds difference between the teams\",  title=\"Winner loss of score leadership per game 2018\")+geom_point()\nprint(g1,vp = viewport(layout.pos.row = 4, layout.pos.col =1))\ng2 <- ggplot(data=s2018,aes(s2018$DiffSeed, s2018$LastSwitch))\ng2<-g2  +labs(subtitle=\"Last Moment where the final winner has a score equal or lower than its opponent's\",  y=\"Game period (%)\", x=\"Seeds difference between the teams\",title=\"Game Leadership for the season 2018\")+geom_hline(yintercept=1/3, color=\"orange\", size=1)+ geom_hline(yintercept=2/3, color=\"orange\", size=1)+geom_point()\nprint(g2,vp = viewport(layout.pos.row = 4, layout.pos.col =2))\ng3 <- ggplot(data=s2018, aes(s2018$DiffSeed, s2018$AUC))\ng3<-g3 + labs(subtitle=\"Area under the curve\", y=\"AUC\", x=\"Seeds difference between the teams\", title=\"Closiness of the results for the season 2018\")+geom_point(aes(color=\"game\"))\nprint(g3,vp = viewport(layout.pos.row = 4, layout.pos.col =3))\n\ng1 <- ggplot(data=s2019, aes(s2019$DiffSeed, s2019$Nb_Switch))\ng1<-g1 +labs(subtitle=\"Count how many times the winner loses leadership\", y=\"Number of times\", x=\"Seeds difference between the teams\",  title=\"Winner loss of score leadership per game 2019\")+geom_point()\nprint(g1,vp = viewport(layout.pos.row = 5, layout.pos.col =1))\ng2 <- ggplot(data=s2019,aes(s2019$DiffSeed, s2019$LastSwitch))\ng2<-g2  +labs(subtitle=\"Last Moment where the final winner has a score equal or lower than its opponent's\",  y=\"Game period (%)\", x=\"Seeds difference between the teams\",title=\"Game Leadership for the season 2019\")+geom_hline(yintercept=1/3, color=\"orange\", size=1)+ geom_hline(yintercept=2/3, color=\"orange\", size=1)+geom_point()\nprint(g2,vp = viewport(layout.pos.row = 5, layout.pos.col =2))\ng3 <- ggplot(data=s2019, aes(s2019$DiffSeed, s2019$AUC))\ng3<-g3 + labs(subtitle=\"Area under the curve\", y=\"AUC\", x=\"Seeds difference between the teams\", title=\"Closiness of the results for the season 2019\")+geom_point(aes(color=\"game\"))\nprint(g3,vp = viewport(layout.pos.row = 5, layout.pos.col =3))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"### Step 2 : Presentation of the Results\n\n#### First Metric: Nb_switch\n\nNb_switch is plotted against the seed difference between the team with each dot representing a game.\n\nFrom an initial glance, we can divide the plot into two parts: under and over a seed difference of 9. For this first case, Nb_switch is relatively consistent with an approximate average of 12 for the 2016 season. In the second case, the Nb_switch barely attains an average of 5. In a closer loop, we can note that the high number of leadership switches are associated with a low seed difference.\n\nWe can also appreciate the overall increase of the number of leadership switch, regardless of the seed difference, as the season becomes more recent. This phenomenon is particularly visible when we considered the situation for the high seed difference situation. For example, in 2019, for the team seeded at 13 managed to take the leadership more than 10 times in 3 out of its four games, a performance three times higher than what could have observed in the past. Same trend is observed for the team seeded 15 in 2019.\n\n#### Second Metric: Last_Switch\n\nLast_Switch represents a proportion of the elapsed time and is plotted against the seed difference between the teams. The orange curves indicate the first, second, and third periods of play respectively. Once again, each dot represents a game.\n\nAs before, we see that we can divide the plot into two parts: under and over a seed difference of 9. For this first case, Last_switch spans over the possible range, concentrating round 0.8-1 for the five first seeds, regardless of the season. For the second case, Last_switch remains lower. For the 2015 season, all games with a seed difference higher than 12 have their Last_Switch under 0.25, meaning that after one quarter of the elapsed time, the winning team took the lead and retained it until the end. When we look at the most recent season, this trend changes to be more balanced: in 2019, most of the game involving high seed differences managed to keep their winning opponents at range until the last period.\n\nA closer investigation shows that Last_switch spans over the possible range for a seed difference under 9. This indicates that even for a narrow seed difference, early leadership domination can be observed. For instance, when we look at the 2018 season, there is approximately the same proportion of games with close seeds with a Last_Switch that occurs either on the first, second, or third period. In other words, for this seed difference, the moment when the leading team gains its ultimate lead cannot be directly inferred from the seed difference.\n\n#### Third Metric: AUC\n\nAUC is plotted against the seed difference between the team. Continuing the trend established previously, each dot represents a game.\n\nWe see that a narrow score range is associated with a lower seed difference. Conversely, in a high difference seed situation, AUC become higher. The curves remain similar over the season illustrated the consistency of the seed selection over the time.\n\n### Step 3 : Conclusion\n\nThis data exploration ultimately allowed us to get a better understanding of the influence of the seed difference on the closeness of a game.\n\nAs we have discussed, an intuitive assumption is that the closeness of a play is dependent only on the differences in seed of the playing teams. We wanted to assess the validity of this hypothesis with the three metrics analyzed above: the number of leadership switches, the last moment the winning team experience an equal or a lower score than its opponents, and the score closeness.\n\nThe correlation between the closeness and the seed difference has been confirmed for the large (>12) and small (<4) difference in seed. In the first case, the winning team tends to take the game leadership, quicker without considering lots of leadership change. Consequently, the range of the score becomes large. The second case, on contrary, shows that for a close game, a higher number a leadership switch, a narrow score range as well as long lasting competition is to be expected.\n\nHowever, when studying the general case (seed difference between 5 and 11) this reasoning can be misleading. In these situations, the three metrics do not show a significant trend. No conclusions can then be drawn regarding the closeness when looking at games with a seed difference in this mid-range. On top of that, the trends become less distinct as we study the more recent NCAA season. In 2018, games with a seed of 8 experience the long-lasting competition with same number of leadership switches as for the game with teams with the same seeds.\n\nSeed difference gives an indication, and only an indication, of the potential closeness of the game. In other words, if closeness is the main driver of the entertainment of a game, one may not solely rely of seed difference to define the associated madness. Tension, fear, and joy are more likely to be experienced in game associated with very low seed difference but not necessarily during a game involving team with a seed difference of 5 or 9. Our metrics then make us believe that the ultimate entertainment and madness can not be so simply predicted for a given type of game."}],"metadata":{"language_info":{"name":"python","version":"3.6.6","mimetype":"text/x-python","codemirror_mode":{"name":"ipython","version":3},"pygments_lexer":"ipython3","nbconvert_exporter":"python","file_extension":".py"},"kernelspec":{"display_name":"Python 3","language":"python","name":"python3"}},"nbformat":4,"nbformat_minor":4}