Cross-Validation From Scratch and a Surprise at n=100

r on Everyday Is A School Day

1 day ago

[This article was first published on r on Everyday Is A School Day, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)

Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

Textbooks say LOOCV has the lowest bias but highest variance compared to 10 and 5-fold. Coded a K-Fold CV from scratch for learning to test that on simulated data 🔍📊 — and at n=1000 it holds up. At n=100? Not so much. 🤔

The above image was generated via chatGPT. Uploaded all the text of this blog post and asked it to generate a cartoon. Very impressive! It used to be spelling error and gibberish of text in the past, but now cohesive words on image. Just wow.

Motivations < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

Crossvalidation is such a crucial step in Machine Learning (and traditional methods) that nowadays is incorporated in easy to use sklearn or tidymodels without us needing to build one from scratch. As with my other learning experience, the best way to learn the concept (other than learning the concept 🤣) is to code it from the ground up and see how it works! In K-Fold CV, the training data is split into K chunks; the model is trained K times, each time holding out a different chunk. Performance is averaged across all K folds, giving a more stable estimate. A special case is Leave-One-Out CV (LOOCV), where each individual observation serves as its own validation set. It’s thorough but computationally expensive. I was told that, bias LOOCV < 10-fold < 5-fold; whereas variance LOOCV > 10-fold > 5-fold. Is that true? Also, what’s with the repeats, does that really reduce variance? Let’s check them out.

Objectives: < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

Simulate Data < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

library(tidyverse)

set.seed(1)
n <- 1000
x <- rnorm(n)
w <- rnorm(n)
y <- 0.5*x^2 + -0.5*w + 0.3*w*x + rnorm(n)
df <- tibble(x,y,w)
idx <- sample(1:n, size=0.8*n)
train <- df[idx, ]
test <- df[-idx, ]

The above code simulates a dataset with 1000 observations, where the response variable y is generated based on a known data-generating process involving predictors x and w. The dataset is then split into a training set (80%) and a test set (20%). Let’s visualize.

df |>
  mutate(w_cut = cut_interval(w, n=5)) |>
  ggplot(aes(x=x, y=y, color=w_cut, group=w_cut)) +
  geom_point(alpha=0.5) +
  theme_bw() +
  geom_smooth(method = "gam", se=F)

Wow, very interesting visualization where the relationships are definitely not linear here. It’s some form of interaction between x and w. Let’s see if we can recover the underlying data-generating process using K-Fold Cross-Validation.

K-Fold Cross-Validation From Scratch < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

folds <- 5
segment_portion <- nrow(train)/folds
formula_list <- list(as.formula("y~x"),as.formula("y~I(x^2)"),as.formula("y~I(x^2)+w+w:x"),as.formula("y~I(x^3)+w+w:x"),
                     as.formula("y~w:x"),as.formula("y~w"),as.formula("y~x+w+x:w"),as.formula("y~I(x^2)+w:x"),
                     as.formula("y~I(x^2)+w"))

cv_log <- tibble()

for (formula in formula_list) {
print(formula)
predict_log <- y_log <- vector(mode="numeric",length=segment_portion*folds)
start <- 1
end <- segment_portion 

for (fold in 1:folds) {
    val_i <- train[start:end,]
    train_i <- train[-c(start:end),]
    model_i <- lm(formula,train_i)
    predict_i <- predict(model_i, val_i)
    predict_log[start:end] <- predict_i
    y_log[start:end] <- val_i$y
    start <- end + 1
    end <- start + segment_portion - 1
}

val_df <- tibble(predict=predict_log,y=y_log) |>
  mutate(formula=deparse(formula))
cv_log <- cv_log |>
  bind_rows(val_df)
}

## y ~ x
## y ~ I(x^2)
## y ~ I(x^2) + w + w:x
## y ~ I(x^3) + w + w:x
## y ~ w:x
## y ~ w
## y ~ x + w + x:w
## y ~ I(x^2) + w:x
## y ~ I(x^2) + w

Alright, what we’ve done above is a manual implementation of K-Fold Cross-Validation. We loop through each formula in our list, and for each formula, we split the training data into 5 folds. For each fold, we train the model on the other 4 folds and validate it on the current fold. We store the predictions and actual values for later evaluation.

