Medición del riesgo de crédito: Construcción de un Scorecard

Objetivo

Este documento tiene como objetivo ilustrar los pasos (simplificados) para la modelación de riesgo de crédito. Para esto se utilizará el conjunto de datos Credit Card Approval Prediction que contiene información sobre solicitudes de tarjetas de crédito y la evolución de las aprobadas.

Adicionalmente se utilizarán dos metodologías para medir la probabilidad de impago: Un modelo logit estándar y la metodología “scorecard” basada en el peso de la evidencia (en adelante WoE, por sus siglas en inglés).

Si bien el estudio no trata de ser extensivo (no se utilizarán todas las técnicas disponibles en cada una de las etapas), sí trata de dar una visión general del proceso de modelación y las técnicas antes mencionadas.

Metodología clásica

Setup

Inicialmente cargamos las librerías que se utilizarán en el análisis:

library(caret)
library(tidyverse)
library(scorecard)
library(ggcorrplot)
library(kableExtra)

Básicamente se utilizan las librerías caret especializada en modelos de machine learning, tidyverse para la limpieza y visualización de datos, scorecard para el cálculo rápido de los WoE y ggcorrplot un wrapper para la visualización de matrices de correlación.

Cargar y limpiar los datos

Como primer paso cargamos los datos:

application_record <- read.csv("3_Clasificacion/CreditCardApproval_Dataset/application_record.csv")
credit_record <- read.csv("3_Clasificacion/CreditCardApproval_Dataset/credit_record.csv")

Como contexto, el conjunto de datos application_record.csv almacena la información de las solicitudes por tarjetas de crédito y algunas características que fueron tomadas al momento de que el cliente hizo la solicitud. El detalle se explica en la siguiente tabla:

Por otra parte, credit_record.csv contiene el estado actual de los clientes a los cuales sí le fue aprobada la tarjeta de crédito:

Predictores

Inicialmente, verificamos el tipo de información que existe en application_record.csv:

application_record |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Este conjunto de datos contiene $438,557$ observaciones de aplicaciones de tarjetas de crédito, una columna identificador, ID (primary key) y $17$ características que pueden ser utilizadas como predictores del impago.

Como se puede observar, existen variables numéricas y caracteres que no están en el formato correcto para realizar el análisis. Más adelante volveremos sobre ello.

Target

Ahora, analizando los datos contenidos en credit_record.csv:

credit_record |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Nótese que este conjunto de datos contiene el historial de pagos de las tarjetas de crédito aprobadas, compuesto por el mes desde que se otorgó la tarjeta, MONTHS_BALANCE y el estado en que se encontraba esa tarjeta a fin de mes, STATUS, además de un identificador que las vincula con sus características, ID.

Este conjunto de datos tiene $1,048,575$ filas, un número muy superior a las solicitadas, lo cual nos da un indicio que tendremos que agregar esta información de alguna manera.

Entendiendo el target

Entender esta información es vital para nuestro análisis. Es decir, dado que el target es la variable que vamos a predecir, debemos tener un correcto entendimiento del mismo. Una primer pregunta es entender la cantidad de valores únicos:

credit_record |> 
    distinct(ID) |> 
    summarise(Count = n()) |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Es decir, a la fecha de extracción de los datos se tenían $45,985$ tarjetas colocadas. ¿Cómo se han ido aprobando en el tiempo?

credit_record |> 
    arrange(ID,MONTHS_BALANCE) |> 
    distinct(ID,.keep_all = T) |> 
    group_by(MONTHS_BALANCE) |> 
    summarise(Count = n()) |> 
    ggplot(aes(x= MONTHS_BALANCE, y=Count))+
    geom_bar(stat= "identity", color ="black", fill = "steelblue") +
    geom_text(aes(label= ifelse(-MONTHS_BALANCE %% 5 == 0,Count, NA)),
              position =  position_dodge(width = 1), vjust = -1.5, size = 2 ) +
    labs( x= "\nMes de otorgación" ,y = "Número de nuevas tarjetas\n")+
    theme_bw()

Nótese la tendencia positiva en la colocación de tarjetas.

Lo siguiente es tener una idea visual del rendimiento de esta cartera en términos de impago o del STATUS de las tarjetas en el tiempo. Como no se tiene una medida monetaria, que es usualmente la forma en que se reporta el impago, veremos qué proporción de las tarjetas colocadas se encuentran en los diferentes estados. Para esto, recordemos la definición de STATUS:

