{"cells":[{"metadata":{},"cell_type":"markdown","source":"# Web of the \"Madness\": Network Approach to Basketball Analytics ","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"","execution_count":null},{"metadata":{"_uuid":"051d70d956493feee0c6d64651c6a088724dca2a","_execution_state":"idle","trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"################ LIBRARIES\n\n# general visualisation\nlibrary('ggplot2') # visualisation\nlibrary('scales') # visualisation\nlibrary('patchwork') # visualisation\nlibrary('RColorBrewer') # visualisation\nlibrary('corrplot') # visualisation\nlibrary('ggthemes') # visualisation\nlibrary('ggrepel') # visualisation\n\n# general data manipulation\nlibrary('dplyr') # data manipulation\nlibrary('readr') # input/output\nlibrary('vroom') # input/output\nlibrary('skimr') # overview\nlibrary('tibble') # data wrangling\nlibrary('tidyr') # data wrangling\nlibrary('stringr') # string manipulation\nlibrary('forcats') # factor manipulation\n\n# specific visualisation\nlibrary('alluvial') # visualisation\nlibrary('ggrepel') # visualisation\nlibrary('ggforce') # visualisation\nlibrary('ggridges') # visualisation\nlibrary('gganimate') # animations\nlibrary('GGally') # visualisation\nlibrary('ggExtra') # visualisation\nlibrary('viridis') # visualisation\nlibrary(gridExtra)\nlibrary('usmap') # geo\nlibrary(\"PerformanceAnalytics\")\nlibrary(\"pheatmap\")\nlibrary(dichromat)\nlibrary(stargazer)\n\n# specific data manipulation\nlibrary('lazyeval') # data wrangling\nlibrary('broom') # data wrangling\nlibrary('purrr') # data wrangling\nlibrary('reshape2') # data wrangling\nlibrary('rlang') # encoding\nlibrary('kableExtra') # display\nlibrary(tm)\n\n# networks\nlibrary(igraph)\nlibrary(GGally)\nlibrary(ergm)\nlibrary(intergraph)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"################ PLAY-BY-PLAY DATA\n\nplay_by_play <- data.frame()\n\n# loop through each seasons PlayByPlay folders and read in in the play by play files\nlist_files <- list.files(\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2\")\n\nfor(each in list_files[str_detect(list_files, \"MEvents\")]) {\n \n df <- read_csv(paste0(\"../input/march-madness-analytics-2020/MPlayByPlay_Stage2/\", each))\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 issed)\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 \n\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 # df <- df %>% \\\n # mutate(fg_type = ifelse(EventType %in% FGA, EventType, ifelse(EventType2 %in% FGA, EventType2, \"Unknown\")))\n \n # create final output\n df <- df %>% ungroup()\n play_by_play <- bind_rows(play_by_play, df)\n print(each)\n \n rm(df); gc()\n}\n\n\n\n### Load preprocessed play-by-play data\n### You can obtain it with script above\n# play_by_play <- readRDS(\"../input/playbyplay-data-20152019/play_by_play2015_19.rds\")\n\n# Select Season 2019\nplay_by_play <- play_by_play[play_by_play$Season == 2019,]","execution_count":null,"outputs":[]},{"metadata":{"trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"################ BASIC DATA\n\n# setwd(\"../input/march-madness-analytics-2020\")\n\n# Load Players data\ndf_Players <- read.csv('../input/march-madness-analytics-2020/MPlayByPlay_Stage2/MPlayers.csv')\n\n# Load Team data\ndf_Teams <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MTeams.csv')\ndf_TeamCoaches <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MTeamCoaches.csv')\ndf_TeamConferences <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MTeamConferences.csv')\ndf_TeamSpellings <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MTeamSpellings.csv')\n\n# Load Cities data\ndf_Cities <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/Cities.csv')\ndf_GameCities <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MGameCities.csv')\n\n# Public Rankings\ndf_MasseyOrdinals <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MMasseyOrdinals.csv')\n\n# Conferences\ndf_Conferences <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/Conferences.csv')\ndf_ConferencesTourneyGames <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MConferenceTourneyGames.csv')\n\n# Tourney results\ndf_TourneyCompactResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MNCAATourneyCompactResults.csv')\ndf_TourneyDetailedResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MNCAATourneyDetailedResults.csv')\ndf_TourneySeedRoundSlots <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MNCAATourneySeedRoundSlots.csv')\ndf_TourneySeeds <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MNCAATourneySeeds.csv')\ndf_TourneySlots <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MNCAATourneySlots.csv')\n\n# Secondary results\ndf_SecondaryTourneyCompactResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MSecondaryTourneyCompactResults.csv')\ndf_SecondaryTourneyTeams <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MSecondaryTourneyTeams.csv')\n\n# Regular Season results\ndf_RegularSeasonCompactResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MRegularSeasonCompactResults.csv')\ndf_RegularSeasonDetailedResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MRegularSeasonDetailedResults.csv')\n\n# Seasons\ndf_Seasons <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MSeasons.csv')","execution_count":null,"outputs":[]},{"metadata":{"trusted":true,"_kg_hide-input":true,"_kg_hide-output":true},"cell_type":"code","source":"################ CALCULATE ADVANCED STATISTICS\n# relied on https://www.kaggle.com/jaseziv83/moreyball-in-the-college-game-a-full-ncaa-eda\n\n# Combine regular season and tourney\ndf_FullDetailedResults <- rbind(df_RegularSeasonDetailedResults, df_TourneyDetailedResults) %>%\n filter(Season == 2019)\n\n## calculate possessions per game statistic: field goal attempts + 0.475 x free throw attempts - offensive rebounds + turnovers\n\n# regular season\nseason_stats <- df_FullDetailedResults %>%\n mutate(WPoss = WFGA + (WFTA * 0.475) + WTO - WOR,\n LPoss = LFGA + (LFTA * 0.475) + LTO - LOR)\n\n\n\n#---------- tidy data for regular season totals ----------#\n\n# First I will define a function that will take the detailed results data and reshape it so that it results in a dataframe where \n# each observation is a team for that season and their totals statistics for that season. It will also calculate the statistics allowed\n# for the season. This function only requires one parameter to be passed to it: either the regular season or Tourney detailed data.\n\n# IMPORTANT: #\n# The data required for this function to work is either the regular season or tourney detailed stats, and the \"teams\" dataset\n\nreshape_detailed_results <- function(detailed_dataset) {\n \n season_team_stats_tot <- rbind(\n detailed_dataset %>%\n select(Season, DayNum, TeamID=WTeamID, Score=WScore, OScore=LScore, WLoc, NumOT, Poss=WPoss, FGM=WFGM, FGA=WFGA, FGM3=WFGM3, FGA3=WFGA3, FTM=WFTM, FTA=WFTA, OR=WOR,\n DR=WDR, Ast=WAst, TO=WTO, Stl=WStl, Blk=WBlk, PF=WPF, OPoss=LPoss, OFGM=LFGM, OFGA=LFGA, OFGM3=LFGM3, OFGA3=LFGA3, OFTM=LFTM, OFTA=LFTA, O_OR=LOR, ODR=LDR,\n OAst=LAst, OTO=LTO, OStl=LStl, OBlk=LBlk, OPF=LPF) %>%\n mutate(Winner=1),\n \n detailed_dataset %>%\n select(Season, DayNum, TeamID=LTeamID, Score=LScore, OScore=WScore, WLoc, NumOT, Poss=LPoss, FGM=LFGM, FGA=LFGA, FGM3=LFGM3, FGA3=LFGA3, FTM=LFTM, FTA=LFTA, OR=LOR,\n DR=LDR, Ast=LAst, TO=LTO, Stl=LStl, Blk=LBlk, PF=LPF, OPoss=WPoss, OFGM=WFGM, OFGA=WFGA, OFGM3=WFGM3, OFGA3=WFGA3, OFTM=WFTM, OFTA=WFTA, O_OR=WOR, ODR=WDR,\n OAst=WAst, OTO=WTO, OStl=WStl, OBlk=WBlk, OPF=WPF) %>%\n mutate(Winner=0)) %>%\n group_by(Season, TeamID) %>%\n summarise(GP = n(),\n wins = sum(Winner),\n TotPoints = sum(Score),\n TotPointsAllow = sum(OScore),\n NumOT = sum(NumOT),\n TotPos = sum(Poss),\n TotFGM = sum(FGM),\n TotFGA = sum(FGA),\n TotFGM3 = sum(FGM3),\n TotFGA3 = sum(FGA3),\n TotFTM = sum(FTM),\n TotFTA = sum(FTA),\n TotOR = sum(OR),\n TotDR = sum(DR),\n TotAst = sum(Ast),\n TotTO = sum(TO),\n TotStl = sum(Stl),\n TotBlk = sum(Blk),\n TotPF = sum(PF),\n TotPossAllow = sum(OPoss),\n TotFGMAllow = sum(OFGM),\n TotFGAAllow = sum(OFGA),\n TotFGM3Allow = sum(OFGM3),\n TotFGA3Allow = sum(OFGA3),\n TotFTMAllow = sum(OFTM),\n TotFTAAllow = sum(OFTA),\n TotORAllow = sum(O_OR),\n TotDRAllow = sum(ODR),\n TotAstAllow = sum(OAst),\n TotTOAllow = sum(OTO),\n TotStlAllow = sum(OStl),\n TotBlkAllow = sum(OBlk),\n TotPFAllow = sum(OPF))\n \n}\n\n## Store the results to a dataframe\nseason_team_stats_tot <- reshape_detailed_results(season_stats)\n\n## calculate win percentage\nseason_team_stats_tot$WinPerc <- season_team_stats_tot$wins / season_team_stats_tot$GP\n\n\n\n#---------- Create a dataframe of season averages for each team ----------#\n\n# Next I will define a function that takes in the totals dataframe from the above function and calculate a season averages dataset.\n# this function also only requires one parameter to be passed to it, the totals dataframe.\n\ncalculate_detailed_averages <- function(totals_dataframe) {\n \n averages <- totals_dataframe\n \n cols <- names(averages[,c(5:35)])\n \n for (eachcol in cols) {\n averages[,eachcol] <- round(averages[,eachcol] / averages$GP,2)\n \n }\n \n averages <- averages %>%\n rename(AvgPoints = TotPoints, AvgPointsAllow=TotPointsAllow, AvgOT=NumOT, AvgPoss=TotPos, AvgFGM=TotFGM, AvgFGA=TotFGA, AvgFGM3=TotFGM3, AvgFGA3=TotFGA3, AvgFTM=TotFTM,\n AvgFTA=TotFTA, AvgOR=TotOR, Avg_DR=TotDR, AvgAst=TotAst, AvgTO=TotTO, AvgStl=TotStl, Avg_Blk=TotBlk, AvgPF=TotPF, AvgPossAllow=TotPossAllow, AvgFGMAllow=TotFGMAllow, \n AvgFGAAllow=TotFGAAllow, AvgFGM3Allow=TotFGM3Allow, AvgFGA3Allow=TotFGA3Allow, AvgFTMAllow=TotFTMAllow, AvgFTAAllow=TotFTAAllow, \n AvgORAllow=TotORAllow, AvgDRAllow=TotDRAllow, AvgAstAllow=TotAstAllow, AvgTOAllow=TotTOAllow, AvgStlAllow=TotStlAllow, AvgBlkAllow=TotBlkAllow,\n AvgPFAllow=TotPFAllow) %>%\n mutate(PointsPerPoss = AvgPoints / AvgPoss,\n PointsPerPossAllow = AvgPointsAllow / AvgPossAllow)\n \n return(averages)\n \n}\n\n\n# create an averages dataframe\nseason_team_stats_averages <- calculate_detailed_averages(season_team_stats_tot)\n\n\n\n#---------- Create a dataframe of advanved stats for each team ----------#\n\n# Create advanved stats dataframe\nadvanced_stats_season <- season_team_stats_tot %>%\n mutate(WinPerc = wins / GP,\n OffRtg = 100 * (TotPoints / TotPos),\n DefRtg = 100 * (TotPointsAllow / TotPossAllow),\n SoS = OffRtg - DefRtg,\n Pie = TotPoints + TotFGM + TotFTM - TotFGA - TotFTA + TotDR + (0.5 * TotOR) + TotAst + TotStl + (0.5 * TotBlk) - TotPF - TotTO,\n OPie = TotPointsAllow + TotFGMAllow + TotFTMAllow - TotFGAAllow - TotFTAAllow + TotDRAllow + (0.5 * TotORAllow) + TotAstAllow + TotStlAllow + (0.5 * TotBlkAllow) - TotPFAllow - TotTOAllow,\n Tie = Pie / (Pie + OPie) * 100,\n AstRatio = 100 * TotAst / (TotFGA + (0.475 * TotFTA) + TotAst + TotTO),\n TORatio = 100 * TotTO / (TotFGA + (0.475 * TotFTA) + TotAst + TotTO),\n TSPerc = 100 * TotPoints / (2 * (TotFGA + (0.475 * TotFTA))),\n FTRate = TotFTA / TotFGA,\n ThreesShare = TotFGA3 / TotFGA,\n OffRebPerc = TotOR / (TotOR + TotDRAllow),\n DefRebPerc = TotDR / (TotDR + TotORAllow),\n TotRebPerc = (TotDR + TotOR) / (TotDR + TotOR + TotDRAllow + TotORAllow)) %>%\n select(Season, TeamID, TotPoints, TotPointsAllow, wins, WinPerc, OffRtg, DefRtg, SoS, Pie, OPie, Tie, AstRatio, TORatio, TSPerc, FTRate, ThreesShare, OffRebPerc, DefRebPerc, TotRebPerc)\n\n\n\n### Combine average and advanced statistics\nteam_stats_full <- season_team_stats_averages %>% left_join(advanced_stats_season, \"TeamID\")\nteam_stats_full$wins <- team_stats_full$wins.y\n\n# Recode TeamID to character\nteam_stats_full$TeamID <- as.character(team_stats_full$TeamID)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"\n> A basketball game allows us to record a variety of data about multiple substantive characteristics such as players' actions, teams' performance, etc. In many cases, we analyze such observations (e.g., the average number of points per game scored by a Player A or the number of victories for Team B) independently from each other. But if you think about it, basketball, like any team sport, is about connections: connections between players on the field, connections between teams during the season and many other similar relationships.\n>\n> Then, the following question comes to the fore: how can we account for such connections and analytically model them to derive meaningful results? One popular way is to leverage the Social Network Analysis Methodology that allows exploring network structures through the application of graph theory. In this notebook, we are going to utilize this approach to answer several distinct questions, pertaining to both micro-level - players' within-game interactions - and macro-level - the aggregated performance of teams during the season. The concrete questions are as follows:\n>\n> 1. How can we operationalize the importance of a player for a team and what are the players which are the most important?\n> 2. Does centralization of a team impove its performance? \n> 3. How can we define competitiveness during the regular season games and what are the conferences with greater competitiveness?\n> 4. Can network methodology help us explain the games' outcomes?\n>\n> In this research, we exploit 2019 data about Regular and NCAA Tourney men's games.","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"# 1. Who are the Important Players in a Team?","execution_count":null},{"metadata":{"_kg_hide-output":true,"trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"################ CREATE NETWORKS OF ASSISTS\noptions(warn=-1)\n\n# Select only plays with assists\nplay_by_play <- subset(play_by_play, EventType2 == \"assist\")\n\n# Create list with Team IDs\nteam_ids <- unique(play_by_play$EventTeamID)\n\n# Remove missing team ids\nif(0 %in% team_ids){\n team_ids <- team_ids[-which(team_ids == 0)]\n}\n\n\ncreateAssistsGraph <- function(team_id, play_by_play=play_by_play){\n\n # Select only one team\n play_by_play <- play_by_play[play_by_play$EventTeamID == team_id,]\n \n # Create edgeslist for one team, First column - assisted, Second column - made a shot.\n play_by_play$EventPlayerID2 <- as.character(play_by_play$EventPlayerID2)\n play_by_play$EventPlayerID <- as.character(play_by_play$EventPlayerID)\n edgelist <- play_by_play[,c(\"EventPlayerID2\", \"EventPlayerID\")]\n \n ### Remove duplicated edges and add weights instead\n # Create pair from each nodes in the edge\n edgelist$pair <- paste(edgelist$EventPlayerID2, edgelist$EventPlayerID, sep = \"_\")\n # Create dataframe with pairs and corresponding weights\n pair_weights <- data.frame(table(edgelist$pair))\n colnames(pair_weights) <- c(\"pair\", 'weight')\n pair_weights$pair <- as.character(pair_weights$pair)\n # Remove duplicated edges\n edgelist <- edgelist[!duplicated(edgelist$pair),]\n # Add weights to the edgelist\n edgelist <- edgelist %>% left_join(pair_weights, 'pair')\n edgelist$pair <- NULL\n \n # Remove missing player ids\n edgelist <- edgelist[!is.na(edgelist$EventPlayerID2),]\n edgelist <- edgelist[!is.na(edgelist$EventPlayerID),]\n \n # Remove 0 player ids\n edgelist <- edgelist[edgelist$EventPlayerID2 != 0,]\n edgelist <- edgelist[edgelist$EventPlayerID != 0,]\n \n # Create graph from edgelist\n G <- igraph::graph_from_edgelist(as.matrix(edgelist[c(\"EventPlayerID2\", \"EventPlayerID\")]))\n # Add weights\n E(G)$weight <- edgelist$weight\n \n # Remove self loops\n G <- igraph::simplify(G)\n \n return(G)\n}\n\n\n# Create assists graphs for all teams\nassist_graphs_list <- list()\n\nfor(i in 1:length(team_ids)){\n assist_graphs_list[[i]] <- createAssistsGraph(team_ids[i], play_by_play)\n}\n\n\n################ CALCULATE SET OF NETWORK STATISTICS FOR ALL PLAYERS\n\ncalculatePlayerNetworkStatistics <- function(g){\n \n # 1. Players ids\n player_ids <- names(V(g))\n \n # 2. Betweenness\n betweenness_vec <- betweenness(g, normalized=T)\n \n # 3. Page Rank\n pagerank_vec <- page.rank(g)$vector\n pagerank_vec <- pagerank_vec/sum(pagerank_vec)\n \n \n return(list(PlayerID=player_ids,\n betweenness=betweenness_vec,\n pagerank=pagerank_vec))\n}\n\n\ndf_PlayersNetworkStats <- lapply(assist_graphs_list, calculatePlayerNetworkStatistics)\ndf_PlayersNetworkStats <- do.call(rbind.data.frame, df_PlayersNetworkStats)\ndf_PlayersNetworkStats <- df_PlayersNetworkStats %>% mutate(PlayerID=as.character(PlayerID))\n\n# Add full names of players to df with network stats\ndf_Players <- df_Players %>% mutate(FullName=paste(FirstName, LastName),\n PlayerID=as.character(PlayerID))\ndf_PlayersNetworkStats <- df_PlayersNetworkStats %>%\n left_join(df_Players %>% select(PlayerID, FullName), \"PlayerID\")\n\n\n\n################ CALCULATE SET OF NETWORK STATISTICS FOR ALL TEAMS\n\ncalculateTeamNetworkStatistics <- function(g){\n \n # 1. Clustering coefficent (transitivity)\n mean_transitivity <- mean(transitivity(g, \"weighted\"), na.rm=T)\n \n # 2. Betweenness\n betweenness_vec <- betweenness(g, normalized=T)\n \n # 3. Closeness\n closeness_vec <- closeness(g, normalized=T, mode=\"in\")\n \n # 4. Page Rank\n pagerank_vec <- page.rank(g)$vector\n pagerank_vec <- pagerank_vec/sum(pagerank_vec)\n \n # 5. EigenVector centrality\n eigenvector_vec <- as.numeric(eigen_centrality(g, directed=T)$vector)\n \n # 6. Centralization metrics\n betweenness_centralization <- centralize(betweenness_vec, normalized = F)\n closeness_centralization <- centralize(closeness_vec, normalized = F)\n pagerank_centralization <- centralize(pagerank_vec, normalized = F)\n eigenvector_centralization <- centralize(eigenvector_vec, normalized = F)\n \n \n return(list(mean_transitivity=mean_transitivity,\n betweenness_centralization=betweenness_centralization,\n closeness_centralization=closeness_centralization,\n pagerank_centralization=pagerank_centralization,\n eigenvector_centralization=eigenvector_centralization))\n}\n\n\ndf_TeamsNetworkStats <- lapply(assist_graphs_list, calculateTeamNetworkStatistics)\ndf_TeamsNetworkStats <- do.call(rbind.data.frame, df_TeamsNetworkStats)\n\n# Add team_id\ndf_TeamsNetworkStats$TeamID <- team_ids\n\n# Add mean rank for the team in that season\n# df_MasseyOrdinals_pom <- subset(df_MasseyOrdinals, SystemName==\"POM\" & Season==2019) %>%\n# select(TeamID, RankingDayNum, OrdinalRank) %>% group_by(TeamID) %>%\n# summarize(median_rank=median(OrdinalRank)) %>% data.frame()\n# \n# # Add ranking to the teams stats\n# df_TeamsNetworkStats <- left_join(df_TeamsNetworkStats, df_MasseyOrdinals_pom, by=\"TeamID\")\n# \n# # Add team names to the dataframe\ndf_TeamsNetworkStats <- df_TeamsNetworkStats %>% left_join(df_Teams %>% select(TeamID, TeamName)) %>% ungroup()\n\n# Recode TeamID to character\ndf_TeamsNetworkStats$TeamID <- as.character(df_TeamsNetworkStats$TeamID)\n\n# Add number of wins during the season\ndf_TeamsNetworkStats <- df_TeamsNetworkStats %>% left_join(team_stats_full %>% select(TeamID, wins), by=\"TeamID\")","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"To erect a network we need 2 crucial components:\n\n1. **nodes** that can be represented by people, organizations, atoms like in [this](https://www.kaggle.com/c/champs-scalar-coupling) Kaggle competition [1], etc.\n\n2. **edges** that reflect connections between pairs of nodes (e.g., a friendship nomination). \n\nSports games enable us to build networks with nodes as players and links as common actions between them based on the act of assisting - passing or crossing the ball to the scorer. This approach is rather frequent in the literature: there were quite a few attempts to create similar networks of assists in football [e.g.: 2,3] and in hockey [e.g.: 4].\n\nThe current study uses the Play-by-Play data for the 2019 season to create networks of assists for each basketball team. Below you can find an example of such a network for the Arizona St team. The direction of edges represents to whom a player gave an assist, whereas the width of links indicates the total amount of assisting situations that happened between a pair of players during the season.","execution_count":null},{"metadata":{"trusted":true,"_kg_hide-input":true},"cell_type":"code","source":"################ PLOT WITH AN EXAMPLE OF ASSIST NETWORK\noptions(warn=-1)\n\n# Adjust plotting window\noptions(repr.plot.width=12, repr.plot.height = 8)\n\n# Create the graph\nG <- assist_graphs_list[[3]]\nG_name <- as.character(df_TeamsNetworkStats[3,]$TeamName)\n\n# Adjust width of the edges\nedge_width <- E(G)$weight*0.3\n\n# Add player names\nvertex_ids <- data.frame(PlayerID=names(V(G)))\nvertex_fullnames <- (vertex_ids %>% left_join(df_Players %>% select(PlayerID, FullName), \"PlayerID\"))$FullName\nG <- set_vertex_attr(G, \"fullname\", value=vertex_fullnames)\n\n# Plot the graph\nplot.igraph(G, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width,\n vertex.size=15, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=vertex.attributes(G)$fullname,\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1.2,\n vertex.color=\"gray90\")\ntitle(paste(\"Assists Network of\", G_name, \"team\"),cex.main=2)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"markdown","source":"To draw some valid conclusions about the importance of a player, we can calculate a bunch of network centrality statistics for each player. Let us investigate a couple of them as an example. First, we compute a **PageRank centrality** for the created web of connections between assists in basketball games. This parameter in a sports-based context refers to the probability of a pass or shot involving a certain player within the network. Second, we calculate **Betweenness centrality**, which may be interpreted as the extent to which a team would suffer, if a player is removed. Let us visualize these characteristics on our graph for the Arizona St team by setting nodes' size to the mentioned centrality measures (the greater the node, the more central is a player).","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PLOT WITH AN EXAMPLE OF ASSIST NETWORK WITH PAGERANK\noptions(warn=-1)\n\n# Create the graph\nG <- assist_graphs_list[[3]]\nG_name <- as.character(df_TeamsNetworkStats[3,]$TeamName)\n\n# Set vertex size end edge width for plotting\nvertex_size <- page.rank(G)$vector * 200\nvertex_size <- ifelse(vertex_size <= 5, 5, vertex_size)\nedge_width <- E(G)$weight*0.3\n# Add player names\nvertex_ids <- data.frame(PlayerID=names(V(G)))\nvertex_fullnames <- (vertex_ids %>% left_join(df_Players %>% select(PlayerID, FullName), \"PlayerID\"))$FullName\nG <- set_vertex_attr(G, \"fullname\", value=vertex_fullnames)\n\n# Plot the graph\nplot.igraph(G, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width,\n vertex.size=vertex_size, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=ifelse(vertex_size>20, vertex.attributes(G)$fullname, NA),\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1.2,\n vertex.color=ifelse(vertex_size>20, \"aquamarine3\", \"gray90\"))\ntitle(paste(\"Assists Network of\", G_name, \"team, \\n PageRank centrality\"),cex.main=2)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"The graph shows that not all of the players are involved in scoring and assisting equally. The 'core' of the team is defined mainly by 5 players depicted with green color.\n\nFurther, we calculate the described centralities for each player in every team and rank them based on this metric. The barplot below displays the TOP-15 players arranged according to the PageRank centrality in their teams.","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PLOT TOP 15 PLAYERS WITH HIGHEST PAGERANK\n\n# Adjust plotting window\noptions(repr.plot.width=10, repr.plot.height = 6)\n\ndf_PlayersNetworkStats %>% arrange(-pagerank) %>% head(15) %>% \n ggplot(aes(reorder(FullName, pagerank), pagerank)) +\n geom_col(fill=\"aquamarine3\") + scale_y_continuous(limits = c(0.2,0.26), oob=rescale_none) +\n coord_flip() + theme_classic(base_size = 18) + ggtitle(\"TOP-15 Players by PageRank centrality in a team\") + \n labs(y=\"PageRank\", x = \"Player\") + \n theme(plot.title = element_text(size = 22))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"As we can see, Christian Lutete has the highest PageRank amongst others. Next, we can look at players with the most pronounced \"betweenness\" attribute.","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PLOT TOP 15 PLAYERS WITH HIGHEST BETWEENNESS\n\n# Adjust plotting window\noptions(repr.plot.width=10, repr.plot.height = 6)\n\ndf_PlayersNetworkStats %>% arrange(-betweenness) %>% head(15) %>% \n ggplot(aes(reorder(FullName, betweenness), betweenness)) +\n geom_col(fill=\"lightblue3\") + scale_y_continuous(limits = c(0.4,0.6), oob=rescale_none) +\n coord_flip() + theme_classic(base_size = 18) + ggtitle(\"TOP-15 Players by Betweenness centrality in a team\") + \n labs(y=\"Betweenness\", x = \"Player\") + \n theme(plot.title = element_text(size = 22))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"In this case, Tyree Pickron, BJ Duling, and P.J. Horne are playing the role of key \"connectors\" for the score moments, and if these players are removed from the team this might be dangerous to the network.","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"# 2. Can High Centralization Improve a Team's Performance?","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"It should be noted that we cannot compare the above mentioned ranks of players directly to each other across teams since centrality measures are network-specific. However, we are able to conduct a between-team comparison based on **centralization metrics** aggregated over a whole network. High centralization signifies that the team depends on a few players, while low centralization means relatively equal distribution of responsibilities amongst the team members. Let us look at the teams with the highest and lowest PageRank centralization.","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PLOT WITH EXAMPLE OF HIGHEST AND LOWEST PAGERANK CENTRALIZATIONS\n\n### HIGHEST PAGERANK\n# Create the graph\nG.1 <- assist_graphs_list[[which.max(df_TeamsNetworkStats$pagerank_centralization)]]\nG.1_name <- as.character(df_TeamsNetworkStats[which.max(df_TeamsNetworkStats$pagerank_centralization),]$TeamName)\n\n# Set vertex size end edge width for plotting\nvertex_size.1 <- page.rank(G.1)$vector * 200\nvertex_size.1 <- ifelse(vertex_size.1 <= 5, 5, vertex_size.1)\nedge_width.1 <- E(G.1)$weight*0.3\n# Add player names\nvertex_ids.1 <- data.frame(PlayerID=names(V(G.1)))\nvertex_fullnames.1 <- (vertex_ids.1 %>% left_join(df_Players %>% select(PlayerID, FullName), \"PlayerID\"))$FullName\nG.1 <- set_vertex_attr(G.1, \"fullname\", value=vertex_fullnames.1)\n\n### LOWEST PAGERANK\n# Create the graph\nG.2 <- assist_graphs_list[[which.min(df_TeamsNetworkStats$pagerank_centralization)]]\nG.2_name <- as.character(df_TeamsNetworkStats[which.min(df_TeamsNetworkStats$pagerank_centralization),]$TeamName)\n\n# Set vertex size end edge width for plotting\nvertex_size.2 <- page.rank(G.2)$vector * 150\nvertex_size.2 <- ifelse(vertex_size.2 <= 5, 5, vertex_size.2)\nedge_width.2 <- E(G.2)$weight*0.3\n# Add player names\nvertex_ids.2 <- data.frame(PlayerID=names(V(G.2)))\nvertex_fullnames.2 <- (vertex_ids.2 %>% left_join(df_Players %>% select(PlayerID, FullName), \"PlayerID\"))$FullName\nG.2 <- set_vertex_attr(G.2, \"fullname\", value=vertex_fullnames.2)\n\n# Adjust plotting window\noptions(repr.plot.width=16, repr.plot.height = 8)\npar(mfrow=c(1,2))\n# Plot the graph\nplot.igraph(G.1, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width,\n vertex.size=vertex_size.1, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=ifelse(vertex_size.1>20, vertex.attributes(G)$fullname, NA),\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1.2,\n vertex.color=ifelse(vertex_size.1>20, \"aquamarine3\", \"gray90\"))\ntitle(paste(G.1_name, '\\n Team with Highest PageRank Centralization'),cex.main=1.7)\n# Plot the graph\nplot.igraph(G.2, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width.2,\n vertex.size=vertex_size.2, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=ifelse(vertex_size.2>10, vertex.attributes(G.2)$fullname, NA),\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1,\n vertex.color=ifelse(vertex_size.2>10, \"aquamarine3\", \"gray90\"))\ntitle(paste(G.2_name, '\\n Team with Lowest PageRank Centralization'),cex.main=1.7)\n","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"These networks demonstrate a huge disbalance within the Hampton team in favor of the 4 key players, while in the Baylor team the PageRank centralization is distributed more or less evenly across the members. Let us look at the same type of plots, but for the betweenness centralization.\n","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"# Create the graph\nG.1 <- assist_graphs_list[[which.max(df_TeamsNetworkStats$betweenness_centralization)]]\nG.1_name <- as.character(df_TeamsNetworkStats[which.max(df_TeamsNetworkStats$betweenness_centralization),]$TeamName)\n\n# Set vertex size end edge width for plotting\nvertex_size.1 <- as.numeric(betweenness(G.1, normalized=T))*100\nvertex_size.1 <- ifelse(vertex_size.1 <= 5, 5, vertex_size.1)\nedge_width.1 <- E(G.1)$weight*0.3\n# Add player names\nvertex_ids.1 <- data.frame(PlayerID=names(V(G.1)))\nvertex_fullnames.1 <- (vertex_ids.1 %>% left_join(df_Players %>% select(PlayerID, FullName), \"PlayerID\"))$FullName\nG.1 <- set_vertex_attr(G.1, \"fullname\", value=vertex_fullnames.1)\n\n# Create the graph\nG.2 <- assist_graphs_list[[which.min(df_TeamsNetworkStats$betweenness_centralization)]]\nG.2_name <- as.character(df_TeamsNetworkStats[which.min(df_TeamsNetworkStats$betweenness_centralization),]$TeamName)\n\n# Set vertex size end edge width for plotting\nvertex_size.2 <- as.numeric(betweenness(G.2, normalized=T))*100\nvertex_size.2 <- ifelse(vertex_size.2 <= 5, 5, vertex_size.2)\nedge_width.2 <- E(G.2)$weight*0.3\n# Add player names\nvertex_ids.2 <- data.frame(PlayerID=names(V(G.2)))\nvertex_fullnames.2 <- (vertex_ids.2 %>% left_join(df_Players %>% select(PlayerID, FullName), \"PlayerID\"))$FullName\nG.2 <- set_vertex_attr(G.2, \"fullname\", value=vertex_fullnames.2)\n\n# Adjust plotting window\noptions(repr.plot.width=16, repr.plot.height = 8)\npar(mfrow=c(1,2))\n# Plot the graph\nplot.igraph(G.1, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width.1,\n vertex.size=vertex_size.1, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=ifelse(vertex_size.1>40, vertex.attributes(G.1)$fullname, NA),\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1.2,\n vertex.color=ifelse(vertex_size.1>40, \"lightblue3\", \"gray90\"))\ntitle(paste(G.1_name, '\\n Team with Highest Betweenness Centralization'),cex.main=1.7)\n# Plot the graph\nplot.igraph(G.2, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width.2,\n vertex.size=vertex_size.2, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=ifelse(vertex_size.2>5, vertex.attributes(G.2)$fullname, NA),\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1.2,\n vertex.color=ifelse(vertex_size.2>5, \"lightblue3\", \"gray90\"))\ntitle(paste(G.2_name, '\\n Team with Highest Betweenness Centralization'),cex.main=1.7)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"It can be seen that there is a high betweenness centralization in the Texas basketball team, the overall connectivity between players will drop dramatically if the competitor can effectively neutralize their key player - Kamaka Hepa. The situation is opposite in the Georgia St: even if some of the players are missing from the network, the overall performance will not decrease substantially.\n\nWe make a step further in order to obtain some important insights into the influence of such network characteristics on team performance. For this purpose, a simple Linear Regression is used. The total number of team victories in the season we incorporate as a dependent variable. For the predictors, we use our two network centralization characteristics mentioned above and a couple of additional ones, namely **closeness centralization** (reflecting how easy it is for a player to be connected with his or her teammates by passing relations) and **transitivity** also known as a clustering coefficient (a measure of connectivity between triads of players in the network).","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"stargazer(lm(wins ~ mean_transitivity + betweenness_centralization + \n closeness_centralization + pagerank_centralization, \n df_TeamsNetworkStats), type=\"text\", single.row=T)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"The regression analysis shows that having high transitivity, closeness, and PageRank centralization adversely affects the number of victories for a team (the respective coefficients are statistically significant and negative). In contrast, the growth in the betweenness centralization leads to a slightly better collective performance. Overall, it seems that teams that are highly centralized around one or a few players are less successful than those with a more dispersed assisting activity level.","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"# 3. How Can We Define Competitiveness within Conferences?","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"The next part of our work is devoted to the analysis of a directed network in which **each node represents a college basketball team, while a tie between a pair of teams indicates on an outcome of a game**: outcoming ties signify a failure, incoming ties signify a victory. In other words, the links direct to the winning teams, which are characterized by the greatest **in-degree** centrality. A similar network-oriented view is present in a range of sports studies. For example, Park and Newman [5] implement a network system for the ranking of the US college football teams, Milekhina [6] uses a network of played matches to explore the potential of a tennis player.\n\nWe explore a network of basketball teams within each conference separately and calculate a centralization measure for each conference. This time the **EigenVector** centralization is utilized. Highly pronounced centralization of this type means that a conference is not competitive since it has one or few clear-cut leaders that easily beat the rest. When the EigenVector centralization is small, a confrontation happens to be serious between many pairs of teams, therefore, the competitiveness is acute. Below we present an example of the most (low EigenVector) and the least (high EigenVector) competitive conferences in the 2019 season.\n","execution_count":null},{"metadata":{"_kg_hide-input":true,"_kg_hide-output":true,"trusted":true},"cell_type":"code","source":"################ CREATE SEPARATE GRAPH OF MATCHES FOR EACH CONFERENCE\n\ndf_TeamConferences$TeamID <- as.character(df_TeamConferences$TeamID)\ndf_Teams$TeamID <- as.character(df_Teams$TeamID)\n\n# Select only 2019 data and replicate TeamID column\ndf_TeamConferences <- df_TeamConferences %>% filter(Season == 2019) %>%\n mutate(WTeamID=TeamID, LTeamID=TeamID) %>% select(-c(Season))\n\ndf_RegularSeasonCompactResults <- df_RegularSeasonCompactResults %>% filter(Season == 2019)\n\ndf_RegularSeasonCompactResults$WTeamID <- as.character(df_RegularSeasonCompactResults$WTeamID)\ndf_RegularSeasonCompactResults$LTeamID <- as.character(df_RegularSeasonCompactResults$LTeamID)\n\n\ndf_RegularSeasonCompactResults <- df_RegularSeasonCompactResults %>%\n left_join(df_TeamConferences %>% select(c(ConfAbbrev, WTeamID)), \"WTeamID\") %>% rename(WConfAbbrev=ConfAbbrev) %>%\n left_join(df_TeamConferences %>% select(c(ConfAbbrev, LTeamID)), \"LTeamID\") %>% rename(LConfAbbrev=ConfAbbrev)\n\ndf_RegularSeasonCompactResults <- df_RegularSeasonCompactResults %>% mutate(same_conf=WConfAbbrev==LConfAbbrev)\n\ndf_RegularSeasonCompactResults$WTeamID <- as.character(df_RegularSeasonCompactResults$WTeamID)\ndf_RegularSeasonCompactResults$LTeamID <- as.character(df_RegularSeasonCompactResults$LTeamID)\n\n# Select only matches in the same conference\ndf_RegularSeasonCompactResults <- df_RegularSeasonCompactResults %>% filter(same_conf)\n\n# Create dataframe with team-to-team wins and loses\nteam_to_team_results <- df_RegularSeasonCompactResults %>% \n # filter(Season >= 2009) %>% \n count(WTeamID, LTeamID) %>% \n arrange(desc(n)) %>% \n left_join(df_Teams %>% select(TeamID, TeamName), by = c(\"WTeamID\" = \"TeamID\")) %>% \n rename(WTeamName = TeamName) %>% \n left_join(df_Teams %>% select(TeamID, TeamName), by = c(\"LTeamID\" = \"TeamID\")) %>% \n rename(LTeamName = TeamName)\nteam_to_team_results <- team_to_team_results %>%\n # select(-ends_with(\"ID\")) %>% \n rename(wins = n) %>% \n left_join(team_to_team_results %>% select(-ends_with(\"ID\")), by = c(\"WTeamName\" = \"LTeamName\", \"LTeamName\" = \"WTeamName\")) %>% \n rename(losses = n) %>% \n replace_na(list(wins = 0, losses = 0)) %>% \n mutate(win_perc = wins/(wins + losses) * 100) %>%\n # Select only teams with 10 or more games played between each other\n filter(wins+losses>=1) %>%\n mutate(WTeamID_LTeamID=paste(as.character(WTeamID), as.character(LTeamID), sep=\"_\"))\n\n# Create edgelist between teams on the wins agains each other\nedgelist_wteam_lteam <- df_RegularSeasonCompactResults %>% \n count(WTeamID, LTeamID) %>%\n mutate(WTeamID_LTeamID=paste(as.character(WTeamID), as.character(LTeamID), sep=\"_\")) %>%\n filter(WTeamID_LTeamID %in% team_to_team_results$WTeamID_LTeamID) %>% \n select(-c(WTeamID_LTeamID))\ncolnames(edgelist_wteam_lteam)[3] <- 'weight'\n\n# Add conference name to edgelist\nedgelist_wteam_lteam <- edgelist_wteam_lteam %>% left_join(df_TeamConferences %>% select(ConfAbbrev, WTeamID), \"WTeamID\")\n\n# Change order of WTeamID and LTeamID\nedgelist_wteam_lteam <- edgelist_wteam_lteam %>% select(LTeamID, WTeamID, weight, ConfAbbrev)\n\n### Create separate graph of matches for each conference\nconference_graphs_list <- list()\nconfrence_names <- as.character(unique(edgelist_wteam_lteam$ConfAbbrev))\n\nfor(i in 1:length(confrence_names)){\n \n conf_edgelist <- edgelist_wteam_lteam %>% filter(ConfAbbrev == confrence_names[i])\n conference_graphs_list[[i]] <- graph.data.frame(conf_edgelist, directed = T)\n \n}\n\n\n### Calculate the EigenVector centralization for each conference\n\ncalculateConferenceNetworkStatistics <- function(g){\n \n # 1. EigenVector centrality\n eigenvector_vec <- as.numeric(eigen_centrality(g, directed=T)$vector)\n \n # 2. Centralization metrics\n eigenvector_centralization <- centralize(eigenvector_vec, normalized = F)\n \n return(list(eigenvector_centralization=eigenvector_centralization))\n}\n\n\ndf_ConferencesNetworkStats <- lapply(conference_graphs_list, calculateConferenceNetworkStatistics)\ndf_ConferencesNetworkStats <- do.call(rbind.data.frame, df_ConferencesNetworkStats)\n\n# Add team_id\ndf_ConferencesNetworkStats$conference_name <- confrence_names\n# Add graph_list number\ndf_ConferencesNetworkStats$id <- 1:nrow(df_ConferencesNetworkStats)\n\n# Add fullnames names of the conferences\ndf_ConferencesNetworkStats <- df_ConferencesNetworkStats %>% left_join(df_Conferences,by = c(\"conference_name\"=\"ConfAbbrev\"))\ndf_ConferencesNetworkStats <- df_ConferencesNetworkStats %>% rename(conference_fullname=Description)\ndf_ConferencesNetworkStats$conference_fullname <- as.character(df_ConferencesNetworkStats$conference_fullname)\n\n# Remove \"Conference\" word\ndf_ConferencesNetworkStats$conference_fullname <- removeWords(df_ConferencesNetworkStats$conference_fullname, \" Conference\")\n","execution_count":null,"outputs":[]},{"metadata":{"trusted":true,"_kg_hide-input":true,"_kg_hide-output":false},"cell_type":"code","source":"### HIGHEST EIGENVECTOR CENTRALIZATION\n\n# Create the graph\nG.1 <- conference_graphs_list[[which.max(df_ConferencesNetworkStats$eigenvector_centralization)]]\nG.1_name <- as.character(df_ConferencesNetworkStats[which.max(df_ConferencesNetworkStats$eigenvector_centralization),]$conference_fullname)\n# Set vertex size end edge width for plotting\nvertex_size.1 <- as.numeric(eigen_centrality(G.1, directed=T)$vector) * 60\n# vertex_size <- ifelse(vertex_size <= 5, 5, vertex_size)\nedge_width.1 <- E(G.1)$weight*0.3\n# Add team names\nvertex_ids.1 <- data.frame(TeamID=names(V(G.1)))\ndf_Teams$TeamID <- as.character(df_Teams$TeamID)\nvertex_ids.1 <- vertex_ids.1 %>% left_join(df_Teams %>% select(TeamID, TeamName), \"TeamID\")\nvertex_fullnames.1 <- as.character(vertex_ids.1$TeamName)\nG.1 <- set_vertex_attr(G.1, \"fullname\", value=vertex_fullnames.1)\n\n### LOWEST EIGENVECTOR CENTRALIZATION\n\n# Create the graph\nG.2 <- conference_graphs_list[[which.min(df_ConferencesNetworkStats$eigenvector_centralization)]]\nG.2_name <- as.character(df_ConferencesNetworkStats[which.min(df_ConferencesNetworkStats$eigenvector_centralization),]$conference_fullname)\n# Set vertex size end edge width for plotting\nvertex_size.2 <- as.numeric(eigen_centrality(G.2, directed=T)$vector) * 30\n# vertex_size <- ifelse(vertex_size <= 5, 5, vertex_size)\nedge_width.2 <- E(G.2)$weight*0.3\n# Add team names\nvertex_ids.2 <- data.frame(TeamID=names(V(G.2)))\ndf_Teams$TeamID <- as.character(df_Teams$TeamID)\nvertex_ids.2 <- vertex_ids.2 %>% left_join(df_Teams %>% select(TeamID, TeamName), \"TeamID\")\nvertex_fullnames.2 <- as.character(vertex_ids.2$TeamName)\nG.2 <- set_vertex_attr(G.2, \"fullname\", value=vertex_fullnames.2)\n\n\n# Adjust plotting window\noptions(repr.plot.width=16, repr.plot.height = 8)\npar(mfrow=c(1,2))\n# Plot the graph\nplot.igraph(G.1, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width.1,\n vertex.size=vertex_size.1, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=ifelse(vertex_size.1>35, vertex.attributes(G.1)$fullname, NA),\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1.2,\n vertex.color=ifelse(vertex_size.1>35, \"lightcoral\", \"gray45\"))\ntitle(paste(G.1_name, '\\n Conference with Highest EigenVector Centralization'),cex.main=1.7)\n\n# Plot the graph\nplot.igraph(G.2, edge.arrow.size=0.7, layout=layout.kamada.kawai, edge.width=edge_width.2,\n vertex.size=vertex_size.2, vertex.frame.color='darkgrey', edge.color='gray90',\n vertex.label=ifelse(vertex_size.2>20, vertex.attributes(G.2)$fullname, NA),\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1,\n vertex.color=ifelse(vertex_size.2>20, \"lightcoral\", \"gray45\"))\ntitle(paste(G.2_name, '\\n Conference with Smallest EigenVector Centralization'),cex.main=1.7)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"The pictures above illustrate that the Duke and North Carolina teams were dominating the Atlantic Coast conference in 2019 surging ahead of Virginia and Florida St, while other teams were having hard times trying to defeat such powerful opponents. The situation at the Missouri Valley conference was inverse: almost all of the teams were characterized by the evenly spread EigenVector centrality, meaning that the season was fairly competitive.\n\nLet us look at how the EigenVector centralization is distributed across all the available conferences in 2019.","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PLOT RANKING OF THE CONFERENCES ACCORDING TO COMPETITIVENESS\n\n# Adjust plotting window\noptions(repr.plot.width=12, repr.plot.height = 8)\n\ndf_ConferencesNetworkStats %>% arrange(-eigenvector_centralization) %>% \n ggplot(aes(reorder(conference_fullname, -eigenvector_centralization), eigenvector_centralization, fill=eigenvector_centralization)) +\n geom_col() +\n coord_flip() + theme_classic(base_size = 18) + ggtitle(\"Conferences by competitiveness in 2019\") + \n labs(y=\"EigenVector centralization\", x = \"Conference\") + \n scale_fill_gradientn(colors=colorRampPalette((brewer.pal(n = 12, name = \"RdYlBu\")))(100), guide=\"colorbar\") +\n theme(plot.title = element_text(size = 24), legend.position = \"none\") + scale_y_continuous(limits=c(0,10.5), expand=c(0,0)) +\n geom_label(aes(x = 28, y = 4, label = \"More competitive conferences\"), \n hjust = 0, \n vjust = 0.5, \n colour = \"#EE613D\", \n fill = \"white\", \n label.size = NA, \n family=\"Helvetica\", \n size = 6) + \n geom_label(aes(x = 7, y = 6.8, label = \"Less competitive conferences\"), \n hjust = 0, \n vjust = 0.5, \n colour = \"#6BA2CB\", \n fill = \"white\", \n label.size = NA, \n family=\"Helvetica\", \n size = 6)","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Atlantic Coast, Big Ten, and Southeastern conferences were amongst the least competitive in 2019, while Missouri Valey, Ivy League, and Big 12 conferences experienced the most competitive basketball atmosphere.\n\nSince we have a lot of historical data related to the games' results, there is a possibility to trace how the competitiveness in each basketball conference has changed over the years.","execution_count":null},{"metadata":{"_kg_hide-output":true,"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PREPROCESSING FOR TIME COMPARISION\noptions(warn=-1)\n\n\ndf_TeamConferences <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MTeamConferences.csv')\ndf_RegularSeasonCompactResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MRegularSeasonCompactResults.csv')\n\ndf_TeamConferences$TeamID <- as.character(df_TeamConferences$TeamID)\ndf_RegularSeasonCompactResults$WTeamID <- as.character(df_RegularSeasonCompactResults$WTeamID)\ndf_RegularSeasonCompactResults$LTeamID <- as.character(df_RegularSeasonCompactResults$LTeamID)\n\n### Conferences and seasons. Select for time-series plots\nconf_season <- data.frame(table(df_TeamConferences$ConfAbbrev, df_TeamConferences$Season))\ncolnames(conf_season) <- c(\"conf\", \"season\", \"teams\")\nconf_season <- conf_season %>% mutate(conf=as.character(conf), season=as.numeric(as.character(season)),\n teams=as.numeric(teams))\n\n# Select only regular games 2000 - 2019 with among conferences which are present in 2019\nconf_season <- conf_season %>% filter(season >= 2000 & season != 2020)\nconf_2019 <- (conf_season %>% filter(season == 2019 & teams > 0))$conf\nconf_season <- conf_season[conf_season$conf %in% conf_2019,] %>% filter(teams > 0)\n# Number of conferences for each year\n# table(conf_season$season)\n\n# Selected conferences\nselected_conferences <- unique(conf_season$conf)\n\n### Calculate the EigenVector centralization for each conference\n\ncalculateConferenceNetworkStatistics <- function(g){\n \n # 1. EigenVector centrality\n eigenvector_vec <- as.numeric(eigen_centrality(g, directed=T)$vector)\n \n # 2. Centralization metrics\n eigenvector_centralization <- centralize(eigenvector_vec, normalized = F)\n \n return(list(eigenvector_centralization=eigenvector_centralization))\n}\n\n\nconfernces_stats_seasons_list <- list()\n\nfor (conf_i in 1:length(unique(conf_season$season))){\n\n # Select only 2019 data and replicate TeamID column\n df_TeamConferences_ <- df_TeamConferences %>% filter(Season == unique(conf_season$season)[conf_i]) %>%\n mutate(WTeamID=TeamID, LTeamID=TeamID) %>% select(-c(Season))\n \n # Proportion of games played inside home confernces\n df_RegularSeasonCompactResults_ <- df_RegularSeasonCompactResults %>% filter(Season == unique(conf_season$season)[conf_i])\n \n df_RegularSeasonCompactResults_ <- df_RegularSeasonCompactResults_ %>%\n left_join(df_TeamConferences_ %>% select(c(ConfAbbrev, WTeamID)), \"WTeamID\") %>% rename(WConfAbbrev=ConfAbbrev) %>%\n left_join(df_TeamConferences_ %>% select(c(ConfAbbrev, LTeamID)), \"LTeamID\") %>% rename(LConfAbbrev=ConfAbbrev)\n \n df_RegularSeasonCompactResults_ <- df_RegularSeasonCompactResults_ %>% mutate(same_conf=WConfAbbrev==LConfAbbrev)\n \n # Select only matches in the same conference\n df_RegularSeasonCompactResults_ <- df_RegularSeasonCompactResults_ %>% filter(same_conf)\n \n # Create dataframe with team-to-team wins and loses\n team_to_team_results <- df_RegularSeasonCompactResults_ %>% \n # filter(Season >= 2009) %>% \n count(WTeamID, LTeamID) %>% \n arrange(desc(n)) %>% \n left_join(df_Teams %>% select(TeamID, TeamName), by = c(\"WTeamID\" = \"TeamID\")) %>% \n rename(WTeamName = TeamName) %>% \n left_join(df_Teams %>% select(TeamID, TeamName), by = c(\"LTeamID\" = \"TeamID\")) %>% \n rename(LTeamName = TeamName)\n team_to_team_results <- team_to_team_results %>%\n # select(-ends_with(\"ID\")) %>% \n rename(wins = n) %>% \n left_join(team_to_team_results %>% select(-ends_with(\"ID\")), by = c(\"WTeamName\" = \"LTeamName\", \"LTeamName\" = \"WTeamName\")) %>% \n rename(losses = n) %>% \n replace_na(list(wins = 0, losses = 0)) %>% \n mutate(win_perc = wins/(wins + losses) * 100) %>%\n # Select only teams with 10 or more games played between each other\n filter(wins+losses>=1) %>%\n mutate(WTeamID_LTeamID=paste(as.character(WTeamID), as.character(LTeamID), sep=\"_\"))\n \n # Create edgelist between teams on the wins agains each other\n edgelist_wteam_lteam <- df_RegularSeasonCompactResults_ %>% \n count(WTeamID, LTeamID) %>%\n mutate(WTeamID_LTeamID=paste(as.character(WTeamID), as.character(LTeamID), sep=\"_\")) %>%\n filter(WTeamID_LTeamID %in% team_to_team_results$WTeamID_LTeamID) %>% \n select(-c(WTeamID_LTeamID))\n colnames(edgelist_wteam_lteam)[3] <- 'weight'\n \n # Add conference name to edgelist\n edgelist_wteam_lteam <- edgelist_wteam_lteam %>% left_join(df_TeamConferences_ %>% select(ConfAbbrev, WTeamID), \"WTeamID\")\n \n # Change order of WTeamID and LTeamID\n edgelist_wteam_lteam <- edgelist_wteam_lteam %>% select(LTeamID, WTeamID, weight, ConfAbbrev)\n \n ### Create separate graph of matches for each conference\n conference_graphs_list <- list()\n confrence_names <- as.character(unique(edgelist_wteam_lteam$ConfAbbrev))\n \n for(i in 1:length(confrence_names)){\n \n conf_edgelist <- edgelist_wteam_lteam %>% filter(ConfAbbrev == confrence_names[i])\n conference_graphs_list[[i]] <- graph.data.frame(conf_edgelist, directed = T)\n \n }\n \n df_ConferencesNetworkStats <- lapply(conference_graphs_list, calculateConferenceNetworkStatistics)\n df_ConferencesNetworkStats <- do.call(rbind.data.frame, df_ConferencesNetworkStats)\n \n # Add team_id\n df_ConferencesNetworkStats$conference_name <- confrence_names\n # Add graph_list number\n df_ConferencesNetworkStats$id <- 1:nrow(df_ConferencesNetworkStats)\n \n # Add season year\n df_ConferencesNetworkStats$season <- unique(conf_season$season)[conf_i]\n \n # Add conferences stats to the list\n confernces_stats_seasons_list[[conf_i]] <- df_ConferencesNetworkStats\n \n}\n\n\ndf_conferences_stats_seasons <- do.call(rbind.data.frame, confernces_stats_seasons_list)\n\n\n# Select only conferences which were present in 2019\ndf_conferences_stats_seasons <- df_conferences_stats_seasons %>% filter(conference_name %in% selected_conferences)\n\n# Select only conferences with full years\nselected_conferences_2000 <- (df_conferences_stats_seasons %>% filter(season == 2000))$conference_name\ndf_conferences_stats_seasons <- df_conferences_stats_seasons %>% filter(conference_name %in% selected_conferences_2000) \ndf_conferences_stats_seasons <- df_conferences_stats_seasons %>% select(-c(id))\n\n# Add fullnames names of the conferences\ndf_conferences_stats_seasons <- df_conferences_stats_seasons %>% left_join(df_Conferences,by = c(\"conference_name\"=\"ConfAbbrev\"))\ndf_conferences_stats_seasons <- df_conferences_stats_seasons %>% rename(conference_fullname=Description)\ndf_conferences_stats_seasons$conference_fullname <- as.character(df_conferences_stats_seasons$conference_fullname)\n# Remove \"Conference\" word\ndf_conferences_stats_seasons$conference_fullname <- removeWords(df_conferences_stats_seasons$conference_fullname, \" Conference\")\ndf_conferences_stats_seasons$conference_name <- NULL\n\n# Create pheatmap object\nheatmap_comp <- spread(df_conferences_stats_seasons, season, eigenvector_centralization)\nrownames(heatmap_comp) <- heatmap_comp$conference_fullname\nheatmap_comp <- as.matrix(heatmap_comp %>% select(-c(conference_fullname)))\nheatmap_comp <- spread(df_conferences_stats_seasons, season, eigenvector_centralization)\nrownames(heatmap_comp) <- heatmap_comp$conference_fullname\nheatmap_comp <- as.matrix(heatmap_comp %>% select(-c(conference_fullname)))\nph <- pheatmap(heatmap_comp, cluster_cols = F, silent=T)\n\n# Order conference names according to the clustering done by pheatmap\ndf_conferences_stats_seasons$conference_fullname <- factor(df_conferences_stats_seasons$conference_fullname, levels=ph$tree_row$labels[ph$tree_row$order])\n","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PLOT THE HEATMAP WITH CONFERENCES AND SEASONS COMPETITIVENESS\n\nggplot(df_conferences_stats_seasons,\n aes(season, conference_fullname)) + geom_tile(aes(fill=eigenvector_centralization),color = \"white\") +\n #Creating legend\n guides(fill=guide_colorbar(\"EigenVector centralization\")) +\n #Creating color range RdYlBu\n scale_fill_gradientn(colors=colorRampPalette((brewer.pal(n = 7, name = \"RdYlBu\")))(100),guide=\"colorbar\") +\n #Rotating labels\n theme(axis.text.x = element_text(angle = 0, hjust = 0,vjust=-0.05)) + theme_minimal(base_size = 18) +\n ggtitle(\"Competitiveness inside conferences \\n in 2000-2019\") + labs(y=\"Conferences\", x = \"Season\") +\n theme(plot.title = element_text(size = 24), axis.ticks = element_blank(),\n panel.grid.major = element_blank(), panel.grid.minor = element_blank(),\n axis.text.y = element_text(margin = margin(r = 0))) + scale_x_continuous(expand=c(0,0))","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"Historically a group of conferences has had a more competitive environment (e.g., Missouri Valley and Ivy League), whereas others have always been located on the one side of the spectrum, where a winner or a small set of possible winners could be predicted in advance (e.g., Conference USA). One can also notice interesting changes happened to some of the conferences like Big East: despite being highly one-sided in around 2004-2014, it evolved to significantly more competitive games later on.","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"# 4. Can Network Methodology Help us Explain the Games' Outcomes?","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"An additional increment that we make refers to the creation of a network of teams, using **all the games** played during the 2019 Season (see below). The graph highlights the 2019 winner of the March Madness (namely, Virginia) and its connections with the other teams that were defeated by the winner during the season. In this section, we analyze this network leveraging a method, called Exponential Random Graph Modeling (ERGM).","execution_count":null},{"metadata":{"_kg_hide-input":true,"_kg_hide-output":true,"trusted":true},"cell_type":"code","source":"################ CREATE COMBINED GRAPH OF ALL GAMES (REGULAR, TOURNEY)\n\n# Load Tourney results in 2019\ndf_TourneyCompactResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MNCAATourneyCompactResults.csv')\ndf_TourneyCompactResults <- df_TourneyCompactResults %>% filter(Season == 2019) %>%\n select(WTeamID, LTeamID)\n\n# Load Regular Season results in 2019\ndf_RegularSeasonCompactResults <- read.csv('../input/march-madness-analytics-2020/MDataFiles_Stage2/MRegularSeasonCompactResults.csv')\ndf_RegularSeasonCompactResults <- df_RegularSeasonCompactResults %>% filter(Season == 2019) %>%\n select(WTeamID, LTeamID)\n\n# Combine Regular and Tourney results\ndf_FullCompactResults <- rbind(df_TourneyCompactResults, df_RegularSeasonCompactResults)\n\n# Recode TeamID to character\ndf_FullCompactResults$WTeamID <- as.character(df_FullCompactResults$WTeamID)\ndf_FullCompactResults$LTeamID <- as.character(df_FullCompactResults$LTeamID)\n\n\n# Create dataframe with team-to-team wins and loses\nteam_to_team_results_full <- df_FullCompactResults %>% \n # filter(Season >= 2009) %>% \n count(WTeamID, LTeamID) %>% \n arrange(desc(n)) %>% \n left_join(df_Teams %>% select(TeamID, TeamName), by = c(\"WTeamID\" = \"TeamID\")) %>% \n rename(WTeamName = TeamName) %>% \n left_join(df_Teams %>% select(TeamID, TeamName), by = c(\"LTeamID\" = \"TeamID\")) %>% \n rename(LTeamName = TeamName)\n\nteam_to_team_results_full <- team_to_team_results_full %>%\n # select(-ends_with(\"ID\")) %>% \n rename(wins = n) %>% \n left_join(team_to_team_results_full %>% select(-ends_with(\"ID\")), by = c(\"WTeamName\" = \"LTeamName\", \"LTeamName\" = \"WTeamName\")) %>% \n rename(losses = n) %>% \n replace_na(list(wins = 0, losses = 0)) %>% \n mutate(win_perc = wins/(wins + losses) * 100) %>%\n # Select only teams with 10 or more games played between each other\n filter(wins+losses>=1) %>%\n mutate(WTeamID_LTeamID=paste(as.character(WTeamID), as.character(LTeamID), sep=\"_\"))\n\n# Create edgelist between teams on the wins agains each other\nedgelist_wteam_lteam_full <- df_FullCompactResults %>% \n count(WTeamID, LTeamID) %>%\n mutate(WTeamID_LTeamID=paste(as.character(WTeamID), as.character(LTeamID), sep=\"_\")) %>%\n filter(WTeamID_LTeamID %in% team_to_team_results_full$WTeamID_LTeamID) %>% \n select(-c(WTeamID_LTeamID))\ncolnames(edgelist_wteam_lteam_full)[3] <- 'weight'\n\n# Drop weights\nedgelist_wteam_lteam_full$weight <- NULL\n\n# Change order of WTeam and LTeam\nedgelist_wteam_lteam_full <- edgelist_wteam_lteam_full %>% select(LTeamID, WTeamID)\n\n# Create the network\ng_teams_full <- graph.data.frame(edgelist_wteam_lteam_full, directed = T)","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ PLOT THE NETWORK OF ALL MATCHES IN 2019\n\n# Adjust plotting window\noptions(repr.plot.width=16, repr.plot.height = 16)\n\n# Add team names\nvertex_ids <- data.frame(TeamID=names(V(g_teams_full)))\ndf_Teams$TeamID <- as.character(df_Teams$TeamID)\nvertex_ids <- vertex_ids %>% left_join(df_Teams %>% select(TeamID, TeamName), \"TeamID\")\nvertex_fullnames <- as.character(vertex_ids$TeamName)\ng_teams_full <- set_vertex_attr(g_teams_full, \"fullname\", value=vertex_fullnames)\n\n# Set vertex sizes\nvertex_size <- as.numeric(strength(g_teams_full, mode=\"in\"))*0.25\n\n# Get the Team ID of 2019 Winner\nTeamID_winner <- (df_Teams %>% filter(TeamName == \"Virginia\"))$TeamID\n\n# Teams which lost to the Winner team\nlost_teams <- edgelist_wteam_lteam_full %>% filter(WTeamID == TeamID_winner)\nlost_teams <- unique(lost_teams$LTeamID)\n\n# Edge color\n# edge_color <- ifelse(edgelist_wteam_lteam_full$WTeamID == TeamID_winner, \"lightcoral\", \"gray90\")\nedge_color <- ifelse(edgelist_wteam_lteam_full$WTeamID == TeamID_winner, \"lightcoral\", adjustcolor(\"gray90\", alpha=0.5))\n\n# Wider edges for the winner team\nedge_width <- ifelse(edgelist_wteam_lteam_full$WTeamID == TeamID_winner, 2, 1)\n\n# Color only Winner team and teams which lost to the Winner team\n# vertex_color <- ifelse(vertex.attributes(g_teams_full)$fullname == \"Virginia\", \"lightcoral\", \"gray90\")\nvertex_color <- ifelse(vertex.attributes(g_teams_full)$fullname == \"Virginia\", \"lightcoral\",\n ifelse(names(V(g_teams_full)) %in% lost_teams, adjustcolor(\"lightcoral\", alpha=0.5),\n adjustcolor(\"gray90\", alpha=0.5)))\n\n# Label only winner team\nvertex_label <- ifelse(vertex.attributes(g_teams_full)$fullname == \"Virginia\", \"Virginia\", NA)\n\nset.seed(42)\n# Plot the graph\nplot.igraph(g_teams_full, edge.arrow.size=0.2, layout=layout.fruchterman.reingold, edge.width=edge_width,\n vertex.size=vertex_size, vertex.frame.color='darkgrey',\n edge.color=edge_color,\n vertex.label=vertex_label,\n vertex.label.color='black', vertex.label.font=2, vertex.label.cex=1.8,\n vertex.color=vertex_color,\n edge.curved=T)\ntitle(\"Tourney and Regular Season Games in 2019 \\n and the Winner of \\\"March Madness\\\"\",cex.main=2)\n","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"_kg_hide-output":true,"trusted":true},"cell_type":"code","source":"################ ERGM PREPROCESSING\n\n### Add team stats as node attributes\ntemp_stats <- data.frame(TeamID=names(V(g_teams_full)))\ntemp_stats$TeamID <- as.character(temp_stats$TeamID)\ntemp_stats <- temp_stats %>%\n left_join(team_stats_full %>% mutate(TeamID=as.character(TeamID)), \"TeamID\")\n\ng_teams_full <- set_vertex_attr(graph=g_teams_full, name=\"TSPerc\",\n value=temp_stats$TSPerc)\ng_teams_full <- set_vertex_attr(graph=g_teams_full, name=\"AstRatio\",\n value=temp_stats$AstRatio)\ng_teams_full <- set_vertex_attr(graph=g_teams_full, name=\"TORatio\",\n value=temp_stats$TORatio)\ng_teams_full <- set_vertex_attr(graph=g_teams_full, name=\"ThreesShare\",\n value=temp_stats$ThreesShare)\ng_teams_full <- set_vertex_attr(graph=g_teams_full, name=\"FTRate\",\n value=temp_stats$FTRate)\ng_teams_full <- set_vertex_attr(graph=g_teams_full, name=\"AvgPoss\",\n value=temp_stats$AvgPoss)\ng_teams_full <- set_vertex_attr(graph=g_teams_full, name=\"EFGPerc\",\n value=temp_stats$AvgPoss)\n\n# Transform igraph to network class\ng_teams_full_net <- asNetwork(g_teams_full)","execution_count":null,"outputs":[]},{"metadata":{"trusted":true},"cell_type":"markdown","source":"We pursue the goal of answering the following question using a network-based methodology: what are the team-related attributes that can influence the probability of winning a game? That is to say, what are the team’s characteristics that can increase or decrease the probability of forming a directed link in the described graph?\n\nTo approach this issue, we use a statistical method termed Exponential Random Graph Modeling (ERGM). ERGM is a method in the area of social network analysis that allows building complex network structures and modeling relationships between them [8]. The model assumes that the emergence of a tie may be affected by individual attributes or the presence or absence of other ties. A distinctive feature of ERGM is that this model focuses on both a structural angle (e.g., transitivity, reciprocity) and individual aspects of vertices in the network. Since ERGM is complicated in terms of the analytical solution, it uses a Markov Chain Monte Carlo (MCMC) approach for the estimation procedure.\n\nThe present investigation exploits a range of college basketball teams’ attributes that can be calculated from the data:\n\n*\t*TSPerc* - True Shooting Percentage\n\n*\t*AstRatio* - Assist Ratio\n\n*\t*TORatio* - Turnover Ratio\n\n*\t*AvgPoss* - Average Possessions\n\n*\t*FTRate* - Free Throw Rate\n\n*\t*ThreesShare* - Three Pointers Share\n\nWe leverage the following ERGM terms that are suitable for a directed network and continuous features of nodes (teams) [7]: \n\n*\t**edges (the effect of a covariate for in-edges)**: the term introduces a network statistic equal to the number of edges in the graph.\n\n*\t**mutual (the effect of mutuality)**: in binary ERGMs this term adds a statistic equal to the number of pairs of nodes $i$ and $j$ for which $(i,j)$ and $(j,i)$ both exist.\n\n*\t**nodeicov**: the total attribute value of a node $j$ for all edges $(i,j)$ in the network.\n\n*\t**diff**: this term plugs a network statistic that is equal to the sum of differences between the origin of a directed link $(i)$ and a head as its destination $(j)$ over all directed edges $(i,j)$.\n\n\nFirst, we specify a model with solely structural terms and then add the terms that deal with characteristics of vertices. An interested reader can find The ERGM diagnostics procedures in the code. The table below shows parameter estimates for our base and main specifications. Further, we outline and interpret an array of inferences that can be made.","execution_count":null},{"metadata":{"_kg_hide-input":true,"_kg_hide-output":true,"trusted":true},"cell_type":"code","source":"################ ERGM SPECIFICATION\n\nset.seed(1234)\nergm_model.0 <- ergm(g_teams_full_net ~ edges + mutual, verbose = F)\nergm_model <- ergm(g_teams_full_net ~ edges + mutual + \n nodeicov(\"TSPerc\") + \n nodeicov(\"AstRatio\") +\n nodeicov(\"TORatio\") + \n nodeicov(\"ThreesShare\") + \n nodeicov(\"FTRate\") + \n nodeicov(\"AvgPoss\") + \n diff(\"TSPerc\") + \n diff(\"AstRatio\") +\n diff(\"TORatio\") + \n diff(\"ThreesShare\") + \n diff(\"FTRate\") + \n diff(\"AvgPoss\"), verbose = F)\n\n# Model\n# For in-degree and out-degree and simulated quantiles the model looks good.\n#m.gof <- gof(ergm_model)\n#par(mfrow=c(1,1))\n#plot(m.gof)\n\n# MCMC diagnstics\n# MCMC convergences looks adequate\n#par(mar=c(0,0,0,0))\n#mcmc.diagnostics(ergm_model)","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"################ ERGM RESULTS\nstargazer(ergm_model.0, ergm_model, type = 'text',\n title = \"RESULTS OF ERGM ESTIMATION\",\n dep.var.caption = \"\",\n dep.var.labels.include = F,\n column.labels = c('Base Model', 'Main Model'), single.row = T)","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"edges_prob <- round(100*plogis(ergm_model.0$coef[['edges']]),2)\ncat('The probability of a directed tie formation (winning), holding mutuality effect constant, is equal to:', edges_prob, '%')","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"This means that our network in terms of link formation is significantly different from a random graph: it has much lower connections between teams than expected by chance. This is understandable: teams are segregated by conferences where the bulk of the matches are held. This, therefore, determines the low connectivity of the network.","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"mutual_prob <- round(100*plogis(ergm_model.0$coef[['mutual']]),2)\ncat('The probability of a directed tie formation (winning), given the presence of mutual ties, is equal to:', mutual_prob, '%')","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"In other words, we are much more likely to see a tie from a node $i$ to a node $j$ if $j$ to $i$ is true than if $j$ does not nominate $i$. This is indicative of the fact that the behavior of the teams, in general, is highly non-deterministic: in a pair of teams both of them can win and lose a match (i.e., send and receive a tie) over the same season.\n\nLet us proceed to the interpretation of the ERGM terms responsible for the attributes of the nodes in our main model. As for the nodeicov effect, there are 2 statistically significant coefficients registered for TORatio (negative influence) and FTRate (positive influence). Specifically, this indicates that growth in the Turnover Ratio of a team reduces its chances to win, whereas growth in the Free Throw Rate increases its chances to defeat a competitor.\n\nWe can compute probabilities ofwinning a game for the selected values of TORatio and FTRate attributes. Let us demonstrate that only for one characteristic, using its minimum and maximum observed values as examples of high and low feature manifestations.","execution_count":null},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"nodeicov.TORatio_prob_min <- round(100*plogis(ergm_model$coef[['edges']] + \n ergm_model$coef[['mutual']] +\n ergm_model$coef[['nodeicov.TORatio']]*\n min(V(g_teams_full)$TORatio)),2)\n\nnodeicov.TORatio_prob_max <- round(100*plogis(ergm_model$coef[['edges']] + \n ergm_model$coef[['mutual']] +\n ergm_model$coef[['nodeicov.TORatio']]*\n max(V(g_teams_full)$TORatio)),2)\n\ncat('The probability of a directed tie formation (winning) for a team with HIGH Turnover Ratio is equal to:', nodeicov.TORatio_prob_max, '%') ","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"cat('The probability of a directed tie formation (winning) for a team with LOW Turnover Ratio is equal to:', nodeicov.TORatio_prob_min, '%')","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"As for the *difference* components in our model, each of the respective attributes demonstrated a statistical significance. *True Shooting Percentage, Assist Ratio, Free Throw Rate showed* negative signs, while *Turnover Ratio, Three Pointers Share*, and *AvgPoss* - positive signs. For the positive effects, this means that higher chances of victory belong to those teams that have lower values of the analyzed attribute in comparison to the values of their competitors. For instance, if a team with small True Shooting Percentage is playing with a team with huge True Shooting Percentage the former has greater chances to beat the latter.\n\nContrariwise, for the negative effects, the finding informs us that teams are more likely to become winners in a game if they have a greater manifestation of the respective attribute compared to that of their competitors. For example, if a team with small Average Possessions is playing with a team with huge values of the Average Possessions the latter has greater chances to beat the former.\n\nWe can demonstrate these statements, taking one variable and calculating the corresponding probabilities for several combinations of its values (maximum and minimum) for a pair of teams (see below).","execution_count":null},{"metadata":{"_kg_hide-input":true,"_kg_hide-output":true,"trusted":true},"cell_type":"code","source":"diff.t_h.AstRatio_min_max <- round(100*plogis(ergm_model$coef[['edges']] + \n ergm_model$coef[['mutual']] +\n ergm_model$coef[['diff.t-h.AstRatio']]*\n (min(V(g_teams_full)$TORatio) - \n max((V(g_teams_full)$TORatio)))),2)\n\ndiff.t_h.AstRatio_max_max <- round(100*plogis(ergm_model$coef[['edges']] + \n ergm_model$coef[['mutual']] +\n ergm_model$coef[['diff.t-h.AstRatio']]*\n (max(V(g_teams_full)$TORatio) - \n max((V(g_teams_full)$TORatio)))),2)\n\ndiff.t_h.AstRatio_min_min <- round(100*plogis(ergm_model$coef[['edges']] + \n ergm_model$coef[['mutual']] +\n ergm_model$coef[['diff.t-h.AstRatio']]*\n (min(V(g_teams_full)$TORatio) - \n min((V(g_teams_full)$TORatio)))),2)\n\ndiff.t_h.AstRatio_max_min <- round(100*plogis(ergm_model$coef[['edges']] + \n ergm_model$coef[['mutual']] +\n ergm_model$coef[['diff.t-h.AstRatio']]*\n (max(V(g_teams_full)$TORatio) - \n min((V(g_teams_full)$TORatio)))),2)","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"cat('The probability of a directed tie formation (winning) for a team with HIGH Assist Ratio when its competitor has LOW True Shooting Percentage is equal to:', diff.t_h.AstRatio_min_max, '%') ","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"cat('The probability of a directed tie formation (winning) for a team with HIGH Assist Ratio when its competitor has HIGH True Shooting Percentage is equal to:', diff.t_h.AstRatio_max_max, '%') ","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"cat('The probability of a directed tie formation (winning) for a team with LOW Assist Ratio when its competitor has LOW True Shooting Percentage is equal to:', diff.t_h.AstRatio_min_min, '%') ","execution_count":null,"outputs":[]},{"metadata":{"_kg_hide-input":true,"trusted":true},"cell_type":"code","source":"cat('The probability of a directed tie formation (winning) for a team with LOW Assist Ratio when its competitor has HIGH True Shooting Percentage is equal to:', diff.t_h.AstRatio_max_min, '%') ","execution_count":null,"outputs":[]},{"metadata":{},"cell_type":"markdown","source":"In a nutshell, the presented analytical work shows that ERGM allows us to comprehensively model an interrelated structure of the data by incorporating a variety of nuanced relational parameters.","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"# Conclusion","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"In this work, we showed that using play-by-play data one can build a team network of assists and specify multiple network centrality measures that can be instrumental in defining the importance of players in a team. It was demonstrated that the team related centralization characteristics are capable of affecting the outcome of a team play.\n\nUsing information about matches' outcomes, the study creates a directed network of teams. By utilizing EigenVector centrality, we showed a way to describe competitiveness within the conferences. Also, we illustrated that Social Network Analysis can be useful in understanding the conditions that lead to a certain match outcome. Particularly, Exponential Random Graph Modeling enables us to explore the complex structure of relationships that emerge between teams during a season.\n\nOverall, a network-based methodology is a fruitful and powerful technique in sports analytics: it can serve as a fully-scaled approach or may complement classical statistical instruments.\n","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"# References","execution_count":null},{"metadata":{"trusted":true},"cell_type":"markdown","source":"1. Kaggle competition: Predicting Molecular Properties. https://www.kaggle.com/c/champs-scalar-coupling\n2. Gonçalves, B., Coutinho, D., Santos, S., Lago-Penas, C., Jiménez, S., & Sampaio, J. (2017). Exploring team passing networks and player movement dynamics in youth association football. PloS one, 12(1).\n3. Clemente, F. M., Martins, F. M. L., & Mendes, R. S. (2016). Analysis of scored and conceded goals by a football team throughout a season: a network analysis. Kinesiology: International journal of fundamental and applied kinesiology, 48(1), 103-114.\n4. Burtch, S. (2015). Passing Networks in Hockey. RIT Analytics Conference 2015.\n5. Park, J., & Newman, M. E. (2005). A network-based ranking system for US college football. Journal of Statistical Mechanics: Theory and Experiment, 2005(10), P10014.\n6. Milekhina, A. (2020) How to explore potential of a tennis player using tools of SNA?. XXI April International Academic Conference on Economic and Social Development.\n7. ergm-terms: Terms used in Exponential Family Random Graph Models. https://rdrr.io/cran/ergm/man/ergm-terms.html\n8. Robinsa, G., Snijdersb, T., Wanga, P., Handcockc, M., & Pattisona, P. (2007). Recent developments in exponential random graph (p*) models for social networks. Social Networks, 29, 192-215.","execution_count":null},{"metadata":{},"cell_type":"markdown","source":"P.S. We would like to acknowledge the work done by [@headsortails](https://www.kaggle.com/headsortails/jump-shot-to-conclusions-march-madness-eda) and [@jaseziv83](https://www.kaggle.com/jaseziv83/moreyball-in-the-college-game-a-full-ncaa-eda), their excellent notebooks helped us a lot during this competition.","execution_count":null}],"metadata":{"kernelspec":{"display_name":"R","language":"R","name":"ir"},"language_info":{"mimetype":"text/x-r-source","name":"R","pygments_lexer":"r","version":"3.4.2","file_extension":".r","codemirror_mode":"r"}},"nbformat":4,"nbformat_minor":4}