Problema

Modelos de score de crédito calculam a probabilidade de inadimplência e são uma das principais ferramentas utilizadas por diversas empresas para aprovar ou negar um crédito. O objetivo deste desafio é criar um modelo preditivo calculando a probabilidade de inadimplência de cada novo pedido de crédito.

A variável resposta é a coluna inadimplente, que indica se o tomador veio a se tornar inadimplente(1) ou não(0). As variáveis da base de dados são descritas abaixo:

  • idade: A idade do cliente.
  • numero_de_dependentes: O número de pessoas dependentes do cliente.
  • salario_mensal: Salário mensal do cliente.
  • numero_emprestimos_imobiliarios: Quantidade de empréstimos imobiliários que o cliente possui em aberto.
  • numero_vezes_passou_90_dias: Número de vezes que o tomador passou mais de 90 dias em atraso.
  • util_linhas_inseguras: Quanto que o cliente está usando, relativamente ao limite dele, de linhas de crédito que não são seguradas por qualquer bem do tomador e.g: imoveis, carros etc.
  • vezes_passou_de_30_59_dias: Número de vezes que o cliente atrasou, entre 30 e 59 dias, o pagamento de um empréstimo.
  • razao_debito: Razão entre as dívidas e o patrimônio do tomador. razão débito = Dividas/Patrimônio
  • numero_linhas_crdto_aberto: Número de empréstimos em aberto pelo cliente.
  • numero_de_vezes_que_passou_60_89_dias: Número de vezes que o cliente atrasou, entre 60 e 89 dias, o pagamento de um empréstimo.

Utilize este modelo para gerar as previsões na base teste.csv, inserindo uma nova coluna na tabela de dados do arquivo teste.csv que contenha as previsões e nomeie esta coluna com o nome “inadimplente”.

library(tidyverse)
library(tidymodels)
library(modelsummary)
library(GGally)
library(knitr)
library(kableExtra)
library(vip)
select <- dplyr::select

treino <- read.csv("treino.csv") %>% mutate(inadimplente = as.factor(inadimplente))
teste <- read.csv("teste.csv")

theme_set(theme_minimal())

treino %>% head() %>% 
  kbl() %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive")) %>%
  scroll_box(width = "800px")
inadimplente util_linhas_inseguras idade vezes_passou_de_30_59_dias razao_debito salario_mensal numero_linhas_crdto_aberto numero_vezes_passou_90_dias numero_emprestimos_imobiliarios numero_de_vezes_que_passou_60_89_dias numero_de_dependentes
1 0.7661266 45 2 0.8029821 9120 13 0 6 0 2
0 0.9571510 40 0 0.1218762 2600 4 0 0 0 1
0 0.6581801 38 1 0.0851134 3042 2 1 0 0 0
0 0.2338098 30 0 0.0360497 3300 5 0 0 0 0
0 0.9072394 49 1 0.0249257 63588 7 0 1 0 0
0 0.2131787 74 0 0.3756070 3500 3 0 1 0 1

Análise Descritiva

Ao avaliar a frequência das classes da variável resposta nota-se que se trata de um caso bastante desbalanceado, dessa forma, é interessante a aplicação de algumas técnicas para reverter essa situação.

treino %>% 
  mutate(inadimplente = as.factor(inadimplente)) %>% 
  group_by(inadimplente) %>%
  count() %>% ungroup() %>% 
  mutate(prop = round(n/sum(n), 3)) %>% 
  ggplot(aes(inadimplente, prop, fill = inadimplente)) + 
  geom_col(show.legend = F) + 
  geom_text(aes(label = prop), stat = "identity", nudge_y = 0.05) +
  labs(x = "Inadimplência", y = "Proporção")

A tabela a seguir possui informações sobre as covariáveis do banco de dados, e a partir dela é possível constatar algumas ideias:

  • A variável Salário tem uma proporção significativa de valores nulos, então uma forma de imputação desses valores será necessário;
  • Nenhuma variável possui desvio padrão igual a zero, logo, nenhuma variável será excluída do modelo por esse motivo;
  • A maioria das variáveis possui distribuição assimétrica;
