Cumulative Accuracy Profile (CAP) and Accuracy Ratio (AR) Estimation

R for Fun

Introduction

Cuốn Risk Management in Banking của Joël Bessis đã được tái bản lần thứ 4. Ở Việt Nam cuốn này được dịch với tên gọi Quản Trị Rủi Ro Trong Ngân Hàng tương ứng với lần tái bản thứ 3.

Khi làm các mô hình Credit Risk và Scorecard thì một trong những thước đo thường được sử dụng để đánh giá chất lượng mô hình phân loại - xếp hạng là Cumulative Accuracy Profile (CAP) và cuốn sách dành hẳn một mục ở chương 20 để nói về CAP như sau:

Đây là một cuốn sách hay và chất lượng cho những ai làm mảng Credit Risk trong ngân hàng và các tổ chức tài chính. Tuy vậy cuốn sách thuộc nhóm sách trình bày ý tưởng mà không hề có bất kì phần thực hành nào. Rất may là khái niệm về CAP này đã được mô tả chi tiết hơn cũng như kèm với phần thực hành bằng Excel - VBA tại trang 182 của cuốn Credit Risk Modeling using Excel and VBA như sau:

Đường CAP thường bị nhầm lẫn với ROC (Receiver Operating Characteristics) vì cả hai đường này có nhiều điểm chung về mặt ý nghĩa. Chẳng hạn, một mô hình có khả năng phân biệt càng tốt thì đường cong CAP và ROC càng lồi lên phía trên và trong tình huống một mô hình hoàn hảo thì diện tích nằm dưới CAP và ROC đều bằng 1.

CAP Curve and Accuracy Ratio (AR) Estimation

Trước hết chúng ta tái lập lại Table 8.1 của cuốn Credit Risk Modeling using Excel and VBA như sau:

# Load các package: 
library(tidyverse)
library(magrittr)

# Bộ dữ liệu minh họa được trình bày ở Table 8.1: 
df_example <- data.frame(Group = c("C", "B", "A"),
                         Bad = c(3, 1, 0), 
                         Good = c(1, 2, 3))


# Tính toán các thứ linh tinh khác và thêm vào điểm có tọa độ (0, 0): 
df_example %>% 
  mutate(Total_gr = Bad + Good, Total_obs = sum(Total_gr)) %>% 
  mutate(Per_gr = Total_gr / Total_obs) %>% 
  mutate(Per_cum = cumsum(Per_gr)) %>% 
  mutate(BadRate = Bad / sum(Bad)) %>% 
  mutate(BadRateCum = cumsum(BadRate)) -> df_cap_example


# Vẽ CAP: 
data.frame(Per_cum = c(0, df_cap_example$Per_cum), 
           BadRateCum = c(0, df_cap_example$BadRateCum)) -> df1


theme_set(theme_minimal())

df1 %>% 
  ggplot(aes(Per_cum, BadRateCum)) + 
  geom_line(color = "blue", size = 1.3) + 
  geom_point(color = "red", size = 2) + 
  labs(x = NULL, 
       title = "An Illustration of CAP Based on Data From Table 8.1") + 
  scale_y_continuous(labels = scales::percent)

Tương tự chúng ta có thể vẽ đường CAP với một bộ số liệu thực:

# Import data: 
hmeq <- read.csv("http://www.creditriskanalytics.net/uploads/1/9/5/1/19511601/hmeq.csv")

# Function replaces NA by mean: 
replace_by_mean <- function(x) {
  x[is.na(x)] <- mean(x, na.rm = TRUE)
  return(x)
}

# A function imputes NA observations for categorical variables: 

replace_na_categorical <- function(x) {
  x %>% 
    table() %>% 
    as.data.frame() %>% 
    arrange(-Freq) ->> my_df
  
  n_obs <- sum(my_df$Freq)
  pop <- my_df$. %>% as.character()
  set.seed(29)
  x[is.na(x)] <- sample(pop, sum(is.na(x)), replace = TRUE, prob = my_df$Freq)
  return(x)
}

