Here’s a short post on why one should consider developing a segmented model when building credit risk scorecards to help optimize approval rates. While segmentation offers a variety of benefits, this post aims to offer a different perspective.

I will be reusing code from a previous post. Feel free to navigate to this post for additional information. Note that sample datasets are available for download from (here)

Packages

#install.packages("pacman") ## Install if needed 
library(pacman)

# p_load automatically installs packages if needed
p_load(dplyr, magrittr, scales, pROC)

Sample data

smple <- read.csv("../../../download/credit_sample.csv")

# Define target
codes <- c("Charged Off", "Does not meet the credit policy. Status:Charged Off")
smple %<>% mutate(bad_flag = ifelse(loan_status %in% codes, 1, 0))

# Some basic data cleaning
smple[is.na(smple)] <- -1
smple %<>% 
  
  # Remove cases where home ownership and payment plan are not reported
  filter(! home_ownership %in% c("", "NONE"),
         pymnt_plan != "") %>% 
  
  # Convert these two variables into factors
  mutate(home_ownership = factor(home_ownership), 
         pymnt_plan = factor(pymnt_plan))

Segments

Typically, credit risk scorecards would have segments like known goods, known bads, ever chaged off etc. For simplicity, I will use the available FICO grade variable in the dataset to segment known goods and known bads. For the purposes of this post, let’s focus on the known goods customers (mostly because policy filters would remove the known bad customers).

smple %>% 
  group_by(grade) %>% 
  summarise(total = n(), bads = sum(bad_flag == 1)) %>% 
  mutate(event_rate = percent(bads / total))
## # A tibble: 7 × 4
##   grade total  bads event_rate
##   <chr> <int> <int> <chr>     
## 1 A      1882    68 3.6%      
## 2 B      3056   239 7.8%      
## 3 C      2805   373 13.3%     
## 4 D      1435   257 17.9%     
## 5 E       590   144 24.4%     
## 6 F       182    65 35.7%     
## 7 G        49    16 32.7%

Since the event rates are significantly higher, let’s keep borrowers who have a FICO grade of "E", "F" & "G" in the known bads bucket and rest in the known goods bucket.

smple %<>%
  mutate(segment = ifelse(grade %in% c("E", "F", "G"), "KB", "KG"))

smple %>% 
  group_by(segment) %>% 
  tally()
## # A tibble: 2 × 2
##   segment     n
##   <chr>   <int>
## 1 KB        821
## 2 KG       9178

Model training

Let’s train two separate sets models like so:

• One to the entire population
• And one model to the known goods

# Create a formula object to be used across models 
form <- as.formula(
  "bad_flag ~
    mths_since_last_delinq +
    total_pymnt +
    acc_now_delinq +
    inq_last_6mths +
    delinq_amnt +
    mths_since_last_record +
    mths_since_recent_revol_delinq +
    mths_since_last_major_derog +
    mths_since_recent_inq +
    mths_since_recent_bc +
    num_accts_ever_120_pd"
)

Model on the entire population

set.seed(1234)

# Train Test split
idx <- sample(1:nrow(smple), size = 0.7 * nrow(smple), replace = F)
train <- smple[idx,]
test <- smple[-idx,]

# Using a GLM model for simplicity
mdl_pop <- glm(
  formula = form,
  family = "binomial",
  data = train
)

# Get performance on entire sample
auc(test$bad_flag, predict(mdl_pop, test))
## Setting levels: control = 0, case = 1
## Setting direction: controls < cases
## Area under the curve: 0.6602

Now that we have a model, let’s assume an expected default propensity target of 2%. That is to say I can only approve those customers who I believe have an expected default propensity of 2% or less. Given this, what would be my expected approval rate? Note that I need to maximise my approval rate (to better utilise my applicant funnel).

# Output scaling function
scaling_func <- function(vec, PDO = 30, OddsAtAnchor = 5, Anchor = 700){
  beta <- PDO / log(2)
  alpha <- Anchor - PDO * OddsAtAnchor
  
  # Simple linear scaling of the log odds
  scr <- alpha - beta * vec
  
  # Round off
  return(round(scr, 0))
}