datasummary_skim(treino)
Unique (#) Missing (%) Mean SD Min Median Max
util_linhas_inseguras 92671 0 5.9 252.3 0.0 0.2 50708.0
idade 86 0 52.3 14.8 0.0 52.0 109.0
vezes_passou_de_30_59_dias 15 0 0.4 4.2 0.0 0.0 98.0
razao_debito 86002 0 354.8 2074.1 0.0 0.4 329664.0
salario_mensal 12229 20 6637.4 13384.0 0.0 5400.0 3008750.0
numero_linhas_crdto_aberto 57 0 8.4 5.1 0.0 8.0 58.0
numero_vezes_passou_90_dias 18 0 0.3 4.2 0.0 0.0 98.0
numero_emprestimos_imobiliarios 28 0 1.0 1.1 0.0 1.0 54.0
numero_de_vezes_que_passou_60_89_dias 13 0 0.2 4.2 0.0 0.0 98.0
numero_de_dependentes 13 3 0.8 1.1 0.0 0.0 20.0

Para conferir possíveis correlações entre as covariáveis, a matriz de correlações será utilizada. A correlação de Spearman foi escolhida devido a assimetria apresentada pelos dados. Após analisar a matriz, a variável numero_emprestimos_imobiliarios possui as maiores correlações, com as variáveis numero_linhas_crdto_aberto, salario_mensal e razao_debito.

ggcorr(treino %>% select(-1), method = c("pairwise", "spearman"),
       label = T, hjust = 1, layout.exp = 6)

Agora, é possível conferir as medidas de tendência central para todas as variáveis numéricas de acordo com as classes da variável resposta, e assim verificar quais covariáveis receberam maior impacto com a variação entre as classes. Em decorrência da assimetria das variáveis, a média pode ser muito influenciada pelos valores extremos e por isso a mediana será considerada. As variáveis que tiveram maior variação entre as classes foram idade e salario_mensal. Também é comum que as variáveis apresentam desvio padrão maior para as pessoas inadimplentes, talvez por ter menos observações.

variaveis <- treino %>% select(-1) %>% names()
paste_var <- variaveis %>% paste(collapse = " + ")
formula <- as.formula(paste("(", paste_var, ") ~  inadimplente * ((`Média` = Mean) + (Mediana = Median) +(Des.Pad. = SD))"))

datasummary(formula, data = treino) %>%
    kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))
0
1
Média Mediana Des.Pad. Média Mediana Des.Pad.
util_linhas_inseguras 6.15 0.13 260.30 2.85 0.84 78.74
idade 52.71 52.00 14.78 45.94 45.00 13.00
vezes_passou_de_30_59_dias 0.28 0.00 3.00 2.40 0.00 11.81
razao_debito 358.44 0.36 2119.32 304.11 0.43 1283.13
salario_mensal 6711.24 5455.00 13755.72 5640.44 4500.00 6467.50
numero_linhas_crdto_aberto 8.49 8.00 5.10 7.88 7.00 5.66
numero_vezes_passou_90_dias 0.14 0.00 2.97 2.10 0.00 11.84
numero_emprestimos_imobiliarios 1.02 1.00 1.11 0.99 1.00 1.47
numero_de_vezes_que_passou_60_89_dias 0.13 0.00 2.96 1.84 0.00 11.83
numero_de_dependentes 0.74 0.00 1.11 0.94 0.00 1.21

Ajuste do Modelo

Para ajustar o modelo, foi realizada a divisão do banco de dados, respeitando a proporção de inadimplentes. Dado o volume de dados, optou-se por utilizar uma proporção igual a 90%, de forma que a fração de teste possui 11000 observações, quantidade suficiente para testar e permitindo que o ajuste utilize o máximo de informações. Como o modelo escolhido, Random Forest, possui hiperparâmetros para serem tunados, também será realizada a validação cruzada, com divisão de 5 folds.

set.seed(123)

treino_split <- initial_split(treino, strata = inadimplente, prop = 0.9)
treino_train <- training(treino_split)
treino_test <- testing(treino_split)

treino_folds <- vfold_cv(treino_train, strata = inadimplente , 5)

Os hiperparâmetros que serão tunados são: o número de preditores em cada árvore e o número mínimo de observações que cada nó para prosseguir com a classificação, os valores testados podem ser observados com o objeto grid. Para o ajuste do modelo, alguns passos foram adicionados a partir do que foi observado com a análise descritiva: a imputação de valores para as variáveis que possuem valores nulos e a retirada de variáveis que indicam combinação linear. E ao acionar o workflow para o ajuste do modelo e tunagem, optou-se por priorizar a detecção de pessoas inadimplentes.

mod <- rand_forest(mtry = tune(), # Número de preditores nas árvores;
                   trees = 1000,  # Número de árvores
                   min_n = tune()) %>%  # Número mínimo para prosseguir a árvore;
  set_engine("ranger", importance = "permutation") %>%
  set_mode("classification")

recipe <- recipe(inadimplente ~ . , data = treino_train) %>%
  step_impute_median(all_predictors()) %>% # Imputar valores faltantes;
  step_lincomb(all_predictors()) # Retira variáveis que são comb. lineares;

workflow <- workflow() %>%
  add_recipe(recipe) %>%
  add_model(mod)

grid <- expand.grid(mtry = c(3, 5, 7),
                    min_n =  c(30, 40, 50))


tune_rf <- tune_grid(workflow,
                     resamples = treino_folds,
                     grid = grid,
                     metrics = metric_set(specificity), # Foco em acertar casos fraudulentos;
                     control = control_grid(verbose = T))