Graficando:

credit_record |> 
    mutate(Estado = case_when(STATUS== "0" |STATUS== "C" | STATUS=="X" ~ "Vigente",
                              STATUS== "1" |STATUS== "2" ~ "Vencido",
                              STATUS== "3" |STATUS== "4" ~ "Ejecución",
                              STATUS== "5" ~ "Castigado")) |> 
    group_by(MONTHS_BALANCE,Estado) |> 
    summarise(Count = n()) |> 
    ggplot(aes(x= MONTHS_BALANCE, y=Count, fill= Estado))+
    geom_bar(stat= "identity", color ="black") +
    labs( x= "\nMes" ,y = "Número de operaciones\n")+
    scale_fill_manual(values = c("gray1","gray30", "gray60","steelblue"))+
    theme_bw()

Nótese que aquí vemos una conducta importante: del total de las tarjetas otorgadas, solo una pequeña proporción se encuentra en algún estado que denote impago. Esta característica de los datos es conocida en la literatura como class imbalance y deberá ser tomada en cuenta a la hora de la modelación.

Viendo el estado como proporción:

credit_record |> 
    mutate(Estado = case_when(STATUS== "0" |STATUS== "C" | STATUS=="X" ~ "Vigente",
                              STATUS== "1" |STATUS== "2" ~ "Vencido",
                              STATUS== "3" |STATUS== "4" ~ "Ejecución",
                              STATUS== "5" ~ "Castigado")) |> 
    group_by(MONTHS_BALANCE,Estado) |> 
    summarise(Count = n()) |> 
    ggplot(aes(x= MONTHS_BALANCE, y=Count, fill= Estado))+
    geom_bar(stat= "identity", color ="black", position = "fill") +
    labs( x= "\nMes" ,y = "Proporción de operaciones\n")+
    scale_fill_manual(values = c("gray1","gray30", "gray60","steelblue"))+
    theme_bw()

El gráfico anterior reafirma que la proporción de tarjetas que muestran algún indicio de impago es bastante pequeño. Es más, el mes de extracción de los datos solo el $1.19\%$ de las tarjetas mostraba un estado que no sea vigente.

Finalmente, para tener una idea de cómo ha evolucionado esta proporción en el tiempo, se grafica la proporción de operaciones “morosas” en el tiempo. Esto se define como¹:

$$mora = \frac{Vencido+Ejecución+Castigado}{Vigente+Vencido+Ejecución+Castigado} $$

credit_record |> 
    mutate(Estado = case_when(STATUS== "0" |STATUS== "C" | STATUS=="X" ~ "Vigente",
                              STATUS== "1" |STATUS== "2" ~ "Vencido",
                              STATUS== "3" |STATUS== "4" ~ "Ejecución",
                              STATUS== "5" ~ "Castigado"),
           Mora = ifelse(Estado != "Vigente", "Mora", "Vigente")) |> 
    group_by(MONTHS_BALANCE,Mora) |> 
    summarise(Count = n()) |> 
   # ungroup() |> 
    mutate(prop= Count/sum(Count)*100) |> 
    filter(Mora == "Mora") |> 
    ggplot(aes(x= MONTHS_BALANCE, y=prop))+
    geom_bar(stat= "identity", color ="black", fill= "steelblue") +
    geom_text(aes(label= ifelse(-MONTHS_BALANCE %% 4 == 0,round(prop,2), NA)),
              position =  position_dodge(width = 1), vjust = -2.5, size = 2.5 ) +
    labs( x= "\nMes" ,y = "Proporción de tarjetas en mora\n")+
    #scale_fill_manual(values = c("gray1","gray30", "gray60","steelblue"))+
    theme_bw()

Donde se observa que la proporción de tarjetas en mora se ha mantenido en torno al $1.2\%$

Análisis de cohortes

Una cuestión interesante es ver cómo se comportaron, digamos los primeros 12 meses, las tarjetas que se otorgaron hace 60 meses y analizarlas como un segmento particular. Luego, podríamos preguntarnos lo mismo pero solamente con las tarjetas que se otorgaron hace 59 meses y hacia adelante. Este tipo de análisis suele llamarse de “cohortes” o “vintage” y nos permite comparar las operaciones en el mismo horizonte temporal. Esto va a ser importante cuando tengamos que elegir la definición de mora o target que vamos a intentar predecir.

