Machine Learning Madness: A Woeful Attempt at Predicting this Year’s NCAA Tourney

Busted brackets are nothing new. Just ask anyone who routinely fills them out for the NCAAM Basketball Tournament. Personally, I can identify with such individuals. Year after year, my predictions never fail to disappoint. This year, however, had something different in store: the use of machine learning. Could a predictive model achieve greater success than my intuition?

Unfortunately, the answer ended up as a resounding no. Competing against my classmates and professor, my bracket ultimately ranked 14th out of the 17 submitted. So what went wrong? Was it my novice status when it comes to machine learning? Or perhaps the unprecedented unpredictable nature of this year’s tourney is to blame for such a disasterclass. Regardless of the reasons, there actually was a method to my madness.

Code

library(tidyverse)
library(tidymodels)
library(hoopR)
library(zoo)
library(gt)
library(ggrepel)

set.seed(1234)

teamgames <- load_mbb_team_box(seasons = 2015:2023) %>%
  filter(game_date < as.Date("2023-03-14"))

teamgames <- load_mbb_team_box(seasons = 2015:2023) %>%
  filter(game_date < as.Date("2023-03-14"))

teamstats <- teamgames %>% 
  mutate(
    possessions = field_goals_attempted - offensive_rebounds + turnovers + (.475 * free_throws_attempted),
    ppp = team_score/possessions,
    eFGpercentage = (field_goals_made + 0.5 * three_point_field_goals_made) / (field_goals_attempted),
    weighted_orb = (offensive_rebounds * 0.01),
    weighted_tov = (total_turnovers * 0.01),
    weighted_fta = (free_throws_attempted * 0.03),
    predictivefactors = (0.3 * ppp) + (50 * eFGpercentage) + weighted_orb - weighted_tov + weighted_fta 
  )

rollingteamstats <- teamstats %>% 
  group_by(team_short_display_name, season) %>%
  arrange(game_date) %>%
  mutate(
    team_rolling_score = rollmean(lag(team_score, n=1), k=3, align="right", fill=NA),
    possessions = field_goals_attempted - offensive_rebounds + turnovers + (.475 * free_throws_attempted),
    team_rolling_possessions = rollmean(lag(possessions, n=1), k=3, align="right", fill=NA),
    ppp = team_score/possessions,
    team_rolling_ppp = rollmean(lag(ppp, n=1), k=10, align="right", fill=NA),
    eFGpercentage = (field_goals_made + 0.5 * three_point_field_goals_made) / (field_goals_attempted),
    team_rolling_eFGpercentage = rollmean(lag(eFGpercentage, n=1), k=7, align="right", fill=NA),
    weighted_orb = (offensive_rebounds * 0.01),
    team_rolling_weighted_orb = rollmean(lag(weighted_orb, n=1), k=7, align="right", fill=NA),
    weighted_tov = (total_turnovers * 0.01),
    team_rolling_weighted_tov = rollmean(lag(weighted_tov, n=1), k=7, align="right", fill=NA),
    weighted_fta = (free_throws_attempted * 0.03),
    team_rolling_weighted_fta = rollmean(lag(weighted_fta, n=1), k=7, align="right", fill=NA),
    predictivefactors = (0.3 * ppp) + (50 * eFGpercentage) + weighted_orb - weighted_tov + weighted_fta,
    team_rolling_predictivefactors = rollmean(lag(predictivefactors, n=1), k=7, align="right", fill=NA)
    ) %>% 
  ungroup()

team_side <- rollingteamstats %>%
  select(
    game_id,
    team_id, 
    team_short_display_name, 
    opponent_team_id, 
    game_date, 
    season, 
    team_score,
    team_rolling_score,
    possessions,
    team_rolling_possessions,
    ppp,
    team_rolling_ppp,
    eFGpercentage,
    team_rolling_eFGpercentage,
    weighted_orb,
    team_rolling_weighted_orb,
    weighted_tov,
    team_rolling_weighted_tov,
    weighted_fta,
    team_rolling_weighted_fta,
    predictivefactors,
    team_rolling_predictivefactors
    )

