--- title: "Simple k-factor optimized Elo based model" output: html_document: df_print: paged --- Let's try to build a model which estimates the teams' strenghts using Elo ratings. We will only care about the win/loss-result of the games, and ignore the scores and any home-field advantage. Furthermore, we'll assume the teams start from scratch each season so their past performance is not taken into account. ## Importing data ```{r setup, echo=FALSE} library(tidyverse) library(elo) library(MLmetrics) ``` Rearrange games such that they are defined by `TeamID` vs `OpponentTeamID` where `TeamID` < `OpponentTeamID`. For this we have to rename columns and make the location the location of the first team (`TeamID`), and add an explicit result. ```{r} invert_loc <- function (loc) { if_else(loc == "N", "N", if_else(loc == "H", "A", "H")) } rearrange_games <- function(data) { data %>% mutate(KeepOrder = WTeamID > LTeamID, TeamID = if_else(KeepOrder, WTeamID, LTeamID), Score = if_else(KeepOrder, WScore, LScore), OpponentTeamID = if_else(KeepOrder, LTeamID, WTeamID), OpponentScore = if_else(KeepOrder, LScore, WScore), Loc = if_else(KeepOrder, WLoc, invert_loc(WLoc)), Result = if_else(KeepOrder, 1, 0)) %>% select(Season, DayNum, TeamID, Score, OpponentTeamID, OpponentScore, Loc, NumOT, Result) } ``` ```{r} season <- read_csv("../input/google-cloud-ncaa-march-madness-2020-division-1-womens-tournament/WDataFiles_Stage1/WRegularSeasonCompactResults.csv") %>% rearrange_games() tourney <- read_csv("../input/google-cloud-ncaa-march-madness-2020-division-1-womens-tournament/WDataFiles_Stage1/WNCAATourneyCompactResults.csv") %>% rearrange_games() teams <- read_csv("../input/google-cloud-ncaa-march-madness-2020-division-1-womens-tournament/WDataFiles_Stage1/WTeams.csv") %>% select(TeamID, TeamName) ``` ## Elo calculation We'll let he `elo` package do all the heavy lifting. The $k$-factor defines how much a team's Elo is updated after a game: higher $k$, higher change to the Elo. Since it's not obvious which value to use, we'll try and pick one which maximizes the predictive performance on the tournament games. We'll assume that the teams start from scratch each season with a default Elo of 1500. ```{r} # Calculate Elos for all games in data frame calculate_elos <- function(data, k) { er <- elo.run(Result ~ factor(TeamID) + factor(OpponentTeamID), data = data, k = k) elos <- final.elos(er) tibble(TeamID = as.numeric(names(elos)), Elo = elos) } # Caluclate Elos for each season separately seasonal_elos <- function(data, k) { data %>% group_by(Season) %>% group_modify(function (data, season) calculate_elos(data, k)) } ``` We'll compare the performance on a variety of useful metrics. ```{r} # Evaluate the performance of a single k value based on Elos from `season` applied to `tourney` evaluate_k <- function (season, tourney, k) { elos <- seasonal_elos(season, k) tourney %>% inner_join(elos, by = c("Season", "TeamID")) %>% inner_join(elos %>% rename(OpponentElo = Elo), by = c("Season", "OpponentTeamID" = "TeamID")) %>% mutate(WinningProbability = elo.prob(Elo, OpponentElo), Prediction = if_else(WinningProbability > 0.5, 1, 0)) %>% group_by(Season) %>% summarize(LogLoss = LogLoss(WinningProbability, Result), Accuracy = Accuracy(Prediction, Result), Precision = Precision(Prediction, Result), Recall = Recall(Prediction, Result), F1_Score = F1_Score(Prediction, Result), AUC = AUC(WinningProbability, Result)) } # Average performance over all seasons mean_evaluate_k <- function (season, tourney, k){ evaluate_k(season, tourney, k) %>% summarize_all(mean) %>% mutate(k = k) %>% select(k, everything(), -Season) } ``` ```{r} k_evaluations <- map_dfr(1:200, function (k) mean_evaluate_k(season, tourney, k)) ``` ```{r} k_evaluations %>% ggplot(aes(x = k, y = LogLoss)) + geom_line() + ggtitle("Log-loss depending on the k-factor") + xlab("k") + ylab("log-loss") ``` ```{r} k_evaluations %>% ggplot(aes(x = k, y = AUC)) + geom_line() + ggtitle("AUC depending on the k-factor") + xlab("k") + ylab("AUC") ``` ```{r} k_evaluations %>% select(-LogLoss, -AUC) %>% pivot_longer(-k, names_to = "Metric", values_to = "Value") %>% ggplot(aes(x = k, y = Value, color = Metric)) + geom_line() + ggtitle("Standard metrics depending on the k-factor") + xlab("k") + ylab(NULL) ``` ```{r} k_evaluations %>% top_n(10, -LogLoss) %>% arrange(-LogLoss) ``` ```{r} k_evaluations %>% top_n(10, Accuracy) %>% arrange(Accuracy) ``` ```{r} k_evaluations %>% top_n(10, F1_Score) %>% arrange(Accuracy) ``` ```{r} k_evaluations %>% top_n(10, AUC) %>% arrange(AUC) ``` Looking at the overall performance for the top-10 $k$-values for each metric suggests that $k ≈ 110$ might be a good choice. In the men's competition, it appears that $k ≈ 76$ is a good value. ([Notebook](https://www.kaggle.com/christoffer/simple-k-optimized-elo-model)) ```{r} k_opt <- 110 ``` ## Team Elos ```{r} elos <- season %>% seasonal_elos(k = k_opt) ``` The top-3 highest rated teams each season: ```{r} top_3_elos <- elos %>% mutate(Elo = round(Elo)) %>% group_by(Season) %>% top_n(3, Elo) %>% ungroup() %>% inner_join(teams, by = "TeamID") %>% arrange(-Season, -Elo) top_3_elos ``` ## Submission We can already estimate the performance on the stage 1 data: ```{r} stage1_loglosses <- evaluate_k(season %>% filter(Season >= 2015), tourney %>% filter(Season >= 2015), k_opt) stage1_loglosses ``` ```{r} stage1_loglosses %>% summarize(mean(LogLoss)) %>% pull() ``` Not great, but also not horrible. Let's create a submission file and see if our estimate is correct. ```{r} tourney_seeds <- read_csv("../input/google-cloud-ncaa-march-madness-2020-division-1-womens-tournament/WDataFiles_Stage1/WNCAATourneySeeds.csv") ``` ```{r} season_submission <- function (data, season) { teams <- unique(data$TeamID) elos <- data %>% select(TeamID, Elo) expand_grid(TeamID = teams, OpponentTeamID = teams) %>% filter(TeamID < OpponentTeamID) %>% inner_join(data, by = "TeamID") %>% inner_join(data %>% rename(OpponentElo = Elo), by =c("OpponentTeamID" = "TeamID")) %>% unite(GameID, TeamID, OpponentTeamID, sep = "_") %>% mutate(pred = elo.prob(Elo, OpponentElo)) %>% select(GameID, pred) } submission <- function (seeds, elos) { seeds %>% inner_join(elos, by = c("Season", "TeamID")) %>% group_by(Season) %>% group_modify(season_submission) %>% unite(id, Season, GameID, sep = "_") %>% arrange(id) } ``` ```{r} submission(tourney_seeds %>% filter(Season >= 2015), elos) %>% write_csv("submission.csv") ```