We basically want to see which formula has the lowest RMSE across the folds. Let’s calculate that next. From the DGP formula, we know that the best model should be y~I(x^2)+w+w:x. Let’s see if we can recover that using K-Fold CV.

Assessing RMSE < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

cv_log |>
  group_by(formula) |>
  summarize(rmse = sqrt(mean((y-predict)^2))) |>
  arrange(rmse) |>
  mutate(rmse = format(rmse, digits = 8))

## # A tibble: 9 × 2
##   formula              rmse     
##   <chr>                <chr>    
## 1 y ~ I(x^2) + w + w:x 1.0397338
## 2 y ~ I(x^2) + w       1.1008693
## 3 y ~ I(x^2) + w:x     1.1607225
## 4 y ~ I(x^2)           1.2144857
## 5 y ~ x + w + x:w      1.2826723
## 6 y ~ I(x^3) + w + w:x 1.2912046
## 7 y ~ w                1.3578304
## 8 y ~ w:x              1.3732478
## 9 y ~ x                1.4451807

Here our loss function is RMSE since y is a continuous data and we’re trying to predict that. The formula with the lowest RMSE is indeed y~I(x^2)+w+w:x, which matches the underlying data-generating process. OK at least, right now we are able to recover the underlying DGP using 5-Fold Cross-Validation. But is there a difference between 5 fold, 10 fold, or even LOOCV? If there is a difference, how do we even assess that? In the past we were able to assess bias and variance based on a true ATE, but what on earth is a true RMSE !?!

To check whether the textbook claim (bias LOOCV < 10-fold < 5-fold; variance LOOCV > 10-fold > 5-fold) holds up, we ran a small simulation with help from Claude Sonnet 5. Since we control the data-generating process, we can compare the “correct formula” (assuming the correct formula has the lowest RMSE as above) with 500 different simulated dataset against a “true” RMSE estimated from a large test set (n=10000) — large enough, by the law of large numbers, to treat as ground truth. Averaging across simulations gives bias (how far off CV runs from the true error) and variance (how much CV’s estimate swings from sample to sample) for each method. Is this legit? 🤔 If the textbook claim is correct, we should be able to observe bias LOOCV < 10-fold < 5-fold; variance LOOCV > 10-fold > 5-fold. Let’s see if we can observe that in the simulation below.

Compare Candidate Models < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

# set.seed(1)

# k-fold CV RMSE for a given formula and dataset (k = n gives LOOCV)
cv_rmse <- function(data, formula, k) {
  n <- nrow(data)
  folds <- sample(rep(1:k, length.out = n))
  preds <- numeric(n)
  for (i in 1:k) {
    train_i <- data[folds != i, ]
    val_i   <- data[folds == i, ]
    model_i <- lm(formula, train_i)
    preds[folds == i] <- predict(model_i, val_i)
  }
  sqrt(mean((data$y - preds)^2))
}

# "true" RMSE: fit on train, evaluate on a large fresh draw from the DGP
true_rmse <- function(train, formula, n_test = 10000) {
  x <- rnorm(n_test); w <- rnorm(n_test)
  y <- 0.5*x^2 - 0.5*w + 0.3*w*x + rnorm(n_test)
  test <- tibble(x, y, w)
  model <- lm(formula, train)
  sqrt(mean((test$y - predict(model, test))^2))
}

formula_true <- as.formula("y ~ I(x^2) + w + w:x")
n_sim   <- 500
n_train <- 100

results <- vector("list", n_sim)

for (s in 1:n_sim) {
  x <- rnorm(n_train); w <- rnorm(n_train)
  y <- 0.5*x^2 - 0.5*w + 0.3*w*x + rnorm(n_train)
  train_s <- tibble(x, y, w)

  results[[s]] <- tibble(
    sim      = s,
    true_err = true_rmse(train_s, formula_true),
    loocv    = cv_rmse(train_s, formula_true, k = n_train),
    cv5      = cv_rmse(train_s, formula_true, k = 5),
    cv10     = cv_rmse(train_s, formula_true, k = 10)
  )
}

sim_df <- bind_rows(results)