opponent_side <- team_side %>%
  select(-opponent_team_id) %>% 
  rename(
    opponent_team_id = team_id,
    opponent_short_display_name = team_short_display_name,
    opponent_score = team_score,
    opponent_rolling_score = team_rolling_score,
    opponent_possessions = possessions,
    opponent_rolling_possessions = team_rolling_possessions,
    opponent_ppp = ppp,
    opponent_rolling_ppp = team_rolling_ppp,
    opponent_eFGpercentage = eFGpercentage,
    opponent_rolling_eFGpercentage = team_rolling_eFGpercentage,
    opponent_weighted_orb = weighted_orb,
    opponent_rolling_weighted_orb = team_rolling_weighted_orb,
    opponent_weighted_tov = weighted_tov,
    opponent_rolling_weighted_tov = team_rolling_weighted_tov,
    opponent_weighted_fta = weighted_fta,
    opponent_rolling_fta = team_rolling_weighted_fta,
    opponent_predictivefactors = predictivefactors,
    opponent_rolling_predictivefactors = team_rolling_predictivefactors
  ) %>%
  mutate(opponent_team_id = as.numeric(opponent_team_id)
)

games <- team_side %>% inner_join(opponent_side)

games <- games %>% mutate(
  team_result = as.factor(case_when(
    team_score > opponent_score ~ "W",
    opponent_score > team_score ~ "L"
))) %>% na.omit()

modelgames <- games %>% 
  select(
    game_id, 
    game_date, 
    team_short_display_name, 
    opponent_short_display_name, 
    season, 
    team_rolling_predictivefactors, 
    opponent_rolling_predictivefactors, 
    team_result
    ) %>%
  na.omit()

game_split <- initial_split(modelgames, prop = .8)
game_train <- training(game_split)
game_test <- testing(game_split)

log_mod <- 
  logistic_reg() %>% 
  set_engine("glm") %>%
  set_mode("classification")

game_recipe <- 
  recipe(team_result ~ ., data = game_train) %>% 
  update_role(game_id, game_date, team_short_display_name, opponent_short_display_name, season, new_role = "ID") %>%
  step_normalize(all_predictors())

log_workflow <- 
  workflow() %>% 
  add_model(log_mod) %>% 
  add_recipe(game_recipe)

log_fit <- 
  log_workflow %>% 
  fit(data = game_train)

southround1games <- tibble(
  team_short_display_name="Alabama",
  opponent_short_display_name="Texas A&M-CC"
) %>% add_row(
  team_short_display_name="Maryland",
  opponent_short_display_name="West Virginia"
) %>% add_row(
  team_short_display_name="San Diego St",
  opponent_short_display_name="Charleston"
) %>% add_row(
  team_short_display_name="Virginia",
  opponent_short_display_name="Furman"
) %>% add_row(
  team_short_display_name="Creighton",
  opponent_short_display_name="NC State"
) %>% add_row(
  team_short_display_name="Baylor",
  opponent_short_display_name="UCSB"
) %>% add_row(
  team_short_display_name="Missouri",
  opponent_short_display_name="Utah State"
) %>% add_row(
  team_short_display_name="Arizona",
  opponent_short_display_name="Princeton"
)

southround1games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(southround1games)
  
southround1games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(southround1games) 