# Use the two functions: 
df <- hmeq %>% 
  mutate_if(is.factor, as.character) %>% 
  mutate(REASON = case_when(REASON == "" ~ NA_character_, TRUE ~ REASON), 
         JOB = case_when(JOB == "" ~ NA_character_, TRUE ~ JOB)) %>%
  mutate_if(is_character, as.factor) %>% 
  mutate_if(is.numeric, replace_by_mean) %>% 
  mutate_if(is.factor, replace_na_categorical)


# Phân chia dữ liệu: 

set.seed(2)
df_train <- df %>% group_by(BAD) %>% sample_frac(0.5, replace = FALSE)
df_test <- setdiff(df, df_train)


# Thực hiện Logistic: 
my_logistic <- glm(BAD ~ ., family = "binomial", data = df_train)

# PD từ mô hình Logistic: 
pd_logistic <- predict(my_logistic, df_test %>% select(-BAD), type = "response")

Kế tiếp là vẽ CAP (tham khảo kĩ hơn một trong hai cuốn sách ở trên về CAP Curve nếu thấy cần thiết ):

df_test %>% 
  mutate(PD = pd_logistic, BAD = case_when(BAD == 1 ~ "Bad", TRUE ~ "Good")) %>% 
  select(BAD, PD) %>% 
  mutate(Group = cut_interval(PD, 10)) %>% 
  group_by(Group, BAD) %>% 
  count() %>% 
  ungroup() %>% 
  spread(key = "BAD", value = "n") %>% 
  mutate(Good = replace_na(Good, 0)) %>% 
  mutate(RankRisk = 1:nrow(.)) %>% 
  arrange(-RankRisk) %>% 
  mutate(Total_gr = Bad + Good) %>% 
  mutate(Total_obs = sum(Total_gr)) %>% 
  mutate(BadRate = Bad / sum(Bad)) %>% 
  mutate(BadRateCum = cumsum(BadRate)) %>% 
  mutate(Per_gr = Total_gr / Total_obs)  %>% 
  mutate(Per_cum = cumsum(Per_gr)) %>% 
  mutate(Rate = Bad / Total_gr) -> df_cap


df_cap %>% 
  ggplot(aes(Per_cum, BadRateCum)) + 
  geom_line(color = "blue", size = 1.3) + 
  geom_point(color = "red", size = 2) + 
  labs(x = NULL, 
       title = "CAP for Logistic Model", 
       caption = "Data Source: http://www.creditriskanalytics.net/uploads/1/9/5/1/19511601/hmeq.csv") + 
  scale_y_continuous(labels = scales::percent)

Accuracy Ratio (AR) là một chỉ tiêu được ước lượng dựa trên CAP bằng hàm ARestimate():

mini_df <- df_cap %>% 
  select(Rate, Total_gr, RankRisk) %>% 
  arrange(-Rate)

library(LDPD)
ARestimate(mini_df$Rate, mini_df$Total_gr, rating.type = "RATING")

## $AR
## [1] 0.5514627
## 
## $CT
## [1] 0.1996644

Theo thông lệ, một mô hình được gọi là chấp nhận được nếu AR cao hơn 30%. Trong trường hợp này thì mô hình Logistic là xài được vì có AR là 55%.

References

Baesens, B., Roesch, D., & Scheule, H. (2016). Credit risk analytics: Measurement techniques, applications, and examples in SAS. John Wiley & Sons.

Bessis, J. (2015). Risk management in banking. John Wiley & Sons.

Löeffler, G., & Posch, P. N. (2011). Credit risk modeling using Excel and VBA. John Wiley & Sons.

Tasche, D. (2009) Estimating discriminatory power and PD curves when the number of defaults is small. Working paper, Lloyds Banking Group. Tasche, D. (2013) The art of probability-of-default curve calibration. Journal of Credit Risk, 9:63-103.