Objetivo
Desenvolver modelo de credit scoring com intuito de diminuir o nível de mau pagadores na base de clientes da mutual.
Tratamento da base
Para manipulação de dados irá ser utilizado a biblioteca dplyr, e para visualização será utilizado o ggplot2.
Leitura e tratamento da base
A base inicialmente conta com 40000 observações e 29 variáveis.
Exibir Dicionário das variáveis
| Variável | Significado |
|---|---|
| clientId | Key para o tomador |
| shopId | Key do empréstimo |
| gender | Gênero do tomador |
| maritalStatus | Estado civil do tomador |
| age | Idade do tomador |
| numberOfDependents | Quantidade de dependentes do tomador |
| education | Nível educacional do tomador |
| flagResidencialPhone | Flag se o tomador possui telefone residencial ou não |
| areaCodeResidencialPhone | Codigo de area do telefone residencial |
| bestPaymentDay | Melhor dia para pagamento do empréstimo |
| shopRank | Ranking do empréstimo |
| residenceType | Tipo de residência |
| monthsInResidence | Tempo vivendo na mesma residência |
| flagMothersName | Tomador registrou o nome da mãe na requisição de empréstimo |
| flagFathersName | Tomador registrou o nome do pai na requisição de empréstimo |
| flagResidenceTown_WorkingTown | Flag se o tomador vive na mesma cidade em que trabalha |
| flagResidenceState_WorkingState | Flag se o tomador vive no mesmo estado que trabalha |
| monthsInTheJob | Tempo no emprego atual |
| professionCode | Código de profissão do tomador |
| mateIncome | Renda do cônjuge do tomador |
| flagResidencialAddress_PostalAddress | Flag de validação do CEP do tomador |
| flagOtherCard | Se o tomador possui outros cartão de créditoIf the applicant possesses another credit or private label card |
| quantityBankingAccounts | Quantidade de contas bancárias do tomador |
| flagMobilePhone | Flag se o tomador possui telefone celular |
| flagContactPhone | Flag se o tomador possui um telefone de contato |
| personalNetIncome | Renda média líquida mensal do tomador |
| codeApplicationBooth | Código de onde a solicitação de empréstimo veio |
| BAD | Flag se o tomador veio atrasou o pagamento do empréstimo |
Observa-se que as variáveis quantitativas quantityBankingAccounts, codeApplicationBooth e numberOfDependents não apresentam variações, então serão removidas da análise.
Exibir Código
| Variável | Variação |
|---|---|
| quantityBankingAccounts | 0 |
| codeApplicationBooth | 0 |
| numberOfDependents | 0 |
As variáveis qualitativas flagMobilePhone, flagContactPhone e flagOtherCard apresentam somente a resposta “N”, logo também serão removidas.
Exibir Código
| Variável | Proporção de respostas N |
|---|---|
| flagMobilePhone | 1 |
| flagContactPhone | 1 |
| flagOtherCard | 1 |
De acordo com o dicionário, as variáveis X1, clientId, shopId são identificadores e a variável education não apresenta informação em nenhuma das linhas da base por isso serão removidas.
A próxima tabela mostra a quantidade de observações “NA” por variável.
Exibir Código
| X1 | clientId | shopId | gender | maritalStatus | age | numberOfDependents | education | flagResidencialPhone | areaCodeResidencialPhone | bestPaymentDay | shopRank | residenceType | monthsInResidence | flagMothersName | flagFathersName | flagResidenceTown_WorkingTown | flagResidenceState_WorkingState | monthsInTheJob | professionCode | mateIncome | flagResidencialAddress_PostalAddress | flagOtherCard | quantityBankingAccounts | flagMobilePhone | flagContactPhone | personalNetIncome | codeApplicationBooth | BAD |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 0 | 0 | 0 | 3 | 0 | 0 | 0 | 40000 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
Exibir Código
Além disso, as variáveis professionCode, shopRank e areaCodeResidencialPhone são representadas por números inteiros, porém possuem significados qualitativos. Serão convertidos as variáveis qualitavias para fatores.
Exibir Código
Após a limpeza da base dados, foi verificado que existem apenas 3 informações com dados faltantes. Como esse número é pequeno, iremos excluí-las da análise para evitar problemas na modelagem.
Exibir Código
| Linhas base Geral | Linhas base sem NA |
|---|---|
| 40000 | 39997 |
Observando as variáveis monthsInTheJob e monthsInResidence foi verificado a existência de indivíduos com anos de vida menores do que anos trabalhos ou anos na mesma residência. Para corrigir isso foram removidas essas observações.
Exibir Código
numeroLinhaAntes = nrow(base)
base = base %>%
mutate(olderThanMonthsInJob = monthsInTheJob / 12 < age) %>%
mutate(olderThanMonthsInResidence = monthsInResidence / 12 <= age)
base = base %>%
filter(olderThanMonthsInJob,
olderThanMonthsInResidence) %>%
select(-c(olderThanMonthsInJob,
olderThanMonthsInResidence))
numeroLinhaDepois = nrow(base)
knitr::kable(
tibble(
`Linhas antes correção` = numeroLinhaAntes,
`Linhas após correção` = numeroLinhaDepois
)
)| Linhas antes correção | Linhas após correção |
|---|---|
| 39997 | 39169 |
A tabela abaixo ilustra algumas medidas descritivas das variáveis quantitativas da base de dados tratada.
Exibir Código
numericosTabela = base %>%
select_if(is.numeric) %>%
.[, -7]
tabela = do.call(cbind, lapply(numericosTabela,function(x) {
if (sum(x) > 30000000)
summary(x, digits = 8)
else
summary(x, digits = 3)
})) %>%
as.data.frame() %>%
rbind(apply(numericosTabela, 2, function(x) {
round(sd(x), 3)
}))
row.names(tabela) = c(rownames(tabela)[1:6], "Sd")
tabela %>%
knitr::kable() %>%
kableExtra::scroll_box(width = "100%")| age | bestPaymentDay | monthsInResidence | monthsInTheJob | mateIncome | personalNetIncome | |
|---|---|---|---|---|---|---|
| Min. | 15.00 | 1.000 | 0.000 | 0.000 | 0.000 | 0.000 |
| 1st Qu. | 23.00 | 8.000 | 36.000 | 12.000 | 0.000 | 270.000 |
| Median | 33.00 | 12.000 | 120.000 | 24.000 | 0.000 | 401.000 |
| Mean | 34.80 | 15.300 | 149.000 | 50.800 | 51.900 | 9949.245 |
| 3rd Qu. | 43.00 | 20.000 | 240.000 | 60.000 | 0.000 | 746.000 |
| Max. | 88.00 | 28.000 | 900.000 | 708.000 | 70000.000 | 38529098.000 |
| Sd | 13.09 | 7.164 | 133.419 | 73.309 | 512.227 | 490756.232 |
A tabela abaixo mostra a quantidade de categorias para cada variável qualitativa do banco de dados que será utilizado.
Exibir Código
| gender | maritalStatus | flagResidencialPhone | areaCodeResidencialPhone | shopRank | residenceType | flagMothersName | flagFathersName | flagResidenceTown_WorkingTown | flagResidenceState_WorkingState | professionCode | flagResidencialAddress_PostalAddress | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Qtd Categorias | 2 | 5 | 2 | 59 | 3 | 4 | 2 | 2 | 2 | 2 | 291 | 2 |
Visualização
Exibir Código
base %>%
ggplot(aes(x = gender)) +
geom_bar(fill = "royalblue") +
geom_text(
aes(y = ..count.., label = ..count..),
stat = "count",
vjust = -0.5,
cex = 5
) +
labs(x = "Gênero",
y = "Frequencia",
title = "Frequência de gêneros") +
theme_minimal() +
scale_x_discrete(breaks = c("F", "M"),
labels = c("Feminino", "Masculino")) +
ylim(c(0,30000))
A quantidade de clientes mulheres é maior do que o dobro em relação aos homens.
Exibir Código
base %>%
mutate(maritalStatus = factor(maritalStatus,
c("S", "C", "O", "V", "D"))) %>%
ggplot(aes(x = maritalStatus)) +
geom_bar(fill = "royalblue") +
geom_text(
aes(y = ..count.., label = ..count..),
stat = "count",
vjust = -0.5,
cex = 5
) +
labs(x = "Estado civíl",
y = "Frequência",
title = "Frequência dos estados civis") +
theme_minimal() +
scale_x_discrete(
breaks = c("S", "C", "O", "V", "D"),
labels = c("Solteiro", "Casado", "Outro", "Viúvo", "Divorciado")
) +
ylim(c(0,28000))
O estado civil da maioria dos indivíduos da base de analise é composta por solteiros, sendo seguidos dos casados, outros, viúvos e divorciados, respectivamente.
Exibir Código
base %>%
mutate(ageCat = cut(age,
breaks = c(0, 20, 30, 40, 50, 60, 70, 80, 90))) %>%
ggplot(aes(x = ageCat)) +
geom_bar(fill = "royalblue",
col = "black") +
geom_text(
aes(y = ..count.., label = ..count..),
stat = "count",
vjust = -0.5,
cex = 5
) +
labs(x = "Intervalo de Idade",
y = "Frequência",
title = "Distribuição das idades") +
theme_minimal()+
ylim(c(0,15000))
A maior densidade das idades dos indivíduos se concentra entre 20 e 40 anos. A média da idade é 34.8 com desvio padrão de 13.1 enquanto a mediana é de 33 e moda de 20.
Exibir Código
base %>%
mutate(week = ceiling(bestPaymentDay / 7)) %>%
mutate(bestPaymentDay_fac = factor(bestPaymentDay,
levels = 1:28)) %>%
mutate(dayWeek = bestPaymentDay %% 7,
dayWeek = ifelse(dayWeek == 0,
7,
dayWeek)) %>%
group_by(week, dayWeek, bestPaymentDay_fac) %>%
summarise(frequencia = n(),
.groups = "drop") %>%
tidyr::complete(week,
tidyr::nesting(dayWeek),
fill = list(frequencia = 0)) %>%
arrange(week, dayWeek) %>%
mutate(bestPaymentDay_fac = 1:28) %>%
ggplot(aes(x = dayWeek, y = -week)) +
geom_tile(aes(fill = frequencia),
col = "black") +
geom_text(aes(label = bestPaymentDay_fac),
size = 5,
colour = "black") +
theme_void() +
labs(title = "Frequência das melhores datas de pagamento",
fill = "Frequência") +
scale_fill_distiller(direction = 2) +
coord_fixed()
O melhor dia de pagamento para a maioria dos clientes é o dia 12 com uma frequência de 10150 clientes, seguidos do dia 8 com frequência de 7206 e dia 18 com 6637 indivíduos. Outra observação importante é que os primeiros sete dias possuem baixa frequência de melhores dias de pagamento.
Exibir Código
options(scipen = 999)
salarioMinimo = 1045
base %>%
mutate(incomeCat = cut(
personalNetIncome,
breaks = c(
-1,
0,
1 * salarioMinimo,
2 * salarioMinimo,
3 * salarioMinimo,
4 * salarioMinimo,
max(personalNetIncome)
),
labels = c("0",
"(0,1]",
"(1,2]",
"(2,3]",
"(3,4]",
"4+")
)) %>%
ggplot(aes(x = incomeCat)) +
geom_bar(fill = "royalblue",
col = "black") +
geom_text(
aes(y = ..count.., label = ..count..),
stat = "count",
vjust = -0.5,
cex = 5
) +
labs(x = "Intervalo de salário mínimo",
y = "Frequência",
title = "Distribuição de renda em salários mínimos") +
theme_minimal()+
ylim(c(0,35000))
Para facilitar a interpretação dos dados foi utilizado o salário mínimo de 1045,00 Reais como referência, pois a base dados possui grande quantidade de outliers. Por exemplo o máximo de renda observado foi de 38.529.098,00, mas 99% dos clientes ganham até 3496,60 Reais. A grande maioria dos clientes recebem de 0 a 1 salário mínimo.
Exibir Código
base %>%
ggplot(aes(x = BAD)) +
geom_bar(fill = "royalblue") +
stat_bin(
aes(label = ..count..),
breaks = seq(-0.5, 1.5, 1),
binwidth = 3,
geom = "text",
color = "black",
vjust = -2
) +
stat_bin(
aes(label = paste0("(", round(
..count.. / sum(..count..) * 100, 1
), "%)")),
breaks = seq(-0.5, 1.5 , 1),
binwidth = 3,
geom = "text",
color = "black",
vjust = -0.5
) +
labs(x = "Atraso no pagamento",
y = "Frequencia",
title = "Atraso no pagamento do empréstimo") +
theme_minimal() +
scale_x_continuous(breaks = c(0, 1),
labels = c("Não", "Sim")) +
ylim(0, 35000)
A grande maioria dos clientes não atrasam no pagamento do empréstimo. Como essa é a variável resposta para a modelagem, esse desbalanceamento pode causar problemas para o ajuste do modelo classificador.
Exibir Código
base %>%
mutate(BAD = factor(BAD)) %>%
ggplot(aes(y = personalNetIncome,
x = BAD,
fill = factor(BAD))) +
geom_boxplot(outlier.shape = NA) +
coord_cartesian(ylim = c(0, 1 * salarioMinimo)) +
scale_x_discrete(breaks = c(0, 1),
labels = c("Não", "Sim")) +
labs(x = "Atraso no pagamento",
y = "Renda Pessoal",
title = "Atraso no pagamento do empréstimo X Renda pessoal") +
theme_minimal() +
theme(legend.position = "none")
Foi gerado gráfico boxplot para estudar a relação entre renda pessoal e atraso no pagamento. Nota-se que ambos apresentam mediana e primeiro quartil similares, porém aqueles que não atrasam o pagamento possuem maior variação na renda pessoal.
Obs: Foram removidos os outliers para melhor visualização.
Exibir Código
base %>%
mutate(BAD = factor(BAD)) %>%
ggplot(aes(
y = monthsInTheJob / 12,
x = BAD,
fill = factor(BAD)
)) +
geom_boxplot(outlier.shape = NA) +
coord_cartesian(ylim = c(0, 10)) +
scale_x_discrete(breaks = c(0, 1),
labels = c("Não", "Sim")) +
labs(x = "Atraso no pagamento",
y = "Tempo de trabalho em anos",
title = "Atraso no pagamento do empréstimo X Tempo de trabalho em anos") +
theme_minimal() +
theme(legend.position = "none")
Foi gerado gráfico boxplot para estudar a relação entre anos de trabalho e atraso no pagamento. Nota-se que a mediana daqueles indivíduos que não atrasaram no pagamento do empréstimo é 2 anos, enquanto aqueles que atrasaram é de apenas 1. O tempo de trabalhos em anos para aqueles que atrasaram no empréstimo está mais concentrado.
Obs: Foram removidos os outliers para melhor visualização.
Modelagem
Para fazer modelagem irá ser utilizado o pacote caret do R.
Será comparado o desempenho das seguintes técnicas de aprendizado de máquina: Decision Tree, KNN, Naive Bayes e GLM. Optou-se remover as variáveis professionCode e areaCodeResidencialPhone, pois elas possuem 291 e 59 fatores respectivamente, o que ocasionaria uma maior complexidade para a modelagem, gerando maior custo computacional.
base = base %>%
select(-c(professionCode,
areaCodeResidencialPhone)) %>%
mutate(BAD = as.factor(BAD))Para que os resultados desse relatório possam ser replicados será utilizado uma seed que será composta pelos números da data do dia.
Afim de mostrar que o problema de desbalanceamento da base irá prejudicar na modelagem, será ajustado um modelo utilizando a técnica de Decision Tree antes da correção desse problema.
Será utilizado a técnica de reamostragem repeatedcv com 10 folds e 3 repetições em todas as modelagens.
Modelagem por Decision Tree:
modelDecision = train(BAD ~ .,
method = "rpart",
trControl = ctrl_cv,
data = base)
predicaoDecision = predict(modelDecision, newdata = base)
confusionMatrix(predicaoDecision, base$BAD)## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 31484 7685
## 1 0 0
##
## Accuracy : 0.8038
## 95% CI : (0.7998, 0.8077)
## No Information Rate : 0.8038
## P-Value [Acc > NIR] : 0.5031
##
## Kappa : 0
##
## Mcnemar's Test P-Value : <0.0000000000000002
##
## Sensitivity : 1.0000
## Specificity : 0.0000
## Pos Pred Value : 0.8038
## Neg Pred Value : NaN
## Prevalence : 0.8038
## Detection Rate : 0.8038
## Detection Prevalence : 1.0000
## Balanced Accuracy : 0.5000
##
## 'Positive' Class : 0
## Apesar do modelo apresentar uma acurácia de 80%, ele está classificando todas as observações com BAD = 0 (cliente bom pagador) e ignorando aquelas com BAD = 1 (cliente mau pagador).
Afim de contornar este problema, será adotado a técnica de oversampling que tem como objetivo equilibrar a base de dados para gerar melhor resultado na modelagem. Para isso será sorteada aleatoriamente números de observações da categoria BAD = 1 até ficar com o mesmo número das com BAD = 0, assim balanceando a proporção da base.
Para treino do modelo será utilizado a base de tamanho 70% da original aplicando a técnica de oversampling. Para a base teste será utilizado os 30% restante da base original.
Index = createDataPartition(y = base$BAD,
p = 0.70,
list = F)
baseBalanceada = base[Index,]
teste = base[-Index,]
numClass1 = table(baseBalanceada$BAD)[[1]]
classe1 = baseBalanceada %>%
filter(BAD == 1) %>%
sample_n(numClass1, replace = T)
classe0 = baseBalanceada %>%
filter(BAD == 0)
baseBalanceada = rbind(classe0,
classe1)
baseBalanceada %>%
group_by(BAD) %>%
summarise(frequencia = n()) %>%
knitr::kable()| BAD | frequencia |
|---|---|
| 0 | 22039 |
| 1 | 22039 |
Modelando novamente por Decision Tree:
modelDecision = train(BAD ~ .,
method = "rpart",
trControl = ctrl_cv,
data = baseBalanceada)
predicaoDecision = predict(modelDecision, newdata = teste)
DECISION = confusionMatrix(predicaoDecision, teste$BAD); DECISION## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 4496 682
## 1 4949 1623
##
## Accuracy : 0.5208
## 95% CI : (0.5117, 0.5298)
## No Information Rate : 0.8038
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.106
##
## Mcnemar's Test P-Value : <0.0000000000000002
##
## Sensitivity : 0.4760
## Specificity : 0.7041
## Pos Pred Value : 0.8683
## Neg Pred Value : 0.2470
## Prevalence : 0.8038
## Detection Rate : 0.3826
## Detection Prevalence : 0.4407
## Balanced Accuracy : 0.5901
##
## 'Positive' Class : 0
## Modelando KNN:
modelKNN = train(BAD ~ .,
method = "knn",
trControl = ctrl_cv,
data = baseBalanceada)
predicaoKNN = predict(modelKNN, newdata = teste)
KNN = confusionMatrix(predicaoKNN, teste$BAD); KNN## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 4812 991
## 1 4633 1314
##
## Accuracy : 0.5214
## 95% CI : (0.5123, 0.5304)
## No Information Rate : 0.8038
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0498
##
## Mcnemar's Test P-Value : <0.0000000000000002
##
## Sensitivity : 0.5095
## Specificity : 0.5701
## Pos Pred Value : 0.8292
## Neg Pred Value : 0.2210
## Prevalence : 0.8038
## Detection Rate : 0.4095
## Detection Prevalence : 0.4939
## Balanced Accuracy : 0.5398
##
## 'Positive' Class : 0
## Modelando Naive Bayes:
modelNaive = train(BAD ~ .,
method = "nb",
trControl = ctrl_cv,
data = baseBalanceada)
predicaoNaive = predict(modelNaive, newdata = teste)
NAIVE = confusionMatrix(predicaoNaive, teste$BAD); NAIVE## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 2027 261
## 1 7418 2044
##
## Accuracy : 0.3465
## 95% CI : (0.3379, 0.3552)
## No Information Rate : 0.8038
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0466
##
## Mcnemar's Test P-Value : <0.0000000000000002
##
## Sensitivity : 0.2146
## Specificity : 0.8868
## Pos Pred Value : 0.8859
## Neg Pred Value : 0.2160
## Prevalence : 0.8038
## Detection Rate : 0.1725
## Detection Prevalence : 0.1947
## Balanced Accuracy : 0.5507
##
## 'Positive' Class : 0
## Modelando GLM:
modelGLM = train(BAD ~ .,
method = "glm",
trControl = ctrl_cv,
data = baseBalanceada)
predicaoGLM = predict(modelGLM, newdata = teste)
GLM = confusionMatrix(predicaoGLM, teste$BAD); GLM## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 5481 835
## 1 3964 1470
##
## Accuracy : 0.5916
## 95% CI : (0.5826, 0.6005)
## No Information Rate : 0.8038
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.1441
##
## Mcnemar's Test P-Value : <0.0000000000000002
##
## Sensitivity : 0.5803
## Specificity : 0.6377
## Pos Pred Value : 0.8678
## Neg Pred Value : 0.2705
## Prevalence : 0.8038
## Detection Rate : 0.4665
## Detection Prevalence : 0.5375
## Balanced Accuracy : 0.6090
##
## 'Positive' Class : 0
## O gráfico a seguir representa o tempo de execução dos modelos:
Exibir Código
tibble(
Tempo = c(
modelKNN$times[[1]][[3]],
modelNaive$times[[1]][[3]],
modelGLM$times[[1]][[3]],
modelDecision$times[[1]][[3]]
),
Modelos = factor(
c("KNN",
"Naive Bayes",
"GLM",
"Decision Tree")
,
levels = c("KNN",
"Naive Bayes",
"GLM",
"Decision Tree")
)
) %>%
ggplot(aes(x = Modelos, y = Tempo)) +
geom_bar(fill = "royalblue",
stat = "identity") +
labs(x = "Modelos",
y = "Tempo(s)",
title = "Tempo em segundo do treinamento dos modelos") +
theme_minimal() +
geom_text(aes(y = Tempo, label = round(Tempo, 3)),
vjust = -0.5,
cex = 5) +
ylim(c(0, 400))
Os tempos de execução dos modelos de GLM e Decision Tree são discrepantes em relação aos de KNN e Naive Bayes.
A tabela a seguir resume o desempenho dos modelos testados:
Exibir Código
tibble(Modelos = c("Decision Tree",
"KNN",
"Naive Bayes",
"GLM"),
Sensibilidade = c(DECISION$byClass[[1]],
KNN$byClass[[1]],
NAIVE$byClass[[1]],
GLM$byClass[[1]]),
Especificidade = c(DECISION$byClass[[2]],
KNN$byClass[[2]],
NAIVE$byClass[[2]],
GLM$byClass[[2]]),
Acurácia = c(DECISION$overall[[1]],
KNN$overall[[1]],
NAIVE$overall[[1]],
GLM$overall[[1]])) %>%
arrange(desc(`Acurácia`)) %>%
knitr::kable()| Modelos | Sensibilidade | Especificidade | Acurácia |
|---|---|---|---|
| GLM | 0.5803070 | 0.6377440 | 0.5915745 |
| KNN | 0.5094759 | 0.5700651 | 0.5213617 |
| Decision Tree | 0.4760191 | 0.7041215 | 0.5207660 |
| Naive Bayes | 0.2146109 | 0.8867679 | 0.3464681 |
Retomando o objetivo do estudo: Desenvolver modelo de credit scoring com intuito de diminuir o nível de mau pagadores na base de clientes da mutual.
Para isso, é importante definir o significado das métricas presentes na tabela. A sensibilidade é a proporção dos clientes bom pagadores que foram classificados como bom pagadores; A especificidade é a proporção dos clientes mau pagadores que foram classificados como mau pagadores; A acurácia é a proporção dos acertos em geral.
Comparando os modelos, o de Decision Tree apresentou uma boa métrica de especificidade, porém apresentou um baixo valor para sensibilidade, mas mais aceitável do que o Naive Bayes. Caso seja mais importante identificar um mau pagador, levando em consideração o risco de classificar bom pagadores de forma errada, o modelo Decision Tree mostrou bom resultado.
O modelo de GLM apresentou a melhor acurácia dos testados, com uma proporção de 58% de sensiblidade e 63% de especificidade. O GLM mostrou ser um modelo mais equilibrado, ideal para problemas em que a importância de identificar um mau pagador é a mesmo do que um bom pagador.
Uma outra maneira de avaliar um classificador é utilizando a curva ROC. Pode-se observar a curva ROC dos modelos de Decision Tree e GLM nos gráficos a seguir.
Exibir Código
predicaoD = predict(modelDecision, teste, type = 'prob')[, 2]
predicaoG = predict(modelGLM, teste, type = 'prob')[, 2]
roc_graph = function(prediction, obs, titulo){
prediction = ROCR::prediction(prediction, obs)
performance = ROCR::performance(prediction, "tpr", "fpr")
auc = ROCR::performance(prediction, measure = "auc")@y.values[[1]]
fx = attr(performance, "y.values")[[1]] - (attr(performance, "x.values")[[1]])
df = data.frame(xvalues = performance@x.values[[1]],
yvalues = performance@y.values[[1]],
alpha_ = performance@alpha.values[[1]])
print(
df %>%
ggplot(aes(x = xvalues, y = yvalues)) +
geom_line(size = 2, col = "royalblue") +
geom_abline(slope=1, alpha = 0.5) +
geom_text(x = .75, y = .15, label = paste("AUC =", round(auc,3)), size = 10) +
scale_color_gradient(low="blue",
high="green",
breaks=c(0, .25, .5, .75, 1),
limits=c(0,1)) +
coord_cartesian(clip = 'off') +
ylab('Verdadeiro Positivo (Sensibilidade)')+
xlab('Falso Positivo (1 - Especificidade)')+
ggtitle(titulo)
)
}
roc_graph(predicaoD, teste$BAD, "ROC Decision Tree")
roc_graph(predicaoG, teste$BAD, "ROC GLM")
A curva ROC ilustra a relação entre a proporção de verdadeiros positivos e falsos positivos, calculadas em diferentes pontos de corte a partir das probabilidades geradas por um modelo para as classificações. AUC é a métrica que cálcula a área sobre a curva ROC, em geral, modelos de classificação procuram maximizar essa métrica.
Apesar dos resultados mostrados, é possível gerar modelos mais robustos que podem apresentar melhor performance utilizando técnicas mais complexas como por exemplo: Bayesian network, Neural network, Support vector machine, entre outras. Porém a complexidade e o custo computacional podem aumentar significativamente.