# Find the number of customers that can be approved such that 
# the cumulative bad rate is <= target
smple %>%
  filter(segment == "KG") %>%  ## Filter on known goods only
  mutate(pred = predict(mdl_pop, newdata = .),   ## Generate predictions
         score = scaling_func(pred),  ## Scale output
         total = n()) %>%
  arrange(pred) %>%
  mutate(rn = row_number(), 
         c_bad_rate = cumsum(bad_flag)/rn) %>%
  filter(c_bad_rate <= 0.02) %>%
  summarise(approve_count = n(), 
            total = mean(total),
            score_cutoff = min(score), 
            bad_rate = sum(bad_flag)/n()) %>%
  mutate(approval_rate = approve_count / total)
##   approve_count total score_cutoff   bad_rate approval_rate
## 1           818  9178          689 0.01833741    0.08912617

Based on the unsegmented model, if we choose a score cutoff of >=689, we should expect a bad rate of ~2% at an approval rate of ~9%.

Model on the known good population

set.seed(1234)

# Filter on KG
sample_kg <- smple %>% filter(segment == "KG")
idx <- sample(1:nrow(sample_kg), size = 0.7 * nrow(sample_kg), replace = F)
train <- sample_kg[idx,]
test <- sample_kg[-idx,]

mdl_kg <- glm(
  formula = form,
  family = "binomial",
  data = train
)

# Get performance on entire sample
auc(test$bad_flag, predict(mdl_kg, test))
## Setting levels: control = 0, case = 1
## Setting direction: controls < cases
## Area under the curve: 0.6496

Simulations

To evaluate the through the door population better, let’s run some simulations. Let’s assume that only known good customers will be assessed through the risk scorecard.

# Function to generate simulations 
generate_sim <- function(mdl, nSim = 500, sample_size = 5000, cutoff = 650){
  
  # Vectors to store output
  bad_rates <- c()
  approval_rates <- c()
  
  for(i in 1:nSim){
    
    out <- smple %>%
      
      # Filter on KG segment 
      filter(segment == "KG") %>%
      
      # Randomly sample with replacement
      sample_n(sample_size, replace = T) %>%
      
      # Generate model output
      mutate(pred = predict(mdl, newdata = .), 
             score = scaling_func(pred)) %>%
      filter(score >= cutoff) %>%
      summarise(bad_rate = sum(bad_flag)/n(), app_rate = n() / sample_size)
    
    # Store output
    bad_rates[i] <- out$bad_rate
    approval_rates[i] <- out$app_rate
  }
  
  # Plot output
  par(mfrow = c(1, 2))
  plot(density(bad_rates), main = "Event Rate")
  abline(v = mean(bad_rates))
  
  plot(density(approval_rates), main = "Approval Rate")
  abline(v = mean(approval_rates))
  par(mfrow = c(1, 1))
}

# Simulate using the model built on the entire population
generate_sim(mdl_pop, cutoff = 689)

Based on the above simulations, when using the model trained on the entire population and using a threshold of >=689 the average simulated event rates and approval rates are close to the expected rates from before. But what if we use the model developed only on the known good population?

smple %>%
  filter(segment == "KG") %>%  ## Filter on known goods only
  mutate(pred = predict(mdl_kg, newdata = .),   ## Generate predictions
         score = scaling_func(pred),  ## Scale output
         total = n()) %>%
  arrange(pred) %>%
  mutate(rn = row_number(), 
         c_bad_rate = cumsum(bad_flag)/rn) %>%
  filter(c_bad_rate <= 0.02) %>%
  summarise(approve_count = n(), 
            total = mean(total),
            score_cutoff = min(score), 
            bad_rate = sum(bad_flag)/n()) %>%
  mutate(approval_rate = approve_count / total)
##   approve_count total score_cutoff  bad_rate approval_rate
## 1           904  9178          696 0.0199115     0.0984964

# Simulate using the model built only on the known good population
generate_sim(mdl_kg, cutoff = 696)

When using the known-good model, we can achieve a slightly higher approval rate keeping the event rate more or less the same. While the difference is not significant, a ~1% higher approval rate on a large funnel could be significant (psst. monthly targets anyone?).

While most modelers/data scientists understand this, explaining the need to build segmented models to a business owner can be easier if the impact can be linked to business outcomes 😉.

Thoughts? Comments? Helpful? Not helpful? Like to see anything else added in here? Let me know!