NCAA women’s basketball tournament seeds
Nguyen_LSCM
10/13/2020
Modeling NCAA women’s basketball tournament seeds
Lately, I’ve been publishing screencasts demonstrating how to use the tidymodels framework, from starting out with first modeling steps to tuning more complex models. Today’s screencast walks through how to tune and choose hyperparameters using this week dataset NCAA women's basketball tournament
Explore the data
Our modeling goal is to estimate of expected tournament wins by seed from this week’s dataset. Let’s start by reading in the data
library(tidyverse)## -- Attaching packages ---------## v ggplot2 3.3.2 v purrr 0.3.4
## v tibble 3.0.3 v dplyr 1.0.0
## v tidyr 1.1.0 v stringr 1.4.0
## v readr 1.3.1 v forcats 0.5.0## -- Conflicts ------------------
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()library(ggthemes)
theme_set(theme_light())
tournament <- read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2020/2020-10-06/tournament.csv")## Parsed with column specification:
## cols(
## year = col_double(),
## school = col_character(),
## seed = col_double(),
## conference = col_character(),
## conf_w = col_double(),
## conf_l = col_double(),
## conf_percent = col_double(),
## conf_place = col_character(),
## reg_w = col_double(),
## reg_l = col_double(),
## reg_percent = col_double(),
## how_qual = col_character(),
## x1st_game_at_home = col_character(),
## tourney_w = col_double(),
## tourney_l = col_double(),
## tourney_finish = col_character(),
## full_w = col_double(),
## full_l = col_double(),
## full_percent = col_double()
## )tournament## # A tibble: 2,092 x 19
## year school seed conference conf_w conf_l conf_percent conf_place reg_w
## <dbl> <chr> <dbl> <chr> <dbl> <dbl> <dbl> <chr> <dbl>
## 1 1982 Arizo~ 4 Western C~ NA NA NA - 23
## 2 1982 Auburn 7 Southeast~ NA NA NA - 24
## 3 1982 Cheyn~ 2 Independe~ NA NA NA - 24
## 4 1982 Clems~ 5 Atlantic ~ 6 3 66.7 4th 20
## 5 1982 Drake 4 Missouri ~ NA NA NA - 26
## 6 1982 East ~ 6 Independe~ NA NA NA - 19
## 7 1982 Georg~ 5 Southeast~ NA NA NA - 21
## 8 1982 Howard 8 Mid-Easte~ NA NA NA - 14
## 9 1982 Illin~ 7 Big Ten NA NA NA - 21
## 10 1982 Jacks~ 7 Southwest~ NA NA NA - 28
## # ... with 2,082 more rows, and 10 more variables: reg_l <dbl>,
## # reg_percent <dbl>, how_qual <chr>, x1st_game_at_home <chr>,
## # tourney_w <dbl>, tourney_l <dbl>, tourney_finish <chr>, full_w <dbl>,
## # full_l <dbl>, full_percent <dbl>We can look at the mean wins by seed
tournament %>% group_by(seed) %>%
summarise(exp_wins = mean(tourney_w, na.rm=TRUE)) %>%
ggplot(aes(seed, exp_wins)) +
geom_point(alpha = 0.8, size = 3) +
labs(y = 'tourmanent wins (mean)')## `summarise()` ungrouping output (override with `.groups` argument)## Warning: Removed 1 rows containing missing values (geom_point).
Let’s visualize all the tournament results, not just the averages
tournament %>% ggplot(aes(seed, tourney_w)) +
geom_bin2d(binwidth = c(1, 1), alpha = 0.8) +
scale_fill_gradient(low = 'gray85', high = 'midnightblue') +
labs(fill = 'number of \nteams', y = 'tournament wins')## Warning: Removed 8 rows containing non-finite values (stat_bin2d).
We have a lot of options to dealwith data liek this (curvy, integers, all greater than zero) but one straightforward options are splines. Splines aren’t perfect for this because they aren’t constrained to stay greater than zero or to always decrease, but they work pretty well and can be used in lots of situations. We have to choose the degrees of freedom for the splines.
library(splines)
plot_smoother <- function(deg_free) {
p <- ggplot(tournament, aes(seed, tourney_w)) +
geom_bin2d(binwidth = c(1, 1), alpha = 0.8) +
scale_fill_gradient(low = 'gray85', high = 'midnightblue') +
geom_smooth(method = lm, se = FALSE, color = 'black',
formula = y ~ ns(x, df = deg_free)) +
labs(
fill = 'number of \nteams', y = 'tournement wins',
title = paste(deg_free, 'spline terms')
)
print(p)
}
walk(c(2, 4, 6, 8, 10, 15), plot_smoother)## Warning: Removed 8 rows containing non-finite values (stat_bin2d).## Warning: Removed 8 rows containing non-finite values (stat_smooth).
## Warning: Removed 8 rows containing non-finite values (stat_bin2d).
## Warning: Removed 8 rows containing non-finite values (stat_smooth).
## Warning: Removed 8 rows containing non-finite values (stat_bin2d).
## Warning: Removed 8 rows containing non-finite values (stat_smooth).
## Warning: Removed 8 rows containing non-finite values (stat_bin2d).
## Warning: Removed 8 rows containing non-finite values (stat_smooth).
## Warning: Removed 8 rows containing non-finite values (stat_bin2d).
## Warning: Removed 8 rows containing non-finite values (stat_smooth).
## Warning: Removed 8 rows containing non-finite values (stat_bin2d).
## Warning: Removed 8 rows containing non-finite values (stat_smooth).## Warning in predict.lm(model, newdata = new_data_frame(list(x = xseq)), se.fit =
## se, : prediction from a rank-deficient fit may be misleading
As the number of degrees of freedom goes up, the curves get more wiggly. This would allow the model to fit a more complex relationship, perhaps too much so give our data. We can tune this hyperparameter to find the best value.
Build a model
We can start by loading the tidymodels metapackage, and splitting our data into training and testing sets
library(tidymodels)## -- Attaching packages ---------## v broom 0.7.0 v recipes 0.1.13
## v dials 0.0.8 v rsample 0.0.7
## v infer 0.5.3 v tune 0.1.1
## v modeldata 0.0.2 v workflows 0.1.2
## v parsnip 0.1.2 v yardstick 0.0.7## -- Conflicts ------------------
## x scales::discard() masks purrr::discard()
## x dplyr::filter() masks stats::filter()
## x recipes::fixed() masks stringr::fixed()
## x dplyr::lag() masks stats::lag()
## x yardstick::spec() masks readr::spec()
## x recipes::step() masks stats::step()set.seed(123)
tourney_split <- tournament %>%
filter(!is.na(seed)) %>%
initial_split(strata = seed)
tourney_train <- training(tourney_split)
tourney_test <- testing(tourney_split)We are going to use resampling to evaluate model performance, so let’s get those resampled sets ready
set.seed(234)
tourney_folds <- bootstraps(tourney_train)
tourney_folds ## # Bootstrap sampling
## # A tibble: 25 x 2
## splits id
## <list> <chr>
## 1 <split [1.6K/545]> Bootstrap01
## 2 <split [1.6K/587]> Bootstrap02
## 3 <split [1.6K/597]> Bootstrap03
## 4 <split [1.6K/581]> Bootstrap04
## 5 <split [1.6K/581]> Bootstrap05
## 6 <split [1.6K/597]> Bootstrap06
## 7 <split [1.6K/570]> Bootstrap07
## 8 <split [1.6K/572]> Bootstrap08
## 9 <split [1.6K/598]> Bootstrap09
## 10 <split [1.6K/576]> Bootstrap10
## # ... with 15 more rowsNext, we build a recipe for data preprocessing. It only has one step!
- First, we must tell the
recipe()what our model is going to be (using a formula here) and what our training data is - For our first and only step, we create new spline terms from the original
seedvariable. We don’t know what the best value for the degrees of freedom is, so we willtune()it. We can set anidvalue for the tunable parameter to more easily keep track of it, if we want
The object tourney_rec is a recipe that has not been trained on data yet, and in fact, we can’t do this because we haven’t decided on a value for deg_free
tourney_rec <- recipe(tourney_w ~ seed, data = tourney_train) %>%
step_ns(seed, deg_free = tune('seed_splines'))
tourney_rec ## Data Recipe
##
## Inputs:
##
## role #variables
## outcome 1
## predictor 1
##
## Operations:
##
## Natural Splines on seedNext, let’s create a model specification for a linear regression model, and the combine the recipe and model together in a workflow
lm_spec <- linear_reg() %>% set_engine('lm')
tourney_wf <- workflow() %>%
add_recipe(tourney_rec) %>%
add_model(lm_spec)
tourney_wf## == Workflow ===================
## Preprocessor: Recipe
## Model: linear_reg()
##
## -- Preprocessor ---------------
## 1 Recipe Step
##
## * step_ns()
##
## -- Model ----------------------
## Linear Regression Model Specification (regression)
##
## Computational engine: lmThis workflow is almost ready to go, but we need to decide what values to try for the splines. There are several different ways to create tuning grids, but if the grid you need is very simple, you might prefer to create it by hand
spline_grid <- tibble(seed_splines = c(1:3, 5, 7, 10))
spline_grid## # A tibble: 6 x 1
## seed_splines
## <dbl>
## 1 1
## 2 2
## 3 3
## 4 5
## 5 7
## 6 10Now we can put this all together. When we use tune_grid(), we will fit each of the options in the grid to each of the resamples
doParallel::registerDoParallel()
save_preds <- control_grid(save_pred = TRUE)
spline_rs <-
tune_grid(tourney_wf,
resamples = tourney_folds,
grid = spline_grid, control = save_preds)
spline_rs## # Tuning results
## # Bootstrap sampling
## # A tibble: 25 x 5
## splits id .metrics .notes .predictions
## <list> <chr> <list> <list> <list>
## 1 <split [1.6K/54~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,270 x ~
## 2 <split [1.6K/58~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,522 x ~
## 3 <split [1.6K/59~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,582 x ~
## 4 <split [1.6K/58~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,486 x ~
## 5 <split [1.6K/58~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,486 x ~
## 6 <split [1.6K/59~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,582 x ~
## 7 <split [1.6K/57~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,420 x ~
## 8 <split [1.6K/57~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,432 x ~
## 9 <split [1.6K/59~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,588 x ~
## 10 <split [1.6K/57~ Bootstrap~ <tibble [12 x ~ <tibble [0 x ~ <tibble [3,456 x ~
## # ... with 15 more rowsWe have not fit each of our candidate set of spline features to our resampled training set!
Evaluate model
Now, let’s check out how we did
collect_metrics(spline_rs)## # A tibble: 12 x 7
## seed_splines .metric .estimator mean n std_err .config
## <dbl> <chr> <chr> <dbl> <int> <dbl> <chr>
## 1 1 rmse standard 0.982 25 0.00741 Recipe1
## 2 1 rsq standard 0.432 25 0.00372 Recipe1
## 3 2 rmse standard 0.896 25 0.00749 Recipe2
## 4 2 rsq standard 0.528 25 0.00486 Recipe2
## 5 3 rmse standard 0.871 25 0.00727 Recipe3
## 6 3 rsq standard 0.554 25 0.00518 Recipe3
## 7 5 rmse standard 0.869 25 0.00730 Recipe4
## 8 5 rsq standard 0.556 25 0.00541 Recipe4
## 9 7 rmse standard 0.868 25 0.00718 Recipe5
## 10 7 rsq standard 0.557 25 0.00537 Recipe5
## 11 10 rmse standard 0.868 25 0.00693 Recipe6
## 12 10 rsq standard 0.557 25 0.00538 Recipe6Looks like the model got better and better as we added more degrees of freedom, which isn’t too shocking in what way did it change?
collect_metrics(spline_rs) %>%
ggplot(aes(seed_splines, mean, color = .metric)) +
geom_line(size = 1.5, alpha = 0.5) +
geom_point(size = 3) +
facet_wrap(~.metric, ncol = 1, scales = 'free_y') +
labs(x = 'degrees of freedom', y = NULL) +
theme(legend.position = 'none')
The models improved a lot as we increased the degrees of freedom at the beginning, but then continuing to add more didn’t make much difference. We could choose the numerically optimal hyperparameter with select_best() but that would choose a more wiggly, complex model than we probably want. We can choose a simpler model that performs well, within some limits around the numerically optimal result. We could choose either by percent loss in performance or within one standard error in performance
select_by_pct_loss(spline_rs, metric = 'rmse', limit = 5, seed_splines)## # A tibble: 1 x 9
## seed_splines .metric .estimator mean n std_err .config .best .loss
## <dbl> <chr> <chr> <dbl> <int> <dbl> <chr> <dbl> <dbl>
## 1 2 rmse standard 0.896 25 0.00749 Recipe2 0.868 3.27select_by_one_std_err(spline_rs, metric = "rmse", seed_splines)## # A tibble: 1 x 9
## seed_splines .metric .estimator mean n std_err .config .best .bound
## <dbl> <chr> <chr> <dbl> <int> <dbl> <chr> <dbl> <dbl>
## 1 3 rmse standard 0.871 25 0.00727 Recipe3 0.868 0.875Looks like 2 or 3 degrees of freedom is a good option. Let’s go with 3, and update our tuneable workflow with this information and then fit it to our training data.
final_wf <- finalize_workflow(tourney_wf, tibble(seed_splines = 3))
tourney_fit <- fit(final_wf, tourney_train)
tourney_fit## == Workflow [trained] =========
## Preprocessor: Recipe
## Model: linear_reg()
##
## -- Preprocessor ---------------
## 1 Recipe Step
##
## * step_ns()
##
## -- Model ----------------------
##
## Call:
## stats::lm(formula = ..y ~ ., data = data)
##
## Coefficients:
## (Intercept) seed_ns_1 seed_ns_2 seed_ns_3
## 3.272 -1.855 -5.590 -1.822tourney_test %>%
bind_cols(predict(tourney_fit, tourney_test)) %>%
metrics(tourney_w, .pred)## # A tibble: 3 x 3
## .metric .estimator .estimate
## <chr> <chr> <dbl>
## 1 rmse standard 0.877
## 2 rsq standard 0.545
## 3 mae standard 0.609predict(tourney_fit, new_data = tibble(seed = 1:16))## # A tibble: 16 x 1
## .pred
## <dbl>
## 1 3.27
## 2 2.61
## 3 1.99
## 4 1.45
## 5 1.02
## 6 0.738
## 7 0.574
## 8 0.492
## 9 0.456
## 10 0.429
## 11 0.380
## 12 0.307
## 13 0.216
## 14 0.110
## 15 -0.00482
## 16 -0.125It’s close! This isn’t a huge surprise, since we’re fitting curves to data in a straightforward way here, but it’s still good to see. You can also see why splines aren’t perfect for this task, because the prediction isn’t constrained to positive values.