cohort <- credit_record |> 
    arrange(ID,MONTHS_BALANCE,STATUS) %>%
    group_by(ID) %>%
    slice(1:24) %>%
    mutate(Mes = seq(1:length(ID)),
           Estado = case_when(STATUS== "0" |STATUS== "C" ~ "Vigente",
                              STATUS== "1" |STATUS== "2" ~ "Vencido",
                              STATUS== "3" |STATUS== "4" ~ "Ejecutado",
                              STATUS== "5" ~ "Castigado",
                              TRUE ~ "Vigente"),
           Mora = ifelse(Estado %in% c("Vencido","Ejecutado","Castigado"),1,0)) 

cohort |> 
    group_by(ID) |> 
    mutate(Mes_inicial = first(MONTHS_BALANCE)) |> 
    group_by(Mes_inicial,Mes) |> 
    summarise(Mora = round(mean(Mora)*100,2 )) |> 
    #pivot_wider(names_from = Mes, values_from = Mora) |> 
    ggplot(aes(y= -Mes_inicial,x=Mes, fill=Mora))+
    geom_tile()+
    scale_fill_gradient(low="gray90", high="steelblue") +
    labs(x = "\nMeses desde que se le otorgó la tarjeta",
         y = "Hace cuántos meses se le otorgó la tarjeta\n")+
    theme_minimal()

Nótese del gráfico anterior que parece haber un incremento en la morosidad entre los meses 4 a 12. Una vez pasado los 12 meses de otorgada la tarjeta los niveles de impago suelen disminuir. Esto puede tener distintas explicaciones, que van desde la política crediticia de la entidad, el mercado al que se está abordando, entre otros.

El análisis anterior es importante porque nos permite incluir la temporalidad en nuestro target, es decir, dado que un individuo que recibe una tarjeta de crédito hoy puede estar vigente el siguiente mes y el siguiente pero quizás no el tercero, debemos definir cuándo una tarjeta puede clasificarse como morosa, es decir, cuál es el horizonte temporal de nuestra predicción. Una primer opción sería:

Se define como morosa o delincuencial una tarjeta de crédito que en los primeros 12 meses de haber sido otorgada haya tenido 30 días o más de atraso en sus pagos.

Por tanto, para codificar nuestra variable $Y$ tenemos que ir tarjeta por tarjeta y, desde el momento de su otorgación hasta el mes $12$, verificar si cae dentro de nuestra definición de mora. El siguiente bloque de código hace precisamente eso:

# Crear un df con aquellas tarjetas con más de 12 meses de uso

cc_mt12m <- credit_record |> 
    arrange(ID,MONTHS_BALANCE) |> 
    distinct(ID,.keep_all = T) |> 
    filter(MONTHS_BALANCE <= -12) |> 
    select(ID) 

# Filtrar en `credit_record.csv` aquellas tarjetas que tienen más de 12 meses y
# crear una variable mora que tome 1 si en cualquiera de estos meses se cumple
# nuestra definición de mora

target_mt12m <- credit_record |> 
    filter(ID %in% cc_mt12m$ID) |> 
    arrange(ID,MONTHS_BALANCE) |> 
    group_by(ID) |> 
    mutate(index = row_number())  |> 
    filter(index <= 12) |> 
    mutate(mora = ifelse(STATUS %in% c("1","2","3","4","5"), 1, 0))


target_30dpd_12m <- target_mt12m |> 
    group_by(ID) |> 
    summarise(mora =  max(mora))

target_30dpd_12m |> 
    head(10) |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

¿Cuántas tarjetas caen en nuestra definición?

prop_table <- prop.table(table(target_30dpd_12m$mora))*100

prop_table |> 
        head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Nótese que aproximadamente un $10\%$ de las tarjetas otorgadas cumplió presentó un atraso de al menos $30$ días los primeros $12$ meses después de otorgada.

Vamos a realizar el mismo ejercicio pero alargando el horizonte de predicción a $24$ meses:

# Crear un df con aquellas tarjetas con más de 24 meses de uso

