Resample

Make a new sample train_downsamp that keeps all positive cases in the training set and an equal number of randomly sampled negative cases so that the split is no longer 5-95 but becomes 50-50.

minority_class_size <- sum(train$target)

set.seed(1234)

train_downsamp <- train %>% 
  group_by(target) %>% 
  sample_n(minority_class_size) %>% 
  ungroup()

See below for what the distribution of feature looks like in the down-sampled dataset.

train_downsamp %>% 
  ggplot(aes(feature, fill = target))+
  geom_histogram()+
  labs(title = "Distribution of values of 'feature' (down-sampled)",
       subtitle = "Greater values of 'feature' associate with higher likelihood 'target' = TRUE")

Build Models

Train a logistic regression model to predict positive cases for target based on feature using the training dataset without any changes in the sample (i.e. with the roughly 5-95 class imbalance).

mod_5_95 <- glm(target ~ feature, family = binomial("logit"), data = train)

Train a model with the down-sampled (i.e. 50-50) dataset.

mod_50_50 <- glm(target ~ feature, family = binomial("logit"), data = train_downsamp)

Add the predictions from each of these models¹¹ onto our test set (and convert log-odd predictions to probabilities).

test_with_preds <- test %>% 
  gather_predictions(mod_5_95, mod_50_50) %>% 
  mutate(pred_prob = convert_lodds(pred))

Visualize distributions of predicted probability of the positive and negative cases for each model.

test_with_preds %>% 
  ggplot(aes(x = pred_prob, fill = target))+
  geom_histogram()+
  facet_wrap(~model, ncol = 1)

The predicted probabilities for the model built with the down-sampled 50-50 dataset are much higher than those built with the original 5-95 dataset. For example, let’s look at the predictions between these models for a particular observation:

test_with_preds %>% 
  filter(id == 1828) %>%
  arrange(id) %>% 
  select(-pred) %>% 
  knitr::kable(digits = 2)

This shows that when feature is equal to -2.77, the model built without undersampling produces a prediction of 6% whereas the model built from the undersampled data would predict 56%. The former can be thought of as the predicted probability of the event whereas the latter would first need to be rescaled.

If picking a decision threshold for the predictions, the model built from the undersampled dataset would have far more predictions of TRUE compared to the rate of TRUEs from the model built from the original training dataset¹².

Rescale Predictions to Predicted Probabilities

Isotonic Regression¹³ or Platt scaling¹⁴ could be used. Such methods are used to calibrate outputted predictions and ensure they align with actual probabilities. Recalibration techniques are typically used when you have models that may not output well-calibrated probabilities¹⁵. However these methods can also be used to rescale your outputs (as in this case). (In the case of linear models, there are also simpler approaches available¹⁶.)

mod_50_50_rescaled_calibrated <- train %>% 
  add_predictions(mod_50_50) %>% 
  glm(target ~ pred, family = binomial("logit"), data = .)

test_with_preds_adjusted <- test %>% 
  spread_predictions(mod_5_95, mod_50_50) %>% 
  rename(pred = mod_50_50) %>% 
  spread_predictions(mod_50_50_rescaled_calibrated) %>% 
  select(-pred) %>% 
  gather(mod_5_95, mod_50_50_rescaled_calibrated, key = "model", value = "pred") %>% 
  mutate(pred_prob = convert_lodds(pred)) 

test_with_preds_adjusted %>% 
  ggplot(aes(x = pred_prob, fill = target))+
  geom_histogram()+
  facet_wrap(~model, ncol = 1)

Now that the predictions have been calibrated according to their underlying base rate, you can see the distributions of the predictions between the models are essentially the same.

Density Plots

Rebuilding plots but using density distributions by class (rather than histograms based on counts).

test_with_preds %>% 
  ggplot(aes(x = pred_prob, fill = target))+
  geom_density(alpha = 0.3)+
  facet_wrap(~model, ncol = 1)

test_with_preds_adjusted %>% 
  ggplot(aes(x = pred_prob, fill = target))+
  geom_density(alpha = 0.3)+
  facet_wrap(~model, ncol = 1)

Lift Plot

test_with_preds_adjusted %>% 
  mutate(target = factor(target, c("TRUE", "FALSE"))) %>% 
  filter(model == "mod_5_95") %>%
  yardstick::lift_curve(target, pred) %>% 
  autoplot()

Comparing Scaling Methods

Added after publishing

Thanks to Andrew Wheeler for his helpful disqus comment referencing another method for rescaling which prompted me to create a quick gist comparing platt scaling against using an offset/adjustment approach for rescaling.