sim_long <- sim_df |>
  pivot_longer(cols = c(loocv, cv5, cv10), names_to = "method", values_to = "cv_estimate")

sim_long |>
  group_by(method) |>
  summarize(
    mean_cv_estimate = mean(cv_estimate),
    mean_true_error   = mean(true_err),
    bias     = mean(cv_estimate - true_err),
    variance = var(cv_estimate),
    .groups  = "drop"
  ) |>
  arrange(bias) |>
  mutate(variance = format(variance, digit = 8))

## # A tibble: 3 × 5
##   method mean_cv_estimate mean_true_error     bias variance     
##   <chr>             <dbl>           <dbl>    <dbl> <chr>        
## 1 loocv              1.00            1.00 0.000703 0.00053227867
## 2 cv10               1.00            1.00 0.000945 0.00053192050
## 3 cv5                1.00            1.00 0.00124  0.00053176441

Wow, looking at the results, we can see that the textbook claim holds up. LOOCV has the lowest bias, but the highest variance. 10-fold CV is in between, and 5-fold CV has the highest bias but lowest variance. But, noticed that we had to increase our digit to 8 to see the difference in variance, it’s really miniscule. Mainly because our n=1000 is already quite large, so the variance is already quite small. If we reduce n to 100, how would that look?

## # A tibble: 3 × 5
##   method mean_cv_estimate mean_true_error     bias variance    
##   <chr>             <dbl>           <dbl>    <dbl> <chr>       
## 1 loocv              1.02            1.02 -0.00400 0.0063905148
## 2 cv10               1.02            1.02 -0.00138 0.0065753049
## 3 cv5                1.03            1.02  0.00244 0.0068098389

!?!?!?!?! 🤷‍♂️ with n=100, the bias and variance order heuristics no longer hold up? Why is this? I don’t know. If you do, please let me know. I even increased the n_sim to 1000, but still same patern. Intersting how I had to push the n up to 850 in order to observe the textbook variance order again, though again it’s quite miniscule.

Verify On Test Set < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

test |>
  mutate(predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), train), test)) |>
  mutate(residual = y-predict) |>
  mutate(res_square = residual^2) |>
  pull(res_square) |>
  mean() |>
  sqrt()

## [1] 1.018281

Alright! The RMSE on test set is quite similar to our average validation sets! 🙌 Let’s visualize the predicted and actual y of the model on test set.

test |>
  mutate(predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), train), test)) |>
  ggplot(aes(x=predict, y=y)) +
  geom_point(alpha=0.5) +
  theme_bw() +
  geom_smooth(method = "lm") +
  labs(title="Predicted vs Actual y on Test Set", x="Predicted y", y="Actual y")

summary(lm(y ~ predict, data=test |> mutate(predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), train), test))))

## 
## Call:
## lm(formula = y ~ predict, data = mutate(test, predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), 
##     train), test)))
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -2.98185 -0.61410 -0.05514  0.62883  2.28837 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  0.08581    0.08390   1.023    0.308    
## predict      0.80885    0.07562  10.696   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.007 on 198 degrees of freedom
## Multiple R-squared:  0.3662,	Adjusted R-squared:  0.363 
## F-statistic: 114.4 on 1 and 198 DF,  p-value: < 2.2e-16

Slope here is 0.81, not 1 — even with the correct formula, coefficients are still estimated from a finite, noisy sample, so predict is really “true signal + estimation error.” Regressing y on a noisy version of itself pulls the slope below 1 — a known effect called attenuation (same idea as errors-in-variables bias). More training data shrinks that estimation error, so the slope should creep closer to 1. Intercept stays near 0 because the estimation error isn’t systematically biased in one direction — just noisy — so predictions still center correctly on average. If this is true, then if we increase our n to 10000, we should see slope is closer to 1 and intercept closer to 0. Let’s test this theory out.

set.seed(1)
n <- 10000
x <- rnorm(n)
w <- rnorm(n)
y <- 0.5*x^2 + -0.5*w + 0.3*w*x + rnorm(n)
df <- tibble(x,y,w)
idx <- sample(1:n, size=0.8*n)
train <- df[idx, ]
test <- df[-idx, ]
formula <- as.formula("y ~ I(x^2) + w + w:x")
folds <- 10
segment_portion <- nrow(train)/folds
predict_log <- y_log <- vector(mode="numeric",length=segment_portion*folds)
start <- 1
end <- segment_portion 