cc_mt24m <- credit_record |> 
    arrange(ID,MONTHS_BALANCE) |> 
    distinct(ID,.keep_all = T) |> 
    filter(MONTHS_BALANCE <= -24) |> 
    select(ID) 

# Filtrar en `credit_record.csv` aquellas tarjetas que tienen más de 12 meses y
# crear una variable mora que tome 1 si en cualquiera de estos meses se cumple
# nuestra definición de mora

target_mt24m <- credit_record |> 
    filter(ID %in% cc_mt24m$ID) |> 
    arrange(ID,MONTHS_BALANCE) |> 
    group_by(ID) |> 
    mutate(index = row_number())  |> 
    filter(index <= 24) |> 
    mutate(mora = ifelse(STATUS %in% c("1","2","3","4","5"), 1, 0))

target_30dpd_24m <- target_mt24m |> 
    group_by(ID) |> 
    summarise(mora =  max(mora))

prop_table1 <- prop.table(table(target_30dpd_24m$mora))*100

prop_table1 |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Donde se incrementa la proporción de tarjetas que cumplen esta definición, pero se reduce el tamaño de la muestra, pues se deben omitir todas las tarjetas que no tengan al menos $24$ meses de antigüedad.

Así, para la modelación, se utilizará la primer definición que se reproduce a continuación:

Se define como morosa o delincuencial una tarjeta de crédito que en los primeros 12 meses de haber sido otorgada haya tenido 30 días o más de atraso en sus pagos.

Finalmente, convertimos el target en un factor:

target_30dpd_12m$mora <- as.factor(ifelse(target_30dpd_12m$mora==1,"Yes","No"))

Feature engineering

Ahora vamos a analizar la información contenida en application_record.csv y la vamos a transformar de modo que se puedan utilizar luego como inputs en el modelo.

application_record |> 
        head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Missing values

Primero, verificamos que no hayan missing values:

NAs <- sapply(application_record, function(x) sum(is.na(x)))
NULLs <- sapply(application_record, function(x) sum(is.null(x)))
Blank <- sapply(application_record, function(x) sum(ifelse(x=="",1,0)))

data.frame(NAs,NULLs,Blank)  |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

La variable OCCUPATION_TYPE contiene un gran número de variables faltantes. Sin embargo, esto también pueden ocurrir porque son individuos que están desempleados:

# Crear un df con una variable indicador para el empleo
data_tmp <- application_record |> 
    mutate(Employment=ifelse(DAYS_EMPLOYED > 0,0,1)) |> 
    select(Employment, OCCUPATION_TYPE)

# Obtener las proporción de individuos empleados y desempleados
prop.table(table(data_tmp$Employment)) |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

prop.table(table(data_tmp$Employment, data_tmp$OCCUPATION_TYPE)) |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Como se puede observar, existe un $13.4\%$ de los individuos empleados que no tiene un OCCUPATION_TYPE por lo cual se eliminará esta variable del análisis²:

application_record$OCCUPATION_TYPE <- NULL

Factors for analysis

Básicamente, en este modelo tenemos variables indicadores (que toman solo 2 valores), variables categóricas (múltiples valores) y variables numéricas.

application_record |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

fct_var <- c("CODE_GENDER","FLAG_OWN_CAR","FLAG_OWN_REALTY","NAME_INCOME_TYPE","NAME_EDUCATION_TYPE","NAME_FAMILY_STATUS","NAME_HOUSING_TYPE","FLAG_MOBIL","FLAG_WORK_PHONE","FLAG_PHONE","FLAG_EMAIL")

application_record <- application_record |> 
    mutate_at(fct_var, as.factor)

Revisando el conjunto de datos:

application_record |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Numeric transformation

Ahora vamos a convertir en años las variables DAYS_BIRTH y DAYS_EMPLOYED:

application_record <- application_record |> 
    mutate(YEARS_BIRTH = -DAYS_BIRTH/365,
           YEARS_EMPLOYED = ifelse(DAYS_EMPLOYED > 0, 0, -DAYS_EMPLOYED/365)) 

application_record |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Una vez convertidas, eliminamos del conjunto de datos las variables iniciales:

application_record$DAYS_BIRTH <- NULL
application_record$DAYS_EMPLOYED  <- NULL

Finalmente, vamos a particionar la variable ingreso:

application_record$INCOME_BIN <- cut(log(application_record$AMT_INCOME_TOTAL),breaks = 5)

Summarizing dataset

Veamos cómo quedaron nuestro predictores:

as.data.frame(summary(application_record)) |> 
    filter(!is.na(Freq)) |> 
    select(-ID, Var2, Freq) |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Joining the dataset

Realizando un inner_join para unir nuestro target con nuestros predictores:

data <- dplyr::inner_join(target_30dpd_12m,application_record, by="ID")
data |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Se debe remover también la variable ID, AMT_INCOME_TOTAL y FLAG_MOBIL puesto que no entrarán en el análisis:

data$ID <- NULL
data$AMT_INCOME_TOTAL <- NULL
data$FLAG_MOBIL <- NULL

Correlation analysis

Una vez que tenemos el conjunto de datos listo, veamos cómo se comportan nuestras variables tanto unilateralmente como en relación al target.

Y en relación al target:

num_var <-  c("CNT_CHILDREN","YEARS_BIRTH","YEARS_EMPLOYED","CNT_FAM_MEMBERS")

data |> 
    select(num_var,mora) |> 
  pivot_longer(-mora, names_to = "variable", values_to = "value") %>% 
  ggplot(aes(x = mora, y = value)) +
  geom_boxplot() +
  facet_wrap(~ variable, scales = "free")

Viendo el análisis de correlación

data_num <- mutate_all(data,as.integer)
ggcorrplot::ggcorrplot(round(cor(data_num),2),
                       colors = c("red","white","steelblue"),
                       method ="circle",
                       outline.color = "black",
                       type = "upper",
                       ggtheme = ggplot2::theme_bw(),
                       lab = TRUE,
                       lab_size = 3,
                       pch = 100)

Modelación

Para realizar la modelación se utilizará la librería caret (que lleva su nombre por Classification And Regression Training). Una buena introducción puede encontrarse aquí.

El proceso de modelación se simplificará bastante, pues el objetivo es interpretar el modelo final. Básicamente, realizaremos una partición de los datos abordando el class-imbalance antes identificado utilizando el método de muestreo SMOTE.

Dividir los datos

Inicialmente se dividen los datos utilizando un $70\%$ de los mismos para entrenar el modelo y el resto para evaluarlo:

set.seed(1234)
trainIndex <- caret::createDataPartition(data$mora,
                                         p = .7,
                                         list = FALSE, 
                                         times = 1)

trainData <- data[trainIndex, ]
testData <- data[-trainIndex, ]

Validación cruzada

Ahora utilizamos la función trainControl donde especificamos algunas opciones que se utilizarán durante el entrenamiento. Particularmente utilizamos el método cv para realizará la validación cruzada utilizando el estándar k-Fold Cross-Validation con $k=10$ y el método de remuestreo SMOTE para abordar el class-imbalance:

cv <- caret::trainControl(method = "cv", 
                          number = 10, 
                          sampling = "smote")

Entrenamiento del modelo

Ahora, entrenamos un modelo logit utilizando la función train utilizando todos los predictores del conjunto de datos de entrenamiento:

logistic_model <- caret::train(mora ~ ., 
                               data = trainData, 
                               method = "glm",
                               family="binomial", 
                               trControl = cv)

Evaluación

Una vez nuestro modelo entrenado, vamos a revisar qué contiene:

model_summ <- summary(logistic_model)
model_summ_df <- as.data.frame(model_summ$coefficients)

Variable <- rownames(model_summ_df)

rownames(model_summ_df) <- NULL
model_summ_df <- cbind(Variable,model_summ_df) |> 
    mutate_if(is.double, round,2)


model_summ_df |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Ahora, veamos la capacidad del modelo recién calibrado para realizar predicciones:

predictions <- predict(logistic_model, newdata=testData, type="prob")
predictions <- cbind(predictions,Moroso =testData$mora)

predictions |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Nótese que, para poder evaluar el modelo, se necesita realizar un punto de corte. Por ejemplo, en el caso más simple podemos elegir:

Si la probabilidad de que el individuo entre en mora es mayor a un $50\%$ se cataloga al individuo como moroso

En base a ese criterio, los resultados son:

preds <- ifelse(predictions$Yes > 0.5,"Yes","No")

