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!*