for (fold in 1:folds) {
    val_i <- train[start:end,]
    train_i <- train[-c(start:end),]
    model_i <- lm(formula,train_i)
    predict_i <- predict(model_i, val_i)
    predict_log[start:end] <- predict_i
    y_log[start:end] <- val_i$y
    start <- end + 1
    end <- start + segment_portion - 1
}

val_df <- tibble(predict=predict_log,y=y_log) 

val_df |>
  summarize(rmse = sqrt(mean((y-predict)^2))) |>
  arrange(rmse) |>
  mutate(rmse = format(rmse, digits = 8))

## # A tibble: 1 × 1
##   rmse     
##   <chr>    
## 1 1.0126176

test |>
  mutate(predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), train), test)) |>
  mutate(residual = y-predict) |>
  mutate(res_square = residual^2) |>
  pull(res_square) |>
  mean() |>
  sqrt()

## [1] 0.9884315

test |>
  mutate(predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), train), test)) |>
  ggplot(aes(x=predict, y=y)) +
  geom_point(alpha=0.5) +
  theme_bw() +
  geom_smooth(method = "lm") +
  labs(title="Predicted vs Actual y on Test Set", x="Predicted y", y="Actual y")

summary(lm(y ~ predict, data=test |> mutate(predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), train), test))))

## 
## Call:
## lm(formula = y ~ predict, data = mutate(test, predict = predict(lm(as.formula("y ~ I(x^2) + w + w:x"), 
##     train), test)))
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -3.08711 -0.67088  0.01239  0.69015  2.86620 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  0.02778    0.02527   1.099    0.272    
## predict      0.96577    0.02369  40.762   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.9884 on 1998 degrees of freedom
## Multiple R-squared:  0.454,	Adjusted R-squared:  0.4538 
## F-statistic:  1662 on 1 and 1998 DF,  p-value: < 2.2e-16

There you have it! The RMSE on test set is quite similar to our average validation sets! 🙌 The slope is now 0.97, much closer to 1, and the intercept is 0.02, much closer to 0. This confirms our theory that with more training data, the estimation error decreases, leading to better predictions.

Opportunities For Improvement < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

apply crossvalidation from scratch on hyperparameter tuning such as xgboost hyperparam, lasso/ridge/elasticnet/glmnet
learn about nested resampling that uses an additional layer of resampling that separates the tuning activities from the process used to estimate the efficacy of the model. see here
learn to code grouped and stratified cv from scratch
learn a bit more on time-series CV
need to try n_sim of 10000 and see if the bias and variance order holds up for n=100, since the simulation is quite slow, I didn’t run it to completion. Update: I did complete an n_sim of 10000 of n=100 and LOOCV still had the lowest variance.

Lessons learnt < svg class="anchor-symbol" aria-hidden="true" height="26" width="26" viewBox="0 0 22 22" xmlns="http://www.w3.org/2000/svg"> < path d="M0 0h24v24H0z" fill="currentColor"> < path d="M3.9 12c0-1.71 1.39-3.1 3.1-3.1h4V7H7c-2.76.0-5 2.24-5 5s2.24 5 5 5h4v-1.9H7c-1.71.0-3.1-1.39-3.1-3.1zM8 13h8v-2H8v2zm9-6h-4v1.9h4c1.71.0 3.1 1.39 3.1 3.1s-1.39 3.1-3.1 3.1h-4V17h4c2.76.0 5-2.24 5-5s-2.24-5-5-5z">

Learnt that we have to use I to indicate that we want to include polynomial terms in the formula, otherwise R will interpret them as interaction terms.
Learnt deparse is useful to convert a formula object into a character string for logging purposes.

If you like this article:

please feel free to send me a comment or visit my other blogs
please feel free to follow me on BlueSky, twitter, GitHub or Mastodon
if you would like collaborate please feel free to contact me

To leave a comment for the author, please follow the link and comment on their blog: r on Everyday Is A School Day.

R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.

Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

Related