draw_confusion_matrix(caret::confusionMatrix(data = factor(preds, levels = c("Yes","No")), reference =testData$mora, positive = "Yes"))

¿Cómo se interpreta? Aunque el detalle de las métricas se muestra en el gráfico anterior, la interpretación es intuitiva. El modelo identificó correctamente a $3997$ clientes como buenos pagadores y a $435$ clientes como pagadores en los datos de testeo. Sin embargo, indicó que $3420$ individuos iban a ser malos pagadores cuando en realidad fueron buenos mientras que que $439$ iban a ser buenos pagadores cuando en realidad fueron malos.

Otra forma de verlo es separar a los buenos pagadores de los malos diferenciando por la probabilidad que les asignó el modelo:

predictions |> 
    ggplot(aes(x= Yes, fill=Moroso))+
    geom_histogram(color = "black", bins =50)+
    scale_fill_manual(values=c("steelblue", "gray80"))+
    labs(x= "\nProbabilidad de impago\n",
         y = "Frecuencia\n")+
    theme_bw()

¿Cómo se interpreta? En el ideal, si el modelo fuera perfecto, ambos histogramas (el de los que sí son morosos y el de los que no son morosos) deberían estar separados, indicando que el modelo ha logrado identificar correctamente a cada grupo. En este caso ambas distribuciones están solapadas, lo que indica justamente lo contrario: el modelo no está distinguiendo a los buenos de los malos pagadores.

Construcción del Scorecard

Alternativamente al método logit, existe una metodología utilizada particularmente en la industria financiera que enfatiza el uso del Weight on Evidence (WoE) y del Information Value (IV) como indicadores de la influencia o peso que tiene cada predictor sobre nuestro target o variable de impago.4

Al final, el objetivo es construir scorecards con puntajes específicos que produzcan un determinado score para el usuario pero, en vez de tener una probabilidad, se tenga un puntaje. Visto de otra manera, el objetivo sería transformar los resultados del modelo logit a puntajes.

La explicación que sigue se basa en la discusión que se encuentra en Siddiqi (2017). Se debe decir que la construcción y cálculo del IV o WoE se debe realizar durante el proceso de feature engineering realizado previamente, por tanto, no es un sustituto sino un complemento al análisis ya realizado.

Creando nuevamente el dataset:

data_sc <- dplyr::inner_join(target_30dpd_12m,application_record, by="ID")

data_sc$ID <- NULL
data_sc$INCOME_BIN <- NULL
data_sc$FLAG_MOBIL <- NULL

data_sc |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Weight on Evidence (WoE)

El primer paso para calcular ambos indicadores es agrupar las variables en “bins” o grupos que tengan algún sentido para el modelador. Se recomienda iniciar con 20 grupos y luego ir modificando en función a las métricas obtenidas. La función scorecard::woebin() realiza esta partición:

bins <- scorecard::woebin(data_sc,"mora",positive = "Yes|1")

## ✔ Binning on 27638 rows and 16 columns in 00:00:11

Por ejemplo, veamos los grupos que se formaron del ingreso de los individuos:

bins$AMT_INCOME_TOTAL |> 
         mutate_if(is.double, round, 4) |> 
    select(-variable,-breaks,-is_special_values,-total_iv,-bin_iv) |> 
    janitor::adorn_totals() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

En la tabla anterior hay bastante información. Nótese que la la columna pos se refiere al número de individuos que han estado en mora en los primeros 12 meses de haber obtenido la tarjeta en cada uno de los grupos. La columna posprob es la proporción de estos individuos considerando el total a los individuos de ese grupo, es decir count. El WoE se calcula como:

$$WoE = \ln\Big(\frac{\textit{Clase Positiva}}{\textit{Clase Negativa}}\Big)\times 100 $$

Se debe tomar en cuenta que la clase positiva es la clase que se desea predecir, en este caso el impago.

Por ejemplo, en el caso del grupo que va entre $[90.000,120.000)$:

$$\begin{aligned} WoE &= \ln\Big( \frac{\frac{217}{2914}}{\frac{1777}{24724}}\Big) \times 100 \\ &= \ln\Big(\frac{0.074}{0.072} \Big) \times 100 \\ß &= 0.35 \end{aligned}$$