show_best(tune_rf) %>% 
  kbl() %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))
mtry min_n .metric .estimator mean n std_err .config
3 50 recall binary 0.9916774 5 0.0003517 Preprocessor1_Model7
3 40 recall binary 0.9914214 5 0.0003145 Preprocessor1_Model4
3 30 recall binary 0.9911949 5 0.0003432 Preprocessor1_Model1
5 50 recall binary 0.9908016 5 0.0003021 Preprocessor1_Model8
5 40 recall binary 0.9903886 5 0.0003462 Preprocessor1_Model5

Resultados

Após o ajuste do modelo, é possível avaliar os resultados para o banco de teste e conferir a capacidade de generalização do modelo com novos dados. A princípio, a acurácia retornou um valor alto, porém deve ser resultado do grande desbalanceamento encontrado entre as classes.

workflow <-  finalize_workflow(workflow, select_best(tune_rf))

aplicacao_teste <- last_fit(workflow, treino_split)
aplicacao_teste %>% collect_metrics() %>% 
  kbl() %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))
.metric .estimator .estimate .config
accuracy binary 0.9360909 Preprocessor1_Model1
roc_auc binary 0.8459163 Preprocessor1_Model1

Aprofundando mais nos resultados, as matrizes de confusão a seguir indicam o percentual de acerto de acordo com as classes verdadeiras e apenas 16% dos inadimplentes foram detectados corretamente.

conf_mat_resampled(aplicacao_teste) %>% 
  group_by(Truth) %>% 
  mutate(Freq = round(Freq/sum(Freq),2)) %>% 
  ggplot(aes(x = Prediction, y = Truth, fill = Freq)) +
  geom_tile(color = "white") + 
  geom_text(aes(label = Freq)) +
  scale_fill_gradient2(low = "#ffffff", high = "#0c6964")

Em busca de reverter o resultado acima, o ponto de corte para classificar como inadimplente ou não foi alterado para a proporção inicial dos dados, com o intuito de aumentar o número de classificações com inadimplência. Nesse caso, 3/4 dos inadimplentes foram detectados, com o custo de uma parcela dos não-inadimplentes terem sido erroneamente classificados.

aplicacao_teste %>% collect_predictions() %>% 
  mutate(pred = ifelse(`.pred_1` >= 0.067, "1", "0")) %>% 
  group_by(inadimplente, pred) %>% 
  count() %>% group_by(inadimplente) %>% 
  mutate(prop = round(n/sum(n),2)) %>% 
  ggplot(aes(x = pred, y = inadimplente, fill = prop)) +
  geom_tile(color = "white") + 
  geom_text(aes(label = prop)) +
  scale_fill_gradient2(low = "#ffffff", high = "#0c6964")

Diminuindo mais o ponto de corte, quase todos os inadimplentes são detectados, porém mais da metade dos não-inadimplentes também é classificado, sendo a classe mais frequente, ao final os realmente inadimplentes seriam minoria entre os classificados, de forma que também não seria uma boa escolha.

aplicacao_teste %>% collect_predictions() %>% 
  mutate(pred = ifelse(`.pred_1` >= 0.01, "1", "0")) %>% 
  group_by(inadimplente, pred) %>% 
  count() %>% group_by(inadimplente) %>% 
  mutate(prop = round(n/sum(n),2)) %>% 
  ggplot(aes(x = pred, y = inadimplente, fill = prop)) +
  geom_tile(color = "white") + 
  geom_text(aes(label = prop)) +
  scale_fill_gradient2(low = "#ffffff", high = "#0c6964")

Também é possível avaliar o modelo ajustado conferindo a importância das variáveis. Nesse caso não foi muito coincidente com o esperado pela análise descritiva, em que as variáveis que pareciam sofrer maior impacto eram o salário e a idade.

aplicacao_teste %>%
  pluck(".workflow", 1) %>%
  pull_workflow_fit()  %>%
  vip(num_features = 20, aesthetics = list(fill = "#45BEC6"))

Novos dados

Agora, é possível finalizar o projeto e realizar a predição para o conjunto de dados final de teste e também conferir se a proporção das classificações segue um padrão razoável.

modelo_final <- workflow %>% fit(treino)
prob_predict <- predict(modelo_final, new_data = teste, type = "prob")$.pred_1

teste <- teste %>% 
  mutate(inadimplente = ifelse(prob_predict >= 0.067, "1", "0"))

teste %>% 
  group_by(inadimplente) %>% 
  count() %>% ungroup() %>% 
  mutate(prop = n /sum(n)) %>% 
  kbl() %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))
inadimplente n prop
0 30140 0.7535
1 9860 0.2465 
write.csv2(teste, "teste_predict.csv")

by Laura Alexandria de Oliveira