Using Accuracy Criterion for Credit Classification Can Cause Disaster for Banks
R for Pleasure
Jenny
Purpose
Machine Learning can be more productive when the modelers not only focus on the accuracy of those models themselve, but also the business value and requirements (profits or lost, etc.). Below is some discovery on this.
Maximize Threshold for Accuracy and Sensitivity
#=================================================================================
# Using Accuracy Criterion for Credit Classification Can Cause Disaster for Banks.
#=================================================================================
# Load R packages:
rm(list = ls())
library(cutpointr)
library(tidyverse)
library(caret)
# Load GermanCredit Data:
data("GermanCredit")
df <- GermanCredit
# Split data:
set.seed(1)
id <- createDataPartition(y = df$Class, p = 0.7, list = FALSE)
train <- df[id, ]
test <- df[-id, ]
# Set conditions for training Logistic Model:
number <- 5
repeats <- 5
set.seed(1)
train.control <- trainControl(method = "repeatedcv",
number = number,
repeats = repeats,
classProbs = TRUE,
allowParallel = TRUE,
summaryFunction = twoClassSummary)
# Trani Logistic Model with train data:
my_logit <- train(Class ~.,
data = train,
method = "glm",
trControl = train.control)
# Use model for predicting PD:
pd <- predict(my_logit, test, type = "prob") %>% pull(Bad)
# Calculate optimal cutoff by sensitivity and accuracy criterion:
m <- cutpointr(x = pd, class = test$Class, metric = sens_constrain, pos_class = "Bad")
n <- cutpointr(x = pd, class = test$Class, metric = accuracy, pos_class = "Bad")
# Optimal cutoff:
t1 <- m$optimal_cutpoint # maximize sensitivity.
t2 <- n$optimal_cutpoint # maximize accuracy.
# Plot ROC curve with optimal cutoff:
gridExtra::grid.arrange(plot(m), plot(n))
## [1] 0.7504762## [1] 0.7504762Effects on Profit
# Function for labelling credit applications:
label_predicted <- function(cutoff) {
y <- case_when(pd >= cutoff ~ "Bad", TRUE ~ "Good") %>% as.factor()
return(y)
}
# Confution maxtrix:
confusionMatrix(label_predicted(t1), test$Class, positive = "Bad") # If t1 is selected for classification. ## Confusion Matrix and Statistics
##
## Reference
## Prediction Bad Good
## Bad 76 102
## Good 14 108
##
## Accuracy : 0.6133
## 95% CI : (0.5557, 0.6687)
## No Information Rate : 0.7
## P-Value [Acc > NIR] : 0.9995
##
## Kappa : 0.2804
##
## Mcnemar's Test P-Value : 6.597e-16
##
## Sensitivity : 0.8444
## Specificity : 0.5143
## Pos Pred Value : 0.4270
## Neg Pred Value : 0.8852
## Prevalence : 0.3000
## Detection Rate : 0.2533
## Detection Prevalence : 0.5933
## Balanced Accuracy : 0.6794
##
## 'Positive' Class : Bad
## ## Confusion Matrix and Statistics
##
## Reference
## Prediction Bad Good
## Bad 38 23
## Good 52 187
##
## Accuracy : 0.75
## 95% CI : (0.697, 0.798)
## No Information Rate : 0.7
## P-Value [Acc > NIR] : 0.032245
##
## Kappa : 0.3444
##
## Mcnemar's Test P-Value : 0.001224
##
## Sensitivity : 0.4222
## Specificity : 0.8905
## Pos Pred Value : 0.6230
## Neg Pred Value : 0.7824
## Prevalence : 0.3000
## Detection Rate : 0.1267
## Detection Prevalence : 0.2033
## Balanced Accuracy : 0.6563
##
## 'Positive' Class : Bad
## # Results of Classification by the two methods:
test %>%
mutate(Class_max_sen = label_predicted(t1),
Class_max_accuracy = label_predicted(t2)) -> test_t1_t2
test_t1_t2 %>%
filter(Class_max_sen == "Good", Class == "Good") %>%
select(Class, Class_max_sen, Amount) -> df_Good_max_sen
test_t1_t2 %>%
filter(Class_max_sen == "Good", Class == "Bad") %>%
select(Class, Class_max_sen, Amount) -> df_Bad_max_sen
test_t1_t2 %>%
filter(Class_max_accuracy == "Good", Class == "Good") %>%
select(Class, Class_max_accuracy, Amount) -> df_Good_max_acc
test_t1_t2 %>%
filter(Class_max_accuracy == "Good", Class == "Bad") %>%
select(Class, Class_max_accuracy, Amount) -> df_Bad_max_acc
# Calculate profit if interest rate for personal loan = 10%:
ir <- 0.15
sum(ir*df_Good_max_sen$Amount) - sum(df_Bad_max_sen$Amount)## [1] 87.25## [1] -97150.35# Function for calculating profit:
profit <- function(ir) {
pro1 <- sum(ir*df_Good_max_sen$Amount) - sum(df_Bad_max_sen$Amount)
pro2 <- sum(ir*df_Good_max_acc$Amount) - sum(df_Bad_max_acc$Amount)
return(data.frame(IR = ir, Pro = c(pro1, pro2), Method = c("MaxSen", "MaxAcc")))
}
# Compare profit:
library(ggdark)
lapply(seq(0.1, 0.3, by = 0.01), profit) -> profit_list
do.call("rbind", profit_list) %>%
mutate(Pro = Pro / 1000) %>%
ggplot(aes(IR, Pro, color = Method)) +
geom_line() +
geom_point() +
scale_x_continuous(breaks = seq(0.1, 0.3, by = 0.01), labels = scales::percent) +
labs(x = "Interest Rate", y = "Profit",
title = "Profit Comparision by Classification Method") + dark_theme_gray()
LS0tCnRpdGxlOiAiVXNpbmcgQWNjdXJhY3kgQ3JpdGVyaW9uIGZvciBDcmVkaXQgQ2xhc3NpZmljYXRpb24gQ2FuIENhdXNlIERpc2FzdGVyIGZvciBCYW5rcyIKYXV0aG9yOiAiSmVubnkiCnN1YnRpdGxlOiAiUiBmb3IgUGxlYXN1cmUiCm91dHB1dDoKICBodG1sX2RvY3VtZW50OgogICAgY29kZV9kb3dubG9hZDogeWVzCiAgICBjb2RlX2ZvbGRpbmc6IGhpZGUKICAgIGhpZ2hsaWdodDogemVuYnVybgogICAgdGhlbWU6IGZsYXRseQogICAgdG9jOiB5ZXMKICAgIHRvY19mbG9hdDogeWVzCiAgd29yZF9kb2N1bWVudDoKICAgIHRvYzogeWVzCi0tLQoKYGBge3Igc2V0dXAsaW5jbHVkZT1GQUxTRX0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGVjaG8gPSBUUlVFLCB3YXJuaW5nID0gRkFMU0UsIG1lc3NhZ2UgPSBGQUxTRSwgZmlnLnJldGluYT0yKQpgYGAKCiMgUHVycG9zZQoKTWFjaGluZSBMZWFybmluZyBjYW4gYmUgbW9yZSBwcm9kdWN0aXZlIHdoZW4gdGhlIG1vZGVsZXJzIG5vdCBvbmx5IGZvY3VzIG9uIHRoZSBhY2N1cmFjeSBvZiB0aG9zZSBtb2RlbHMgdGhlbXNlbHZlLCBidXQgYWxzbyB0aGUgYnVzaW5lc3MgdmFsdWUgYW5kIHJlcXVpcmVtZW50cyAocHJvZml0cyBvciBsb3N0LCBldGMuKS4gQmVsb3cgaXMgc29tZSBkaXNjb3Zlcnkgb24gdGhpcy4gCgojIE1heGltaXplIFRocmVzaG9sZCBmb3IgQWNjdXJhY3kgYW5kIFNlbnNpdGl2aXR5CgoKYGBge3J9CiM9PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT0KIyBVc2luZyBBY2N1cmFjeSBDcml0ZXJpb24gZm9yIENyZWRpdCBDbGFzc2lmaWNhdGlvbiBDYW4gQ2F1c2UgRGlzYXN0ZXIgZm9yIEJhbmtzLiAKIz09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PQogCgojIExvYWQgUiBwYWNrYWdlczogCnJtKGxpc3QgPSBscygpKQpsaWJyYXJ5KGN1dHBvaW50cikKbGlicmFyeSh0aWR5dmVyc2UpCmxpYnJhcnkoY2FyZXQpCgojIExvYWQgR2VybWFuQ3JlZGl0IERhdGE6IApkYXRhKCJHZXJtYW5DcmVkaXQiKQpkZiA8LSBHZXJtYW5DcmVkaXQgCgojIFNwbGl0IGRhdGE6IApzZXQuc2VlZCgxKQppZCA8LSBjcmVhdGVEYXRhUGFydGl0aW9uKHkgPSBkZiRDbGFzcywgcCA9IDAuNywgbGlzdCA9IEZBTFNFKQp0cmFpbiA8LSBkZltpZCwgXQp0ZXN0IDwtIGRmWy1pZCwgXQoKIyBTZXQgY29uZGl0aW9ucyBmb3IgdHJhaW5pbmcgTG9naXN0aWMgTW9kZWw6IAoKbnVtYmVyIDwtIDUKcmVwZWF0cyA8LSA1CgpzZXQuc2VlZCgxKQp0cmFpbi5jb250cm9sIDwtIHRyYWluQ29udHJvbChtZXRob2QgPSAicmVwZWF0ZWRjdiIsIAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBudW1iZXIgPSBudW1iZXIsCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIHJlcGVhdHMgPSByZXBlYXRzLCAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgY2xhc3NQcm9icyA9IFRSVUUsCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIGFsbG93UGFyYWxsZWwgPSBUUlVFLCAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgc3VtbWFyeUZ1bmN0aW9uID0gdHdvQ2xhc3NTdW1tYXJ5KQoKCiMgVHJhbmkgTG9naXN0aWMgTW9kZWwgd2l0aCB0cmFpbiBkYXRhOiAKbXlfbG9naXQgPC0gdHJhaW4oQ2xhc3Mgfi4sIAogICAgICAgICAgICAgICAgICBkYXRhID0gdHJhaW4sIAogICAgICAgICAgICAgICAgICBtZXRob2QgPSAiZ2xtIiwgCiAgICAgICAgICAgICAgICAgIHRyQ29udHJvbCA9IHRyYWluLmNvbnRyb2wpCgoKIyBVc2UgbW9kZWwgZm9yIHByZWRpY3RpbmcgUEQ6IApwZCA8LSBwcmVkaWN0KG15X2xvZ2l0LCB0ZXN0LCB0eXBlID0gInByb2IiKSAlPiUgcHVsbChCYWQpCgoKIyBDYWxjdWxhdGUgb3B0aW1hbCBjdXRvZmYgYnkgc2Vuc2l0aXZpdHkgYW5kIGFjY3VyYWN5IGNyaXRlcmlvbjogCm0gPC0gY3V0cG9pbnRyKHggPSBwZCwgY2xhc3MgPSB0ZXN0JENsYXNzLCBtZXRyaWMgPSBzZW5zX2NvbnN0cmFpbiwgcG9zX2NsYXNzID0gIkJhZCIpCm4gPC0gY3V0cG9pbnRyKHggPSBwZCwgY2xhc3MgPSB0ZXN0JENsYXNzLCBtZXRyaWMgPSBhY2N1cmFjeSwgcG9zX2NsYXNzID0gIkJhZCIpCgojIE9wdGltYWwgY3V0b2ZmOiAKdDEgPC0gbSRvcHRpbWFsX2N1dHBvaW50ICMgbWF4aW1pemUgc2Vuc2l0aXZpdHkuIAp0MiA8LSBuJG9wdGltYWxfY3V0cG9pbnQgIyBtYXhpbWl6ZSBhY2N1cmFjeS4gCgojIFBsb3QgUk9DIGN1cnZlIHdpdGggb3B0aW1hbCBjdXRvZmY6IApncmlkRXh0cmE6OmdyaWQuYXJyYW5nZShwbG90KG0pLCBwbG90KG4pKQoKIyBYIGlzIHVuY2hhbmdlZCByZWdhcmRsZXNzIG9mIG1ldGhvZCBzZWxlY3RlZDogCgptJEFVQwpuJEFVQwpgYGAKCgojIEVmZmVjdHMgb24gUHJvZml0CgoKYGBge3J9CiMgRnVuY3Rpb24gZm9yIGxhYmVsbGluZyBjcmVkaXQgYXBwbGljYXRpb25zOiAKCmxhYmVsX3ByZWRpY3RlZCA8LSBmdW5jdGlvbihjdXRvZmYpIHsKICB5IDwtIGNhc2Vfd2hlbihwZCA+PSBjdXRvZmYgfiAiQmFkIiwgVFJVRSB+ICJHb29kIikgJT4lIGFzLmZhY3RvcigpCiAgcmV0dXJuKHkpCn0KCiMgQ29uZnV0aW9uIG1heHRyaXg6IApjb25mdXNpb25NYXRyaXgobGFiZWxfcHJlZGljdGVkKHQxKSwgdGVzdCRDbGFzcywgcG9zaXRpdmUgPSAiQmFkIikgIyBJZiB0MSBpcyBzZWxlY3RlZCBmb3IgY2xhc3NpZmljYXRpb24uIApjb25mdXNpb25NYXRyaXgobGFiZWxfcHJlZGljdGVkKHQyKSwgdGVzdCRDbGFzcywgcG9zaXRpdmUgPSAiQmFkIikgIyBJZiB0MiBpcyBzZWxlY3RlZCBmb3IgY2xhc3NpZmljYXRpb24uIAoKIyBSZXN1bHRzIG9mIENsYXNzaWZpY2F0aW9uIGJ5IHRoZSB0d28gbWV0aG9kczogCgp0ZXN0ICU+JSAKICBtdXRhdGUoQ2xhc3NfbWF4X3NlbiA9IGxhYmVsX3ByZWRpY3RlZCh0MSksCiAgICAgICAgIENsYXNzX21heF9hY2N1cmFjeSA9IGxhYmVsX3ByZWRpY3RlZCh0MikpIC0+IHRlc3RfdDFfdDIKCnRlc3RfdDFfdDIgJT4lIAogIGZpbHRlcihDbGFzc19tYXhfc2VuID09ICJHb29kIiwgQ2xhc3MgPT0gIkdvb2QiKSAlPiUgCiAgc2VsZWN0KENsYXNzLCBDbGFzc19tYXhfc2VuLCBBbW91bnQpIC0+IGRmX0dvb2RfbWF4X3NlbgoKdGVzdF90MV90MiAlPiUgCiAgZmlsdGVyKENsYXNzX21heF9zZW4gPT0gIkdvb2QiLCBDbGFzcyA9PSAiQmFkIikgJT4lIAogIHNlbGVjdChDbGFzcywgQ2xhc3NfbWF4X3NlbiwgQW1vdW50KSAtPiBkZl9CYWRfbWF4X3NlbgoKdGVzdF90MV90MiAlPiUgCiAgZmlsdGVyKENsYXNzX21heF9hY2N1cmFjeSA9PSAiR29vZCIsIENsYXNzID09ICJHb29kIikgJT4lIAogIHNlbGVjdChDbGFzcywgQ2xhc3NfbWF4X2FjY3VyYWN5LCBBbW91bnQpIC0+IGRmX0dvb2RfbWF4X2FjYwoKdGVzdF90MV90MiAlPiUgCiAgZmlsdGVyKENsYXNzX21heF9hY2N1cmFjeSA9PSAiR29vZCIsIENsYXNzID09ICJCYWQiKSAlPiUgCiAgc2VsZWN0KENsYXNzLCBDbGFzc19tYXhfYWNjdXJhY3ksIEFtb3VudCkgLT4gZGZfQmFkX21heF9hY2MKCgojIENhbGN1bGF0ZSBwcm9maXQgaWYgaW50ZXJlc3QgcmF0ZSBmb3IgcGVyc29uYWwgbG9hbiA9IDEwJTogCmlyIDwtIDAuMTUKc3VtKGlyKmRmX0dvb2RfbWF4X3NlbiRBbW91bnQpIC0gc3VtKGRmX0JhZF9tYXhfc2VuJEFtb3VudCkKc3VtKGlyKmRmX0dvb2RfbWF4X2FjYyRBbW91bnQpIC0gc3VtKGRmX0JhZF9tYXhfYWNjJEFtb3VudCkKCgoKIyBGdW5jdGlvbiBmb3IgY2FsY3VsYXRpbmcgcHJvZml0OiAKCnByb2ZpdCA8LSBmdW5jdGlvbihpcikgewogIHBybzEgPC0gc3VtKGlyKmRmX0dvb2RfbWF4X3NlbiRBbW91bnQpIC0gc3VtKGRmX0JhZF9tYXhfc2VuJEFtb3VudCkKICBwcm8yIDwtIHN1bShpcipkZl9Hb29kX21heF9hY2MkQW1vdW50KSAtIHN1bShkZl9CYWRfbWF4X2FjYyRBbW91bnQpCiAgcmV0dXJuKGRhdGEuZnJhbWUoSVIgPSBpciwgUHJvID0gYyhwcm8xLCBwcm8yKSwgTWV0aG9kID0gYygiTWF4U2VuIiwgIk1heEFjYyIpKSkKfQoKCiMgQ29tcGFyZSBwcm9maXQ6IApsaWJyYXJ5KGdnZGFyaykKbGFwcGx5KHNlcSgwLjEsIDAuMywgYnkgPSAwLjAxKSwgcHJvZml0KSAtPiBwcm9maXRfbGlzdCAKCmRvLmNhbGwoInJiaW5kIiwgcHJvZml0X2xpc3QpICU+JSAKICBtdXRhdGUoUHJvID0gUHJvIC8gMTAwMCkgJT4lIAogIGdncGxvdChhZXMoSVIsIFBybywgY29sb3IgPSBNZXRob2QpKSArIAogIGdlb21fbGluZSgpICsgCiAgZ2VvbV9wb2ludCgpICsgCiAgc2NhbGVfeF9jb250aW51b3VzKGJyZWFrcyA9IHNlcSgwLjEsIDAuMywgYnkgPSAwLjAxKSwgbGFiZWxzID0gc2NhbGVzOjpwZXJjZW50KSArIAogIGxhYnMoeCA9ICJJbnRlcmVzdCBSYXRlIiwgeSA9ICJQcm9maXQiLCAKICAgICAgIHRpdGxlID0gIlByb2ZpdCBDb21wYXJpc2lvbiBieSBDbGFzc2lmaWNhdGlvbiBNZXRob2QiKSArIGRhcmtfdGhlbWVfZ3JheSgpCgpgYGAKCg==