Cuando el resultado es positivo indica que, para ese grupo, la proporción de individuos en la clase positiva es mayor que la proporción de los individuos en la clase negativa. Así, en este rango, hay más individuos morosos que los que no lo son.

Viendo el resumen gráfico:

bins$AMT_INCOME_TOTAL |> 
    ggplot(aes(x= bin, y = woe))+
    geom_bar(stat= "identity", color = "black", fill="steelblue")+
    theme_bw()

Nótese que en el gráfico anterior vemos que para los dos grupos de ingresos más bajos el WoE es positivo, lo que indica que la proporción de impagos en ese grupo es mayor a la proporción de individuos que pagan.

Lo que esperaríamos ver, sin embargo, es una tendencia negativa entre los grupos de ingreso más alto y el WoE, lo que indicaría que, a medida que el ingreso se incrementa, la proporción de individuos que son buenos pagadores se hace más grande en relación a la proporción de malos pagadores. Sin embargo, eso no ocurre en nuestro caso.³

Este análisis se debe realizar para todas las variables:

bins_df <- bind_rows(bins)

bins_df |> 
    select(variable, bin,woe) |> 
   ggplot(aes(x = bin, y=woe)) +
   geom_bar(stat= "identity", color= "black", fill="steelblue") +
   facet_wrap(~ variable, scales = "free_x")+
    theme_bw()+
    theme(axis.text.x = element_text(angle = 45))

Con esta información se debe buscar “arreglar” las variables que no tengan tanto sentido con diferentes grupos.

Information Value (IV)

El indicador IV muestra la fuerza total de la característica en función al target o variable de impago. Su uso proviene de la teoría de la información y se calcula como:

$$IV = \sum_{i=1}^{n} (\textit{Dist. Good}_{i} - \textit{Dist. Bad}_{i}) \times \ln\Big(\frac{\textit{Dist. Good}_{i}}{\textit{Dist. Bad}_{i}}\Big)$$

El criterio que se suele utilizar para ver la predictibilidad de cada variable es:

Sin embargo, cuando la característica tiene un $IV > 0.5$ se debe revisar cuidadosamente.

En el caso de nuestros datos el IV es:

infv <- scorecard::iv(data_sc, y = "mora", positive = "Yes|1") |> 
    as_tibble() 

infv |> 
    mutate_if(is.double, round, 3) |> 
    arrange(desc(info_value)) |> 
    kable(format="markdown") |>
    kable_styling("striped") 

Con esto datos vemos que las variables, en general, presentan poco poder predictivo.

Modelación

Inicialmente, debemos construir un conjunto de datos pero utilizando el valor del $WoE$ en vez del valor numérico de la variable:

data_woe <-  woebin_ply(data_sc, bins ) %>%
  as_tibble()

## ✔ Woe transformating on 27638 rows and 15 columns in 00:00:10

Los datos quedan como:

data_woe |> 
    head() |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Ahora, vamos a iniciar el proceso de modelaje nuevamente.

# Dividir los datos en train y test dataset
set.seed(1234)
trainIndex_woe <- createDataPartition(data_woe$mora, 
                                  p = .7, 
                                  list = FALSE, 
                                  times = 1)

trainData_woe <- data_woe[trainIndex_woe, ]
testData_woe <- data_woe[-trainIndex_woe, ]

# Crear un objeto para realizar 10-fold cv
cv_woe <- trainControl(method = "cv", number = 10, sampling = "smote")

# Entrenar el modelo con los datos woe
logistic_model_woe <- train(mora ~ ., 
                            data = trainData_woe, 
                            method = "glm",
                            family="binomial", 
                            trControl = cv_woe)

#Realizar las predicciones con un punto de corte de 0.5%
predictions_woe <- predict(logistic_model_woe, newdata=testData_woe, type="prob")
preds_woe <- ifelse(predictions_woe$Yes > 0.5,"Yes","No")


# Evaluar el modelo
draw_confusion_matrix(caret::confusionMatrix(data = factor(preds_woe, levels = c("Yes","No")), reference =testData_woe$mora, positive = "Yes"))

Que es ligeramente mejor que el modelo entrenando datos sin agrupar. El modelo es

model_summ_woe <- summary(logistic_model_woe)
model_summ_df_woe <- as.data.frame(model_summ_woe$coefficients)

Variable <- rownames(model_summ_df_woe)