southround1 <- log_fit %>% predict(new_data = southround1games) %>%
  bind_cols(southround1games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

southround1 <- log_fit %>% predict(new_data = southround1games, type="prob") %>%
  bind_cols(southround1) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

southround2games <- tibble(
  team_short_display_name="Texas A&M-CC",
  opponent_short_display_name="Maryland"
) %>% add_row(
  team_short_display_name="Charleston",
  opponent_short_display_name="Furman"
) %>% add_row(
  team_short_display_name="Creighton",
  opponent_short_display_name="UCSB"
) %>% add_row(
  team_short_display_name="Utah State",
  opponent_short_display_name="Arizona"
)

southround2games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(southround2games)
  
southround2games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(southround2games) 

southround2 <- log_fit %>% predict(new_data = southround2games) %>%
  bind_cols(southround2games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

southround2 <- log_fit %>% predict(new_data = southround2games, type="prob") %>%
  bind_cols(southround2) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

southround3games <- tibble(
  team_short_display_name="Maryland",
  opponent_short_display_name="Furman"
) %>% add_row(
  team_short_display_name="UCSB",
  opponent_short_display_name="Arizona"
) 

southround3games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(southround3games)
  
southround3games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(southround3games) 

southround3 <- log_fit %>% predict(new_data = southround3games) %>%
  bind_cols(southround3games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

southround3 <- log_fit %>% predict(new_data = southround3games, type="prob") %>%
  bind_cols(southround3) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())



southround4games <- tibble(
  team_short_display_name="Furman",
  opponent_short_display_name="Arizona"
)

southround4games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(southround4games)
  
southround4games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(southround4games) 

southround4 <- log_fit %>% predict(new_data = southround4games) %>%
  bind_cols(southround4games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

southround4 <- log_fit %>% predict(new_data = southround4games, type="prob") %>%
  bind_cols(southround4) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

eastround1games <- tibble(
  team_short_display_name="Purdue",
  opponent_short_display_name="Fair Dickinson"
) %>% add_row(
  team_short_display_name="Memphis",
  opponent_short_display_name="FAU"
) %>% add_row(
  team_short_display_name="Duke",
  opponent_short_display_name="Oral Roberts"
) %>% add_row(
  team_short_display_name="Tennessee",
  opponent_short_display_name="Louisiana"
) %>% add_row(
  team_short_display_name="Kentucky",
  opponent_short_display_name="Providence"
) %>% add_row(
  team_short_display_name="Kansas St",
  opponent_short_display_name="Montana St"
) %>% add_row(
  team_short_display_name="Michigan St",
  opponent_short_display_name="USC"
) %>% add_row(
  team_short_display_name="Marquette",
  opponent_short_display_name="Vermont"
)
  
eastround1games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(eastround1games)
  
eastround1games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(eastround1games) 

eastround1 <- log_fit %>% predict(new_data = eastround1games) %>%
  bind_cols(eastround1games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

eastround1 <- log_fit %>% predict(new_data = eastround1games, type="prob") %>%
  bind_cols(eastround1) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

eastround2games <- tibble(
  team_short_display_name="Fair Dickinson",
  opponent_short_display_name="FAU"
) %>% add_row(
  team_short_display_name="Duke",
  opponent_short_display_name="Louisiana"
) %>% add_row(
  team_short_display_name="Kentucky",
  opponent_short_display_name="Kansas St"
) %>% add_row(
  team_short_display_name="Michigan St",
  opponent_short_display_name="Vermont"
)

eastround2games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(eastround2games)
  
eastround2games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(eastround2games) 

eastround2 <- log_fit %>% predict(new_data = eastround2games) %>%
  bind_cols(eastround2games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

eastround2 <- log_fit %>% predict(new_data = eastround2games, type="prob") %>%
  bind_cols(eastround2) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

eastround3games <- tibble(
  team_short_display_name="FAU",
  opponent_short_display_name="Duke"
) %>% add_row(
  team_short_display_name="Kentucky",
  opponent_short_display_name="Vermont"
) 

eastround3games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(eastround3games)
  
eastround3games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(eastround3games) 

eastround3 <- log_fit %>% predict(new_data = eastround3games) %>%
  bind_cols(eastround3games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

eastround3 <- log_fit %>% predict(new_data = eastround3games, type="prob") %>%
  bind_cols(eastround3) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

eastround4games <- tibble(
  team_short_display_name="Duke",
  opponent_short_display_name="Vermont"
)

eastround4games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(eastround4games)
  
eastround4games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(eastround4games) 

eastround4 <- log_fit %>% predict(new_data = eastround4games) %>%
  bind_cols(eastround4games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

eastround4 <- log_fit %>% predict(new_data = southround4games, type="prob") %>%
  bind_cols(eastround4) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

midwestround1games <- tibble(
  team_short_display_name="Houston",
  opponent_short_display_name="N Kentucky"
) %>% add_row(
  team_short_display_name="Iowa",
  opponent_short_display_name="Auburn"
) %>% add_row(
  team_short_display_name="Miami",
  opponent_short_display_name="Drake"
) %>% add_row(
  team_short_display_name="Indiana",
  opponent_short_display_name="Kent State"
) %>% add_row(
  team_short_display_name="Iowa State",
  opponent_short_display_name="Pitt"
) %>% add_row(
  team_short_display_name="Xavier",
  opponent_short_display_name="Kennesaw St"
) %>% add_row(
  team_short_display_name="Texas A&M",
  opponent_short_display_name="Penn State"
) %>% add_row(
  team_short_display_name="Texas",
  opponent_short_display_name="Colgate"
)

midwestround1games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(midwestround1games)
  
midwestround1games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(midwestround1games) 

midwestround1 <- log_fit %>% predict(new_data = midwestround1games) %>%
  bind_cols(midwestround1games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

midwestround1 <- log_fit %>% predict(new_data = midwestround1games, type="prob") %>%
  bind_cols(midwestround1) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

midwestround2games <- tibble(
  team_short_display_name="N Kentucky",
  opponent_short_display_name="Iowa"
) %>% add_row(
  team_short_display_name="Miami",
  opponent_short_display_name="Kent State"
) %>% add_row(
  team_short_display_name="Pitt",
  opponent_short_display_name="Xavier"
) %>% add_row(
  team_short_display_name="Penn State",
  opponent_short_display_name="Colgate"
)

midwestround2games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(midwestround2games)
  
midwestround2games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(midwestround2games) 

midwestround2 <- log_fit %>% predict(new_data = midwestround2games) %>%
  bind_cols(midwestround2games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

midwestround2 <- log_fit %>% predict(new_data = midwestround2games, type="prob") %>%
  bind_cols(midwestround2) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

midwestround3games <- tibble(
  team_short_display_name="N Kentucky",
  opponent_short_display_name="Miami"
) %>% add_row(
  team_short_display_name="Xavier",
  opponent_short_display_name="Colgate"
) 

midwestround3games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(midwestround3games)
  
midwestround3games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(midwestround3games) 

midwestround3 <- log_fit %>% predict(new_data = midwestround3games) %>%
  bind_cols(midwestround3games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

midwestround3 <- log_fit %>% predict(new_data = midwestround3games, type="prob") %>%
  bind_cols(midwestround3) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

midwestround4games <- tibble(
  team_short_display_name="N Kentucky",
  opponent_short_display_name="Colgate"
)

midwestround4games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(midwestround4games)
  
midwestround4games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(midwestround4games) 

midwestround4 <- log_fit %>% predict(new_data = midwestround4games) %>%
  bind_cols(midwestround4games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

midwestround4 <- log_fit %>% predict(new_data = midwestround4games, type="prob") %>%
  bind_cols(midwestround4) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

westround1games <- tibble(
  team_short_display_name="Kansas",
  opponent_short_display_name="Howard"
) %>% add_row(
  team_short_display_name="Arkansas",
  opponent_short_display_name="Illinois"
) %>% add_row(
  team_short_display_name="Saint Mary's",
  opponent_short_display_name="VCU"
) %>% add_row(
  team_short_display_name="UConn",
  opponent_short_display_name="Iona"
) %>% add_row(
  team_short_display_name="TCU",
  opponent_short_display_name="Arizona St"
) %>% add_row(
  team_short_display_name="Gonzaga",
  opponent_short_display_name="Grand Canyon"
) %>% add_row(
  team_short_display_name="Northwestern",
  opponent_short_display_name="Boise St"
) %>% add_row(
  team_short_display_name="UCLA",
  opponent_short_display_name="UNC Asheville"
)

westround1games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(westround1games)
  
westround1games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(westround1games) 

westround1 <- log_fit %>% predict(new_data = westround1games) %>%
  bind_cols(westround1games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

westround1 <- log_fit %>% predict(new_data = westround1games, type="prob") %>%
  bind_cols(westround1) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

westround2games <- tibble(
  team_short_display_name="Howard",
  opponent_short_display_name="Arkansas"
) %>% add_row(
  team_short_display_name="VCU",
  opponent_short_display_name="Iona"
) %>% add_row(
  team_short_display_name="TCU",
  opponent_short_display_name="Gonzaga"
) %>% add_row(
  team_short_display_name="Boise St",
  opponent_short_display_name="UNC Asheville"
)

westround2games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(westround2games)
  
westround2games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(westround2games) 

westround2 <- log_fit %>% predict(new_data = westround2games) %>%
  bind_cols(westround2games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

westround2 <- log_fit %>% predict(new_data = westround2games, type="prob") %>%
  bind_cols(westround2) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

westround3games <- tibble(
  team_short_display_name="Arkansas",
  opponent_short_display_name="VCU"
) %>% add_row(
  team_short_display_name="Gonzaga",
  opponent_short_display_name="UNC Asheville"
) 

westround3games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(westround3games)
  
westround3games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(westround3games) 

westround3 <- log_fit %>% predict(new_data = westround3games) %>%
  bind_cols(westround3games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

westround3 <- log_fit %>% predict(new_data = westround3games, type="prob") %>%
  bind_cols(westround3) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

westround4games <- tibble(
  team_short_display_name="VCU",
  opponent_short_display_name="Gonzaga"
)

westround4games <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(westround4games)
  
westround4games <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(westround4games) 

westround4 <- log_fit %>% predict(new_data = westround4games) %>%
  bind_cols(westround4games) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

westround4 <- log_fit %>% predict(new_data = westround4games, type="prob") %>%
  bind_cols(westround4) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

finalfourgames <- tibble(
  team_short_display_name="Arizona",
  opponent_short_display_name="Vermont"
) %>% add_row(
  team_short_display_name="Colgate",
  opponent_short_display_name="Gonzaga"  
)

finalfourgames <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(finalfourgames)
  
finalfourgames <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(finalfourgames) 

finalfour <- log_fit %>% predict(new_data = finalfourgames) %>%
  bind_cols(finalfourgames) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

finalfour <- log_fit %>% predict(new_data = finalfourgames, type="prob") %>%
  bind_cols(finalfour) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

championshipgame <- tibble(
  team_short_display_name="Arizona",
  opponent_short_display_name="Gonzaga"
) 

championshipgame <- modelgames %>% group_by(team_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% select(-team_result, -starts_with("opponent")) %>% right_join(championshipgame)
  
championshipgame <- modelgames %>% group_by(opponent_short_display_name) %>% filter(game_date == max(game_date) & season == 2023) %>% slice(1) %>% ungroup() %>% select(-team_result, -starts_with("team"), -game_id, -game_date, -season) %>% right_join(championshipgame) 

championship <- log_fit %>% predict(new_data = championshipgame) %>%
  bind_cols(championshipgame) %>% select(.pred_class, team_short_display_name, opponent_short_display_name, everything())

championship <- log_fit %>% predict(new_data = championshipgame, type="prob") %>%
  bind_cols(championship) %>% select(.pred_class, .pred_W, .pred_L, team_short_display_name, opponent_short_display_name, everything())

The most highly emphasized metric was effective field goal percentage. I placed importance on this metric because it accounts for the fact that three point field goals are more valuable than two point field foals. If a team is scoring high in this metric it means that they are shooting well, and if you are making shots then you are winning games (there is a reason why it is considered the most important of Dean Oliver’s Four Factors).

In addition, (although to a much lesser extent) I included points per possession, offensive rebounds, turnovers, and free throw attempts. Points per possession is important because it suggests whether or not a team is putting its possessions to good use. As for offensive rebounds and turnovers, the way I weighted these metrics sort of had them cancel out one another. This makes sense because offensive rebounds provide another crack at scoring whereas turning over the ball prevents a team from even having a chance to score. Regarding free throw attempts, I made this part of the model because a team that is consistently going to the line is providing themselves with the opportunity to points on the board.

Putting all the aforementioned factors together on a rolling basis of the last seven games, I created a variable that I referred to as formula scores for both teams and their opponents. Below is a chart that demonstrates these scores for all games dating back to 2015.

Code

win <- modelgames %>% filter(team_result == "W")
loss <- modelgames %>% filter(team_result == "L")

averages <- modelgames %>% ungroup() %>% summarise(Avg_team_rolling_predictive_factors = mean(team_rolling_predictivefactors), 
                                                   Avg_opponent_rolling_predictive_factors = mean(opponent_rolling_predictivefactors))
ggplot() + 
  geom_point(data=modelgames, aes(x=team_rolling_predictivefactors, y=opponent_rolling_predictivefactors), color="grey") +
  geom_point(data=win, aes(x=team_rolling_predictivefactors, y=opponent_rolling_predictivefactors), color="green") +
  geom_point(data=loss, aes(x=team_rolling_predictivefactors, y=opponent_rolling_predictivefactors), color="red") +
  geom_smooth(data=modelgames, aes(x=`team_rolling_predictivefactors`, y=`opponent_rolling_predictivefactors`), method=lm, se=FALSE) +
  geom_hline(yintercept=26.27, color="black") + 
  geom_vline(xintercept=26.27, color="black") +
  labs(
    x="Team Formula Score (Green = Win, Red = Loss)",
    y="Opponent Formula Score", 
    title="Higher Team Scores Have Generally Indicated Wins", 
    subtitle="Although there is variability, discrepnacy in these factors normally impacts results.",
    caption="Source: NCAA | By Jacob Spooner"
    ) +
  theme_minimal() + 
  theme(
    plot.title = element_text(size = 18, face = "bold"),
    axis.title = element_text(size = 10),
    axis.text = element_text(size = 7),
    axis.ticks = element_blank(),
    panel.grid.minor = element_blank(),
    panel.grid.major.x = element_blank()
  )

Although the correlation demonstrated between wins/losses and team/opponent score is far from perfect, there is enough there to suggest that these formula scores are fairly predictive in regards to which team will come out on top. Hence, my decision to emphasize factors such as effective field goal percentage were logical in the given context of game outcomes.

While my madness did indeed have a method to it, a brave soul would be required to predict a certain result shown in the table below containing round 1’s games from the midwest region.

Code

midwestround1 %>% 
  select(team_short_display_name, .pred_class, .pred_W, opponent_short_display_name) %>%
  gt() %>% 
  cols_label(
    team_short_display_name = "Team",
    .pred_class = "Prediction",
    .pred_W = "Win Confidence",
    opponent_short_display_name = "Opponent"
  ) %>%
  tab_header(
    title = "Midwest Regional: First Round",
    subtitle = "My model was extremely confident in Colgate. Alas they got trounced."
  ) %>%  
  tab_source_note(
    source_note = md("by: Jacob Spooner")
  ) %>% 
  tab_style(
    style = cell_text(color = "black", weight = "bold", align = "left"),
    locations = cells_title("title")
  ) %>% 
  tab_style(
    style = cell_text(color = "black", align = "left"),
    locations = cells_title("subtitle")
  ) 

Midwest Regional: First Round
My model was extremely confident in Colgate. Alas they got trounced.
Team	Prediction	Win Confidence	Opponent
Iowa	W	0.5380343	Auburn
Texas	L	0.2711109	Colgate
Miami	W	0.5157184	Drake
Xavier	W	0.5178294	Kennesaw St
Indiana	L	0.4475793	Kent State
Houston	L	0.3451261	N Kentucky
Texas A&M	L	0.3841507	Penn State
Iowa State	L	0.3577992	Pitt
by: Jacob Spooner

Yes, that’s right. The model had Colgate as huge favorites over Texas. Sure there were some crazy upsets in this edition of March Madness, but seriously? On what planet is a 15 seed favored by a margin that wide?

That being said, there were some solid predictions in that table such as the wins for Pitt and Penn State as well as the the narrow victories for Miami and Xavier. And then you have Northern Kentucky coming out on top against Houston. So yeah. For all the good in there, some of these predictions are truly horrific.

It is also worth mentioning that these Colgate and Northern Kentucky victories were not the only crazy upset predictions the model generated. In all honesty, it was scary how much it liked the 15 and 16 seeds and had many of them going on deep runs (although it had both Princeton and FDU losing in the first round of course). Given this issue, provided with greater amounts of time and expertise, I would have factored in the strength of schedules of these teams since I believe that failing to do so resulted in a ridiculous amount of upsets (dominating Mickey Mouse teams is not the quite the same as consistently performing well against ones featuring NBA talent galore).

So there you have it. Far from a roaring success but fun nonetheless. As embarrassing as it is, I have left images of my bracket below. Make of it what you will at your own risk.