rownames(model_summ_df_woe) <- NULL
model_summ_df_woe <- cbind(Variable,model_summ_df_woe) |> 
    mutate_if(is.double, round,2)

model_summ_df_woe |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Scorecard

El siguiente paso es construir el scorecard para el modelo. Para esto vamos a utilizar la librería scorecard. Sin embargo, vamos a volverlo a estimar con la librería glm por un tema de compatibilidad entre librerías:

set.seed(1234)
trainData_smote <- themis::smote(trainData_woe, "mora")

logistic_model_woe_glm <-  glm( mora ~ CODE_GENDER_woe + FLAG_OWN_CAR_woe + FLAG_OWN_REALTY_woe + 
    CNT_CHILDREN_woe + AMT_INCOME_TOTAL_woe + NAME_INCOME_TYPE_woe + 
    NAME_EDUCATION_TYPE_woe + NAME_FAMILY_STATUS_woe + NAME_HOUSING_TYPE_woe + 
    FLAG_WORK_PHONE_woe + FLAG_PHONE_woe + FLAG_EMAIL_woe + CNT_FAM_MEMBERS_woe + 
    YEARS_BIRTH_woe + YEARS_EMPLOYED_woe, data = trainData_smote, family = 'binomial')

Ahora, realizamos la predicción

resp_glm  <-  predict(logistic_model_woe_glm, type = 'response')

predictions_woe_glm <- predict(logistic_model_woe_glm, newdata=testData_woe, type="response")

preds_woe_glm <- ifelse(predictions_woe_glm> 0.5,"Yes","No")


# Evaluar el modelo
draw_confusion_matrix(caret::confusionMatrix(data = factor(preds_woe_glm, levels = c("Yes","No")), reference =testData_woe$mora, positive = "Yes"))

Que si bien no es igual al anterior por un tema de random sampling es bastante similar y ligeramente superior al modelo inicial.

Ahora vamos a reescalar el modelo para obtener el scorecard apuntando a un rango entre $300$ puntos y $850$ siendo $575$ puntos el punto donde hay $50\%$ de probabilidad de impago, según el modelo.

#1:1 significa 575

points0 = 850
odds0 = 1000
pdo = 27.59

card <-  scorecard::scorecard( bins ,logistic_model_woe_glm,
                               points0 = points0, 
                               odds0 =1/odds0, # el scorecard requiere la inversa
                               pdo = pdo)

sc <-  scorecard::scorecard_ply(data_sc, card)

predictions_sc <- data.frame(score= sc$score,Moroso =data_sc$mora)

predictions_sc |> 
    ggplot(aes(x= score, fill=Moroso))+
    geom_histogram(color = "black", bins =50)+
    scale_fill_manual(values=c("steelblue", "gray80"))+
    labs(x= "\nScore",
         y = "Frecuencia\n")+
    theme_bw()

Como se observa, el modelo todavía no tiene tanta capacidad predictiva pero permite asignar un puntaje a cada individuo del conjunto de datos.

¿Cómo quedaría el scorecard?

score_card <- bind_rows(card) |> 
    select(variable, bin, points) 

score_card |> 
    kable(format="markdown") |>
    kable_styling("striped") |>
    scroll_box(width = "100%") 

Por ejemplo, un individuo comienza con $575$ puntos, si es de sexo femenino ($CODE_GENDER = F$) suma $4$ puntos, si tiene un auto propio ($FLAG_OWN_CAR = Y$) gana otros $7$ puntos y así sucesivamente.

Si al final el nuevo solicitante acaba con más de $575$ puntos se le otorga la tarjeta de crédito.

Comentarios finales

Con este ejercicio se ha tratado de ilustrar de forma resumida el proceso de construcción de un scorecard para medir el riesgo de crédito. Aún cuando hay bastante espacio de mejora (análisis de outliers, mejor procesos de binning, reescalamiento y centrado de datos, probar con distintos modelos, etc.), se ha tratado de mantener el proceso lo más simple posible para ilustrar los distintos puntos:

1. La definición de impago en la construcción del target es fundamental para el análisis
2. La construcción de un scorecard es un proceso lento que requiere conocimiento experto y bastante información. La relación entre los datos no es necesariamente lineal por lo que la etapa de preprocesamiento es fundamental.