O objetivo deste projeto é dizer qual a probabilidade de um cliente passar com sucesso para análise de crédito dado que ele foi pré-aprovado para o empréstimo com garantia de automóvel.
Neste estudo de caso, vamos tentar discutir algumas maneiras de prever a chance de um cliente específico, que quer candidatar-se a um empréstimo, será padrão em seus pagamentos (ou não).
Em primeiro lugar, "prever" algo é uma expressão realmente estranha, não é? É provável que as pessoas comuns liguem a "previsão" com o relatório meteorológico diário - e todos sabemos que esse tipo de previsão não é confiável o tempo todo.
Então, por que fazer o esforço tentar olhar para o futuro para estimar a probabilidade de inadimplência? Por que os bancos simplesmente não dão a alguém que precise de algum dinheiro sabendo que eles não podem fazer nada para reduzir os mal devedores?
É claro que não é assim que isso funciona - a maneira mais intuitiva (e ainda muito popular) é que um oficial de empréstimo qualificado e experiente faça o melhor para decidir se um candidato é aprovado - ou não.
A carga do dataset no formato csv deve passar por uma transformação inicial quanto a coluna bi_lead_id simplesmente por simples inconsistência quanto a coerção. Transformamos em caractere.
df <- read.csv("data/auto_refi_loan_data.csv",encoding = "UTF-8", stringsAsFactors = FALSE)
head(df[,1:6])## X bi_lead_id age monthly_income collateral_value loan_amount
## 1 1 1.00001e+11 61 1300 NA 10000
## 2 2 1.73466e+05 50 3500 40000 23936
## 3 3 1.73465e+05 31 2600 18000 5000
## 4 4 1.73464e+05 51 3600 21000 10000
## 5 5 1.73463e+05 51 1500 10000 8000
## 6 6 1.73462e+05 25 4000 39000 10000
Estrutura do Dataset
A coluna de descrição foi truncada para melhor visualização
structure <- read.csv("data/dataset_description.csv", header = FALSE, col.names = c("coluna","descricao"),encoding = "UTF-8")
structure$descricao <- strtrim(structure$descricao,width = 45)
structure## coluna descricao
## 1 bi_lead_id Chave única de uma solicitação de cliente
## 2 age Idade do cliente
## 3 monthly_income Renda mensal informada pelo cliente no moment
## 4 collateral_value Valor do automóvel que será dado em garantia
## 5 loan_amount Valor solicitado pelo cliente para empréstimo
## 6 city Cidade do cliente
## 7 state Estado do cliente
## 8 collateral_debt_amount Valor que o automovel do cliente tem de dívid
## 9 serasa_restriction Indica se o cliente possui alguma pendência n
## 10 serasa_dishonored_checks Indica se o cliente possui cheques sem fundo
## 11 serasa_expired_debts Indica se o cliente possui dívidas vencidas (
## 12 serasa_banking_debts Indica se o cliente possui divídas bancárias
## 13 serasa_commercial_debts Indica se o cliente possui dividas comerciais
## 14 serasa_protests Indica se o cliente possui protestos (dado da
## 15 marital_status Estado civil
## 16 cpf_restriction Restrição no cpf (informado pelo cliente)
## 17 loan_term Prazo do empréstimo
## 18 monthly_payment Pagamento mensal do empréstimo
## 19 purpose Motivo pelo qual o cliente deseja o empréstim
## 20 auto_brand Marca do carro
## 21 auto_model Modelo do carro
## 22 auto_model_year Ano do carro
## 23 covered_lead Lead pré-aprovado (apenas leads pré-aprovados
## 24 form_completed Ficha cadastral completa pelo cliente
## 25 sent_to_analysis Enviado para análise de crédito
## 26 discard_reason Motivo de descarte de um lead (leads pré-apro
## 27 channel Canal de entrada do lead
## 28 created_at_safra Data de criação do lead
## 29 zip_code CEP do cliente
## 30 landing_page Página inicial que o cliente acessou no site
## 31 landing_page_product Produto da página inicial do cliente
## 32 gender Gênero do cliente
## 33 education_level Grau de instrução do cliente
## 34 utm_term Tipo de dispositivo do cliente (c = computer,
Algumas ações são necessárias, como por exemplo, a limpeza e transformação de algumas variáveis categóricas para inteiros ou numéricas de ponto flutuante. Também excluimos todas as observações cujo valor da variáel covered_lead seja igual a zero e os formulários incompletos.
library(gmodels)
df$bi_lead_id <- as.character(df$bi_lead_id) # adequando a variável (transofrmação)
ndf <- subset(df,covered_lead != "0")
ndf <- subset(ndf,form_completed != "0")
## trocando valores não disponíveis por zero nas colunas
## collateral_debt_amount e monthly_payment
ndf[is.na(ndf)] <- 0A coluna purpose é uma string com muitas váriações, o ideal é que o dado tivesse sido padronizado em sua coleta, já que isso aconteceu via portal na Internet. Vamos tentar melhorar com alguns ajustes. Vamos olhar um pequeno exemplo:
ndf$purpose[20:30]## [1] "NEGOCIAR DIVIDAS" "Quitar dívidas"
## [3] "para pagar contas" "Pagar dívidas "
## [5] "quitar dividas" "Pagar dividas"
## [7] "Quitar empréstimo bancário " "Para fins de saúde."
## [9] "Pagamento de dividas" "Terminar a minha lanchonete "
## [11] "PAGAMENTO DÍVIDAS "
quitar dividas é um bom exemplo, vamos retirar os espaços duplos ou maiores, deixar todo o texto em caixa baixa e remover toda a pontuação do texto. Vamos remover as acentuações, já que alguns clientes colocam e outros não.
ndf$purpose <- as.factor(tolower(ndf$purpose))
ndf$purpose <- gsub("^ *|(?<= ) | *$", "", ndf$purpose, perl = TRUE)
rm_accent <- function(str,pattern="all") {
# rm.accent - REMOVE ACENTOS DE PALAVRAS
# Função que tira todos os acentos e pontuações de um vetor de strings.
# Parâmetros:
# str - vetor de strings que terão seus acentos retirados.
# patterns - vetor de strings com um ou mais elementos indicando quais acentos deverão ser retirados.
# Para indicar quais acentos deverão ser retirados, um vetor com os símbolos deverão ser passados.
# Exemplo: pattern = c("´", "^") retirará os acentos agudos e circunflexos apenas.
# Outras palavras aceitas: "all" (retira todos os acentos, que são "´", "`", "^", "~", "¨", "ç")
if(!is.character(str))
str <- as.character(str)
pattern <- unique(pattern)
if(any(pattern=="Ç"))
pattern[pattern=="Ç"] <- "ç"
symbols <- c(
acute = "áéíóúÁÉÍÓÚýÝ",
grave = "àèìòùÀÈÌÒÙ",
circunflex = "âêîôûÂÊÎÔÛ",
tilde = "ãõÃÕñÑ",
umlaut = "äëïöüÄËÏÖÜÿ",
cedil = "çÇ"
)
nudeSymbols <- c(
acute = "aeiouAEIOUyY",
grave = "aeiouAEIOU",
circunflex = "aeiouAEIOU",
tilde = "aoAOnN",
umlaut = "aeiouAEIOUy",
cedil = "cC"
)
accentTypes <- c("´","`","^","~","¨","ç")
if(any(c("all","al","a","todos","t","to","tod","todo")%in%pattern)) # opcao retirar todos
return(chartr(paste(symbols, collapse=""), paste(nudeSymbols, collapse=""), str))
for(i in which(accentTypes%in%pattern))
str <- chartr(symbols[i],nudeSymbols[i], str)
return(str)
}
ndf$purpose <- rm_accent(ndf$purpose)
ndf$purpose[20:30]## [1] "negociar dividas" "quitar dividas"
## [3] "para pagar contas" "pagar dividas"
## [5] "quitar dividas" "pagar dividas"
## [7] "quitar emprestimo bancario" "para fins de saude."
## [9] "pagamento de dividas" "terminar a minha lanchonete"
## [11] "pagamento dividas"
Agora podemos transformar essa coluna em numérica devido aos seus nívels (fatores). O mesmo para outras variáveis.
ndf$purpose <- as.factor(ndf$purpose)
ndf$purpose <- as.integer(unclass(ndf$purpose))
ndf$education_level <- as.factor(ndf$education_level)
ndf$education_level <- as.integer(unclass(ndf$education_level))
# transformando marital_status
ndf$marital_status <- as.integer(ndf$marital_status)Vamos então retirar algumas colunas para um novo dataset para o processamento, como por exemplo a cidade onde o cliente mora, esses valores não interferem no resultado final.
credit <- ndf
credit[,c(1,2,7,8,18,21:25,27:33,35,36)] <- NULL
ndf[is.na(ndf)] <- 0
dim(credit)[1]## [1] 4172
#remove(ndf)summary(credit[,c(1:5,14:16,17)])## age monthly_income collateral_value loan_amount
## Min. : 18.00 Min. : 800 Min. : 27 Min. : 2500
## 1st Qu.: 30.00 1st Qu.: 2800 1st Qu.: 18000 1st Qu.: 7000
## Median : 37.00 Median : 4000 Median : 24000 Median : 12310
## Mean : 38.84 Mean : 14541 Mean : 53686 Mean : 15550
## 3rd Qu.: 46.00 3rd Qu.: 6700 3rd Qu.: 34000 3rd Qu.: 20000
## Max. :115.00 Max. :11000000 Max. :27000000 Max. :288000
## collateral_debt_amount monthly_payment purpose
## Min. : 0 Min. : 0.0 Min. : 1.0
## 1st Qu.: 0 1st Qu.: 365.9 1st Qu.: 609.8
## Median : 0 Median : 580.6 Median :1105.0
## Mean : 4880 Mean : 725.6 Mean :1188.9
## 3rd Qu.: 10 3rd Qu.: 891.1 3rd Qu.:1888.2
## Max. :10100000 Max. :12000.0 Max. :2471.0
## sent_to_analysis education_level
## Min. :0.00 Min. : 1.00
## 1st Qu.:0.00 1st Qu.: 7.00
## Median :0.00 Median : 8.00
## Mean :0.36 Mean : 7.34
## 3rd Qu.:1.00 3rd Qu.:10.00
## Max. :1.00 Max. :12.00
Nesta fase vamos apenas entender se existe valores do tipo outliers. Não vamos avaliar as medidas de tendência central da coluna sent_to_analysis. Observando os valores acima é fácil perceber que alguns clientes digitaram informações aparentemente inconsistentes, como por exemplo, o monthly_payment. Valores zero e outros muito acima da média, o que podemos considerar outliers. O mesmo vale para a idade. O mesmo ocorre com loan_term, vamos retirar esses valores faltantes.
Normalizando as variáveis
A solução abaixo permite escalar apenas nomes de variáveis específicas, preservando outras variáveis inalteradas (e os nomes das variáveis podem ser gerados dinamicamente), mas optamos aqui por seu indice específico.
standValue <- function(x){(x-min(x))/(max(x)-min(x))}
credit$monthly_income <- standValue(credit$monthly_income)
credit$collateral_value <- standValue(credit$collateral_value)
credit$loan_amount <- standValue(credit$loan_amount)
credit$collateral_debt_amount <- standValue(credit$collateral_debt_amount)
credit$monthly_payment <- standValue(credit$monthly_payment)
credit$purpose <- standValue(credit$purpose)
credit$age <- standValue(credit$age)
credit$education_level <- standValue(credit$education_level)
credit$monthly_payment <- standValue(credit$monthly_payment)
summary(credit[,c(1:5,14:16,17)])## age monthly_income collateral_value
## Min. :0.0000 Min. :0.0000000 Min. :0.0000000
## 1st Qu.:0.1237 1st Qu.:0.0001818 1st Qu.:0.0006657
## Median :0.1959 Median :0.0002909 Median :0.0008879
## Mean :0.2148 Mean :0.0012493 Mean :0.0019874
## 3rd Qu.:0.2887 3rd Qu.:0.0005364 3rd Qu.:0.0012583
## Max. :1.0000 Max. :1.0000000 Max. :1.0000000
## loan_amount collateral_debt_amount monthly_payment
## Min. :0.00000 Min. :0.0000000 Min. :0.00000
## 1st Qu.:0.01576 1st Qu.:0.0000000 1st Qu.:0.03049
## Median :0.03436 Median :0.0000000 Median :0.04838
## Mean :0.04571 Mean :0.0004832 Mean :0.06046
## 3rd Qu.:0.06130 3rd Qu.:0.0000010 3rd Qu.:0.07426
## Max. :1.00000 Max. :1.0000000 Max. :1.00000
## purpose sent_to_analysis education_level
## Min. :0.0000 Min. :0.00 Min. :0.0000
## 1st Qu.:0.2465 1st Qu.:0.00 1st Qu.:0.5455
## Median :0.4470 Median :0.00 Median :0.6364
## Mean :0.4809 Mean :0.36 Mean :0.5764
## 3rd Qu.:0.7641 3rd Qu.:1.00 3rd Qu.:0.8182
## Max. :1.0000 Max. :1.00 Max. :1.0000
Agora com os dados normalizados passamos para a próxima fase.
Agora vamos identificar os clientes que já foram enviados para análise de crédito. Esses clientes serão usados para testar o modelo.
dim(subset(credit,credit$sent_to_analysis > 0))[1]## [1] 1502
Observa-se que apenas 4172 clientes que não tem restrições no Serasa, sendo que desses 1502 ainda não foram enviados para a análise de crédito.
Registros sem valores de Pagamento mensal do empréstimo são retirados.
monthly_payment
head(credit[order(credit$monthly_payment,decreasing = TRUE),c(1:4)])## age monthly_income collateral_value loan_amount
## 2816 0.2371134 0.003563896 0.0166656881 1.0000000
## 11054 0.2577320 0.009018838 0.0062953074 0.5271454
## 8632 0.3505155 0.002427449 0.0079619757 0.6690018
## 22595 0.3092784 0.001745581 0.0021841922 0.1772329
## 25826 0.2268041 0.000381846 0.0009249317 0.0262697
## 34693 0.2989691 0.001745581 0.0030568597 0.1663748
credit <- subset(credit,credit$monthly_payment != 0)head(credit[order(credit$collateral_value,decreasing = TRUE),c(1:4)])## age monthly_income collateral_value loan_amount
## 33736 0.24742268 1.701033e-04 1.0000000 0.026269702
## 5507 0.05154639 2.909302e-04 0.9074073 0.026269702
## 22443 0.14432990 3.636628e-05 0.6666663 0.008756567
## 27610 0.19587629 2.909302e-04 0.6111107 0.008756567
## 2907 0.23711340 1.090988e-04 0.5926197 0.015761821
## 27593 0.43298969 8.364245e-04 0.2111103 0.230784799
Os valores acima ordenados por collateral_value mostram que o valor máximo é um outlier. o gráfico de dispersão confirma essa suspeita. Devemos observa que o segundo item da lista foi enviado para análise de crédito, então não podemos considerá-lo como outlier.
Comparando todas as variáveis com e sem os outliers
boxplot(credit[,c(2:5,14:15)])
boxplot(credit[,c(2:5,14:15)],outline = FALSE)
par(mfrow = c(1,5))
plot(credit$age, ylab = structure[2,2], xlab = "Clientes")
plot(credit$collateral_value, ylab = structure[4,2], xlab = "Clientes")
plot(credit$collateral_debt_amount, ylab = structure[8,2], xlab = "Clientes")
plot(credit$monthly_payment, ylab = structure[18,2], xlab = "Clientes")
plot(credit$monthly_income, ylab = structure[3,2], xlab = "Clientes")
Apesar dos valores estarem longe dos demais, há coerência entre collateral_valuee monthly_income, pois os valores são muito distante dos demais.
Vamos então retirar todos os outliers para verificar o seu comportamento, mas antes vamos fazer uma cópia dos nossos dados.
## Função para remover outliers
remove_outliers <- function(x, na.rm = TRUE, ...) {
qnt <- quantile(x, probs=c(.25, .75), na.rm = na.rm, ...)
H <- 1.5 * IQR(x, na.rm = na.rm)
y <- x
y[x < (qnt[1] - H)] <- NA
y[x > (qnt[2] + H)] <- NA
y
}
credit2 <- credit
credit$collateral_value <- remove_outliers(credit$collateral_value)
credit$collateral_debt_amount <- remove_outliers(credit$collateral_debt_amount)
credit$monthly_payment <- remove_outliers(credit$monthly_payment)
credit$monthly_income <- remove_outliers(credit$monthly_income)
par(mfrow = c(1,5))
plot(credit$age, ylab = structure[2,2], xlab = "Clientes")
plot(credit$collateral_value, ylab = structure[4,2], xlab = "Clientes")
plot(credit$collateral_debt_amount, ylab = structure[8,2], xlab = "Clientes")
plot(credit$monthly_payment, ylab = structure[18,2], xlab = "Clientes")
plot(credit$monthly_income, ylab = structure[3,2], xlab = "Clientes")
credit <- credit2
remove(credit2)Agora temos uma dispersão sem outliers, mas isso é apenas para demonstrar, pois não vamos retirar esses valores de nosso modelo.
head(credit[order(credit$monthly_income,decreasing = TRUE),c(1:4)],10)## age monthly_income collateral_value loan_amount
## 3322 0.04123711 1.0000000 0.0005545609 0.038528897
## 10677 0.39175258 0.5737872 0.0004434497 0.029071804
## 22362 0.36082474 0.4872354 0.0009249317 0.070052539
## 2053 0.28865979 0.3817732 0.0004434497 0.029071804
## 29190 0.23711340 0.2272165 0.0012212283 0.095271454
## 33164 0.17525773 0.1635755 0.0005545609 0.026269702
## 33538 0.34020619 0.1635755 0.0008693761 0.008756567
## 28685 0.11340206 0.1363008 0.0016286361 0.129947461
## 28712 0.02061856 0.1181179 0.0009249317 0.008756567
## 15446 0.09278351 0.1090261 0.0002582643 0.008756567
O terceiro item da tabela acima já enviado para análise, então não vamos considerar esses elementos distantes como outliers.
Agora temos nosso banco de dados e nós sabemos como parece.
O primeiro passo é criar nosso conjunto de dados de treinamento e nosso conjunto de dados de teste. O conjunto de teste é usado para avaliar a precisão do modelo.
Vamos criar vários modelos, por isso é necessário dar-lhes designações numéricas (1, 2, 3, etc.). Podemos quebrar os conjuntos de dados em todos os tamanhos que desejamos, até 50-50, mas aqui usamos uma divisão de um terço e dois terços, pois é o mais recomendado pela literatura.
Nesta fase, realizaremos uma regressão logística usando a função glm(). Começamos com o conjunto de práticas, i_calibration1. Aqui, seremos seletivos com as variáveis que usamos no modelo. Vamos mudar isso um pouco, mas, por enquanto, usaremos apenas cinco para determinar o valor da credibilidade.
OBS: retiramos do modelo a variável e marital_status e education_level, essa variável deixa o modelo instável e uma predição a partir de um ajuste rank-deficient pode ser enganoso.
credit[is.na(credit)] <- 0
i_test1 <- sort(sample(1:nrow(credit), size = dim(credit)[1]*.7))
i_calibration1 <- (1:nrow(credit))[-i_test1]
set.seed(1)
LogisticModel.1 <- glm(sent_to_analysis ~ . -marital_status -education_level,
family = poisson(link = "log"),data = credit[i_calibration1, ])Com isso, podemos avançar para ajustar o modelo que acabamos de criar para o conjunto de testes, i_test1, e nos preparar para fazer nossa primeira previsão.
fitLog1 <- predict(LogisticModel.1, type = 'response', newdata = credit[i_test1, ])Nós montamos nosso modelo. Agora, usaremos o pacote ROCR para criar previsões e medir o desempenho em termos de área sob a curva (AUC). Quanto maior a medida da AUC, melhor será o nosso modelo.
library(ROCR)
pred1 <- prediction(fitLog1, credit$sent_to_analysis[i_test1])
perf1 <- performance(pred1, 'tpr', 'fpr')
plot(perf1,colorize=TRUE,print.cutoffs.at=seq(0,1,by=0.1), text.adj=c(-0.2,1.7))
E iremos envolver esta parte ao encontrar a AUC.
AUCLog1 <- performance(pred1, measure = 'auc')@y.values[[1]]
AUCLog1## [1] 0.7453075
Esse não é um resultado ruim, mas vamos ver se podemos fazer melhor com um método diferente.
Em seguida, vamos tentar analisar os dados usando uma abordagem de árvore de regressão. Grande parte do nosso código é semelhante ao que foi usado nos modelos de logística acima, mas precisamos fazer alguns ajustes.
Observe novamente que estamos analisando todas as variáveis em nosso modelo para encontrar seu impacto em nossa variável de interesse, credibilidade (sent_to_analysis).
O pacote rparté usado para Árvores de particionamento e regressão recursivas. Completando os recursos necessário, o pacote rpart.plotserá usado para plotar o gráfico.
Temporáriamente a coluna sent_to_analysisserá transofmrada em categórica, pois a biblioteca rpart usa dessa forma.
library(rpart)
set.seed(1)
credit$sent_to_analysis <- as.factor(credit$sent_to_analysis)
TreeModel <- rpart(sent_to_analysis ~ ., data = credit[i_calibration1, ])
library(rpart.plot)
prp(TreeModel, type = 2, extra = 1)
fitTree <- predict(TreeModel, newdata = credit[i_test1, ], type = 'prob')[, 2]
pred3 <- prediction(fitTree, credit$sent_to_analysis[i_test1])
perf3 <- performance(pred3, 'tpr', 'fpr')
plot(perf3,colorize=TRUE,print.cutoffs.at=seq(0,1,by=0.1), text.adj=c(-0.2,1.7))
AUCTree <- performance(pred3, measure = 'auc')@y.values[[1]]
AUCTree## [1] 0.7196146
O resultado foi pior do que o anterior. E ambos não são resultados satisfatórios, dada a complexidade do nosso modelo de árvore, então, novamente, temos que nos perguntar se não estamos melhor usando o modelo de Regressão Logística mais simples do primeiro modelo.
Em vez de construir uma árvore de decisão, podemos usar o método Random Forest para criar uma "floresta" metafóra de árvores de decisão. Neste método, o resultado final é o modo das classes (se trabalharmos em um modelo de classificação) ou a média das previsões (se estiver trabalhando com regressões).
A idéia por trás da floresta aleatória é que as árvores de decisão são propensas a superação, então encontrar a árvore "média" na floresta pode ajudar a evitar esse problema.
library(randomForest)
set.seed(1)
RF <- randomForest(sent_to_analysis ~ . , data = credit[i_calibration1, ])
fitForest1 <- predict(RF, newdata = credit[i_test1, ], type = 'prob')[, 2]
pred4 <- prediction(fitForest1, credit$sent_to_analysis[i_test1])
perf4 <- performance(pred4, 'tpr', 'fpr')
plot(perf4,colorize=TRUE,print.cutoffs.at=seq(0,1,by=0.1), text.adj=c(-0.2,1.7))
Agora vamos avaliar o desempenho
AUCRF <- performance(pred4, measure = 'auc')@y.values[[1]]
AUCRF## [1] 0.7462712
Com o esforço extra, ainda assim não obtemos um resultado um tanto melhorado. O modelo de Regressão logística é o melhor desempenho até o momento.
Analisamos vários resultados usando dois métodos básicos de análise - regressões logísticas e árvores de decisão. Verificamos apenas resultados individuais expressos como AUC.
A abordagem da floresta aleatória exige que criemos uma floresta de árvores de decisão e assumimos o modo ou a média. Por que não fazer uso de todos esses dados? Como eles se parecem?
O código a seguir cria um gráfico que representa centenas de combinações de pontuações AUC para cada árvore em nossa floresta aleatória e para modelos logísticos.
Primeiro precisamos de uma função para realizar a análise.
OBS: para esse modelo vamos deixar todas as variáveis no modelo.
AUC <- function(i){
set.seed(i)
i_test2 <<- sample(1:nrow(credit), size = dim(credit)[1]*.7)
i_calibration2 <<- (1:nrow(credit))[-i_test2]
# vamos criar esse modelo no ambiente global, pois vamos usa-lo mais na frente
LogisticModel.3 <<- glm(sent_to_analysis ~ ., family = binomial, data = credit[i_calibration2, ])
summary(LogisticModel.3)
fitLog3 <- predict(LogisticModel.3, type = 'response', newdata = credit[i_test2, ])
library(ROCR)
pred5 <- prediction(fitLog3, credit$sent_to_analysis[i_test2])
AUCLog3 <- performance(pred5, measure = 'auc')@y.values[[1]]
RF <- randomForest(sent_to_analysis ~ ., data = credit[i_calibration2, ])
fitForest2 <- predict(RF, newdata = credit[i_test2, ], type = 'prob')[, 2]
pred6 <- prediction(fitForest2, credit$sent_to_analysis[i_test2])
AUCRF <- performance(pred6, measure = 'auc')@y.values[[1]]
return(c(AUCLog3, AUCRF))
}Esta parte do código leva um tempo para ser executado porque estamos tabulando e gravando centenas de resultados individuais. Você pode ajustar o número de resultados no modelo alterando a contagem no objeto VAUC. Aqui, escolhemos calcular 100 x-y pares, ou 200 resultados individuais.
Normalmente markdown não é usado para relatórios longos ou demorados, mas para essa demanda o processo foi realizado aqui mesmo.
VAUC <- Vectorize(AUC)(1:200)
plot(t(VAUC), xlab = 'Logistic', ylab = 'Random Forest')
É possível verificar que os resultados que temos dos primeiros quatro modelos estão bem no meio da distribuição.
Isso confirma para nós os modelos são bastante comparáveis. O melhor que podemos esperar é uma AUC de 0,77 e a maioria nos dá resultados semelhantes ao que já calculamos.
Mas vamos tentar visualizar um pouco melhor. Um par de pacotes R pode ser usado para melhorar a representação gráfica dos resultados. Isso nos mostrará exatamente onde o conjunto de resultados mais provável reside.
Primeiro, precisamos converter nosso objeto VAUC em um Data Frame.
AA <- as.data.frame(t(VAUC))Vamos usar as bibliotecas ggplot2 e hdrcde para criar alguns gráficos. O primeiro é um gráfico de contorno de densidade.
library(ggplot2)
data(AA, package = 'MASS')
ggplot(AA, aes(x = V1, y = V2)) + geom_point() + geom_density2d() + xlab('Logistic') + ylab('Random Forest')
O segundo é um gráfico de contorno de alta densidade que nos dá as regiões de probabilidade para os dados.
library("hdrcde")
par(mar = c(3.1, 4.1, 1.1, 2.1))
with(AA, hdr.boxplot.2d(V1, V2, show.points = TRUE, prob = c(.01, .05, .5, .75), xlab = 'Logistic', ylab = 'Random Forest'))
De qualquer maneira que descrevemos nossos resultados, temos que usar os dados para tomar uma decisão de empréstimo, há um problema aqui?
Estas podem ser as melhores pontuações que podemos encontrar com esses modelos, mas os resultados são aceitáveis para determinar o mérito do credor? Isso depende dos padrões de crédito utilizados pela instituição de crédito.
Na melhor das hipóteses, parece que nossos modelos nos dão 82% de chance de emprestar a bons riscos de crédito. Por cada R$ 1 milhão em empréstimos, na melhor das hipóteses, podemos esperar que seja reembolsado R$ 820.000. Em média, esperamos recuperar cerca de R$ 780 mil em principal. Em outras palavras, de acordo com nossa análise, há entre 75% e 80% de chance de recuperar nosso empréstimo de US R$ 1 milhão, dependendo do método de modelagem que usamos.
À medida que adicionamos candidatos de empréstimo a nossas bases de dados, gostaríamos que eles se agrupassem na área mais escura do gráfico de alta densidade se considerarmos bons riscos de crédito.
A menos que cobramos muito interesse para cobrir nossas perdas, talvez precisemos de melhores modelos.
Como há muitas possíveis variáveis para o modelo, podemos proceder com a abordagem de Stepwise para selecionar o modelo com a "melhor" combinação de variáveis explicativas:
O critério de informação Akaike (AIC) é uma medida da qualidade relativa dos modelos estatísticos para um dado conjunto de dados. Dada uma coleção de modelos para os dados, AIC estima a qualidade de cada modelo, em relação a cada um dos outros modelos. Assim, a AIC fornece um meio para a seleção do modelo.
O AIC é baseado na teoria da informação: oferece uma estimativa relativa da informação perdida quando um determinado modelo é usado para representar o processo que gera os dados. Ao fazê-lo, trata-se do trade-off entre a bondade do ajuste do modelo e a complexidade do modelo.
O Critério de Informação de Akaike (AIC) é definido como
AICp = −2log(Lp)+2[(p + 1)+1]
em que Lp é a função de máxima verossimilhança do modelo e p é o número de variáveis explicativas consideradas no modelo.
O Critério de Informação Bayesiano (BIC) é definido como
BICp = −2log(Lp)+[(p + 1)+1]log(n)
Tanto o AIC quanto o BIC aumentam conforme SQE aumenta. Além disso, ambos critérios penalizam modelos com muitas variáveis sendo que valores menores de AIC e BIC são preferíveis.
Como modelos com mais variáveis tendem a produzir menor SQE mas usam mais parâmetros, a melhor escolha é balancear o ajuste com a quantidade de variáveis.
Criando outro modelo para teste
Mais uma vez vamos usar todas as variáveis no modelo.
#Índices obtidos após a aleatorização
ordena <- sort(sample(nrow(credit), size = dim(credit)[1]*.7))
#Dados para o treinamento
treinamento<-credit[ordena,]
#Dados para a validação
validacao<-credit[-ordena,]
#Regressão Logística
modelo.completo <- glm(sent_to_analysis ~ . ,family=binomial,data=treinamento)Vamos fazer isso com o melhor modelo, mas antes temos que voltar aos dados originais (nao normalizados), pois estamos em busca de sucesso ou fracasso, então a distribuição típica é Poison.
Vamos usar a biblioteca MASS para calcular intervalos de confiança a partir de modelos de regressão logística.
library("MASS")
stepwise <- stepAIC(modelo.completo,direction="both")## Start: AIC=3172.63
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + serasa_protests + marital_status +
## cpf_restriction + monthly_payment + purpose + education_level
##
##
## Step: AIC=3172.63
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + serasa_protests + cpf_restriction +
## monthly_payment + purpose + education_level
##
## Df Deviance AIC
## - serasa_protests 1 3140.7 3170.7
## - loan_amount 1 3140.9 3170.9
## - education_level 1 3140.9 3170.9
## - purpose 1 3141.1 3171.1
## - collateral_value 1 3141.1 3171.1
## - monthly_income 1 3141.3 3171.3
## - serasa_expired_debts 1 3141.4 3171.4
## <none> 3140.6 3172.6
## - serasa_restriction 1 3144.5 3174.5
## - serasa_commercial_debts 1 3144.7 3174.7
## - age 1 3149.8 3179.8
## - serasa_dishonored_checks 1 3153.2 3183.2
## - serasa_banking_debts 1 3158.5 3188.5
## - cpf_restriction 1 3159.5 3189.5
## - monthly_payment 1 3167.7 3197.7
## - collateral_debt_amount 1 3394.3 3424.3
##
## Step: AIC=3170.75
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + cpf_restriction + monthly_payment +
## purpose + education_level
##
## Df Deviance AIC
## - loan_amount 1 3141.0 3169.0
## - education_level 1 3141.1 3169.1
## - collateral_value 1 3141.2 3169.2
## - purpose 1 3141.3 3169.3
## - monthly_income 1 3141.4 3169.4
## - serasa_expired_debts 1 3141.5 3169.5
## <none> 3140.7 3170.7
## + serasa_protests 1 3140.6 3172.6
## - serasa_restriction 1 3144.8 3172.8
## - serasa_commercial_debts 1 3145.5 3173.5
## - age 1 3149.9 3177.9
## - serasa_dishonored_checks 1 3153.2 3181.2
## - serasa_banking_debts 1 3159.4 3187.4
## - cpf_restriction 1 3159.5 3187.5
## - monthly_payment 1 3167.9 3195.9
## - collateral_debt_amount 1 3394.4 3422.4
##
## Step: AIC=3169
## sent_to_analysis ~ age + monthly_income + collateral_value +
## collateral_debt_amount + serasa_restriction + serasa_dishonored_checks +
## serasa_expired_debts + serasa_banking_debts + serasa_commercial_debts +
## cpf_restriction + monthly_payment + purpose + education_level
##
## Df Deviance AIC
## - education_level 1 3141.3 3167.3
## - collateral_value 1 3141.5 3167.5
## - purpose 1 3141.5 3167.5
## - monthly_income 1 3141.6 3167.6
## - serasa_expired_debts 1 3141.8 3167.8
## <none> 3141.0 3169.0
## + loan_amount 1 3140.7 3170.7
## + serasa_protests 1 3140.9 3170.9
## - serasa_restriction 1 3145.1 3171.1
## - serasa_commercial_debts 1 3145.8 3171.8
## - age 1 3150.9 3176.9
## - serasa_dishonored_checks 1 3153.6 3179.6
## - serasa_banking_debts 1 3159.5 3185.5
## - cpf_restriction 1 3159.8 3185.8
## - monthly_payment 1 3244.5 3270.5
## - collateral_debt_amount 1 3395.2 3421.2
##
## Step: AIC=3167.31
## sent_to_analysis ~ age + monthly_income + collateral_value +
## collateral_debt_amount + serasa_restriction + serasa_dishonored_checks +
## serasa_expired_debts + serasa_banking_debts + serasa_commercial_debts +
## cpf_restriction + monthly_payment + purpose
##
## Df Deviance AIC
## - collateral_value 1 3141.8 3165.8
## - purpose 1 3141.8 3165.8
## - monthly_income 1 3141.9 3165.9
## - serasa_expired_debts 1 3142.1 3166.1
## <none> 3141.3 3167.3
## + education_level 1 3141.0 3169.0
## + loan_amount 1 3141.1 3169.1
## + serasa_protests 1 3141.2 3169.2
## - serasa_restriction 1 3145.3 3169.3
## - serasa_commercial_debts 1 3146.1 3170.1
## - age 1 3150.9 3174.9
## - serasa_dishonored_checks 1 3154.0 3178.0
## - serasa_banking_debts 1 3159.8 3183.8
## - cpf_restriction 1 3160.0 3184.0
## - monthly_payment 1 3244.9 3268.9
## - collateral_debt_amount 1 3395.2 3419.2
##
## Step: AIC=3165.8
## sent_to_analysis ~ age + monthly_income + collateral_debt_amount +
## serasa_restriction + serasa_dishonored_checks + serasa_expired_debts +
## serasa_banking_debts + serasa_commercial_debts + cpf_restriction +
## monthly_payment + purpose
##
## Df Deviance AIC
## - purpose 1 3142.3 3164.3
## - monthly_income 1 3142.4 3164.4
## - serasa_expired_debts 1 3142.6 3164.6
## <none> 3141.8 3165.8
## + collateral_value 1 3141.3 3167.3
## + education_level 1 3141.5 3167.5
## + loan_amount 1 3141.5 3167.5
## + serasa_protests 1 3141.7 3167.7
## - serasa_restriction 1 3145.8 3167.8
## - serasa_commercial_debts 1 3146.6 3168.6
## - age 1 3151.3 3173.3
## - serasa_dishonored_checks 1 3154.5 3176.5
## - serasa_banking_debts 1 3160.4 3182.4
## - cpf_restriction 1 3160.6 3182.6
## - monthly_payment 1 3245.3 3267.3
## - collateral_debt_amount 1 3395.8 3417.8
##
## Step: AIC=3164.31
## sent_to_analysis ~ age + monthly_income + collateral_debt_amount +
## serasa_restriction + serasa_dishonored_checks + serasa_expired_debts +
## serasa_banking_debts + serasa_commercial_debts + cpf_restriction +
## monthly_payment
##
## Df Deviance AIC
## - monthly_income 1 3142.9 3162.9
## - serasa_expired_debts 1 3143.1 3163.1
## <none> 3142.3 3164.3
## + purpose 1 3141.8 3165.8
## + collateral_value 1 3141.8 3165.8
## + education_level 1 3142.0 3166.0
## + loan_amount 1 3142.0 3166.0
## + serasa_protests 1 3142.2 3166.2
## - serasa_restriction 1 3146.3 3166.3
## - serasa_commercial_debts 1 3147.1 3167.1
## - age 1 3151.7 3171.7
## - serasa_dishonored_checks 1 3155.0 3175.0
## - serasa_banking_debts 1 3160.9 3180.9
## - cpf_restriction 1 3161.6 3181.6
## - monthly_payment 1 3246.9 3266.9
## - collateral_debt_amount 1 3397.9 3417.9
##
## Step: AIC=3162.93
## sent_to_analysis ~ age + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + cpf_restriction + monthly_payment
##
## Df Deviance AIC
## - serasa_expired_debts 1 3143.7 3161.7
## <none> 3142.9 3162.9
## + monthly_income 1 3142.3 3164.3
## + purpose 1 3142.4 3164.4
## + collateral_value 1 3142.4 3164.4
## + education_level 1 3142.7 3164.7
## + loan_amount 1 3142.7 3164.7
## + serasa_protests 1 3142.8 3164.8
## - serasa_restriction 1 3146.9 3164.9
## - serasa_commercial_debts 1 3147.7 3165.7
## - age 1 3152.2 3170.2
## - serasa_dishonored_checks 1 3155.6 3173.6
## - serasa_banking_debts 1 3161.7 3179.7
## - cpf_restriction 1 3162.1 3180.1
## - monthly_payment 1 3247.3 3265.3
## - collateral_debt_amount 1 3398.5 3416.5
##
## Step: AIC=3161.74
## sent_to_analysis ~ age + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_banking_debts + serasa_commercial_debts +
## cpf_restriction + monthly_payment
##
## Df Deviance AIC
## <none> 3143.7 3161.7
## + serasa_expired_debts 1 3142.9 3162.9
## + monthly_income 1 3143.1 3163.1
## + purpose 1 3143.2 3163.2
## + collateral_value 1 3143.2 3163.2
## + education_level 1 3143.4 3163.4
## + loan_amount 1 3143.5 3163.5
## + serasa_protests 1 3143.6 3163.6
## - serasa_restriction 1 3148.1 3164.1
## - serasa_commercial_debts 1 3148.4 3164.4
## - age 1 3153.0 3169.0
## - serasa_dishonored_checks 1 3156.5 3172.5
## - cpf_restriction 1 3162.8 3178.8
## - serasa_banking_debts 1 3162.9 3178.9
## - monthly_payment 1 3248.2 3264.2
## - collateral_debt_amount 1 3399.4 3415.4
Após algumas iterações, observa-se que o conjunto de variáveis com o menor valor para o Critério de Informação de Akaike é:
summary(stepwise)##
## Call:
## glm(formula = sent_to_analysis ~ age + collateral_debt_amount +
## serasa_restriction + serasa_dishonored_checks + serasa_banking_debts +
## serasa_commercial_debts + cpf_restriction + monthly_payment,
## family = binomial, data = treinamento)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.4671 -0.9941 -0.3335 1.1293 3.8970
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.9627 0.1090 -8.830 < 2e-16 ***
## age 1.0748 0.3533 3.042 0.002348 **
## collateral_debt_amount -2409.9410 260.4229 -9.254 < 2e-16 ***
## serasa_restriction -0.5764 0.2830 -2.037 0.041649 *
## serasa_dishonored_checks -13.9045 213.1950 -0.065 0.947999
## serasa_banking_debts -1.9907 0.5538 -3.594 0.000325 ***
## serasa_commercial_debts -0.7851 0.3687 -2.129 0.033225 *
## cpf_restriction -0.6890 0.1630 -4.228 2.36e-05 ***
## monthly_payment 10.6721 1.1350 9.403 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 3792.6 on 2910 degrees of freedom
## Residual deviance: 3143.7 on 2902 degrees of freedom
## AIC: 3161.7
##
## Number of Fisher Scoring iterations: 15
Percebemos que nem todas as variáveis são significativas. Podemos excluir do modelo serasa_dishonored_checks, serasa_dishonored_checks e todas as outras com p-value maior que 0.05.
Uma medida interessante para interpretar o modelo é a medida de Razão de chances (Odds Ratio) que calcula a razão de chances.
Em estatística, o odds ratio (OR) é uma das três principais maneiras de quantificar a intensidade da presença ou ausência da propriedade A associada à presença ou ausência da propriedade B em uma determinada população.
exp(cbind(OR = coef(stepwise), confint(stepwise)))## OR 2.5 % 97.5 %
## (Intercept) 3.818733e-01 3.080031e-01 4.722848e-01
## age 2.929528e+00 1.466464e+00 5.860944e+00
## collateral_debt_amount 0.000000e+00 0.000000e+00 0.000000e+00
## serasa_restriction 5.618986e-01 3.176688e-01 9.669771e-01
## serasa_dishonored_checks 9.148112e-07 7.471407e-91 7.449736e-81
## serasa_banking_debts 1.365930e-01 3.925038e-02 3.630650e-01
## serasa_commercial_debts 4.560555e-01 2.181745e-01 9.323106e-01
## cpf_restriction 5.020791e-01 3.625569e-01 6.874718e-01
## monthly_payment 4.313701e+04 4.833683e+03 4.134821e+05
A ideia agora é construir o(s) modelo(s) de Credit Scoring com o DataFrame "credit" e em seguida avaliar o ajuste com o DataFrame "validacao".
#Abordagem Stepwise para seleção de variáveis
#Faz a previsão para a base de validação (probabilidade)
predito <- predict(stepwise,validacao,type="response")
#Escolhe quem vai ser "1" e quem vai ser "0"
predito <- ifelse(predito>=0.8,1,0)
#Compara os resultados
table(predito,validacao$sent_to_analysis)##
## predito 0 1
## 0 784 446
## 1 4 14
A taxa de acerto é:
## [1] 0.6394231
Podemos melhorar a taxa de acerto refinando o modelo por meio da exclusão de variáveis não significantes e pela inclusão de componentes estatisticamente significantes.
logLik(modelo.completo)## 'log Lik.' -1570.315 (df=16)
logLik(LogisticModel.1)## 'log Lik.' -803.5719 (df=15)
logLik(LogisticModel.3)## 'log Lik.' -681.4784 (df=16)
Então temos o valor do modelo que sabemos que é o correto de −1582.51, enquanto o modelo mais simples sem as variáveis education_level e marital_status (e errado) foi de -796.70. O modelo, também completo, vemos então que quanto melhor o ajuste (e teoricamente melhor o modelo) temos um valor maior de logLik.
extractAIC(modelo.completo)## [1] 16.00 3172.63
extractAIC(LogisticModel.1)## [1] 15.000 1637.144
extractAIC(LogisticModel.3)## [1] 16.000 1394.957
Agora o modelo 1, com 2 parâmetros a menos tem um valor mais alto de 3197 enquanto o modelo 3 (que sabemos que é o correto) tem um parâmetro e o valor de 1623 de AIC, mas o modelo completo tem o menor valor, então valores menores devem ser bons. Somos inclinados a usar o modelo completo que tem os 2 parâmetros, intercepto e inclinação.
Mas podemos ainda fazer um teste F, vendo a razão entre os logLik para saber se os modelos são diferentes.
anova(LogisticModel.1,LogisticModel.3)## Analysis of Deviance Table
##
## Model 1: sent_to_analysis ~ (age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + serasa_protests + marital_status +
## cpf_restriction + monthly_payment + purpose + education_level) -
## marital_status - education_level
## Model 2: sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + serasa_protests + marital_status +
## cpf_restriction + monthly_payment + purpose + education_level
## Resid. Df Resid. Dev Df Deviance
## 1 1233 687.14
## 2 1232 1362.96 1 -675.81
Existem diferenças entre os modelos, então ficamos com aquele com mais parâmetros, o modelo 1, o mais complexo, não podemos abandonar ele pelo mais simples, ja que ele explica muita coisa que o modelo 2 mais simples não deu conta de explicar, mas não podemos esquecer que:
Podemos ainda fazer isso usando o comando ste**p(), que vai pegar o modelo inicial que você fornecer, e se você mandar ele simplificar com o argumento direction = ”backwar**d”, ele vai tirando um por um dos parâmetros, e ve se o modelo fica diferente, se continuar explicando bem os dados, ele descarta esse parâmetro, so deixar o trace = 1 para ver o processo, como o modelo mais complexo aqui, o modelo 1, ele faz isso quantas vezes for o núemro de variáveis menos um.
Então temos:
ps(trace=1 e nesse caso o direction=”backward” são os default da função)
mod.final3 <- step(LogisticModel.3)## Start: AIC=1394.96
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + serasa_protests + marital_status +
## cpf_restriction + monthly_payment + purpose + education_level
##
##
## Step: AIC=1394.96
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + serasa_protests + cpf_restriction +
## monthly_payment + purpose + education_level
##
## Df Deviance AIC
## - education_level 1 1363.0 1393.0
## - serasa_protests 1 1363.0 1393.0
## - serasa_commercial_debts 1 1363.0 1393.0
## - purpose 1 1363.1 1393.1
## - monthly_income 1 1363.1 1393.1
## - collateral_value 1 1364.1 1394.1
## - serasa_expired_debts 1 1364.2 1394.2
## <none> 1363.0 1395.0
## - loan_amount 1 1365.8 1395.8
## - serasa_restriction 1 1366.1 1396.1
## - serasa_banking_debts 1 1367.2 1397.2
## - serasa_dishonored_checks 1 1368.4 1398.4
## - age 1 1370.7 1400.7
## - monthly_payment 1 1379.4 1409.4
## - cpf_restriction 1 1383.9 1413.9
## - collateral_debt_amount 1 1484.5 1514.5
##
## Step: AIC=1392.96
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + serasa_protests + cpf_restriction +
## monthly_payment + purpose
##
## Df Deviance AIC
## - serasa_protests 1 1363.0 1391.0
## - serasa_commercial_debts 1 1363.0 1391.0
## - purpose 1 1363.1 1391.1
## - monthly_income 1 1363.1 1391.1
## - collateral_value 1 1364.1 1392.1
## - serasa_expired_debts 1 1364.2 1392.2
## <none> 1363.0 1393.0
## - loan_amount 1 1365.8 1393.8
## - serasa_restriction 1 1366.1 1394.1
## - serasa_banking_debts 1 1367.2 1395.2
## - serasa_dishonored_checks 1 1368.4 1396.4
## - age 1 1370.7 1398.7
## - monthly_payment 1 1379.5 1407.5
## - cpf_restriction 1 1383.9 1411.9
## - collateral_debt_amount 1 1484.6 1512.6
##
## Step: AIC=1390.96
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## serasa_commercial_debts + cpf_restriction + monthly_payment +
## purpose
##
## Df Deviance AIC
## - serasa_commercial_debts 1 1363.0 1389.0
## - purpose 1 1363.1 1389.1
## - monthly_income 1 1363.1 1389.1
## - collateral_value 1 1364.1 1390.1
## - serasa_expired_debts 1 1364.2 1390.2
## <none> 1363.0 1391.0
## - loan_amount 1 1365.8 1391.8
## - serasa_restriction 1 1367.1 1393.1
## - serasa_banking_debts 1 1367.2 1393.2
## - serasa_dishonored_checks 1 1368.6 1394.6
## - age 1 1370.7 1396.7
## - monthly_payment 1 1379.5 1405.5
## - cpf_restriction 1 1384.0 1410.0
## - collateral_debt_amount 1 1484.7 1510.7
##
## Step: AIC=1388.96
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## cpf_restriction + monthly_payment + purpose
##
## Df Deviance AIC
## - purpose 1 1363.1 1387.1
## - monthly_income 1 1363.1 1387.1
## - collateral_value 1 1364.1 1388.1
## - serasa_expired_debts 1 1364.3 1388.3
## <none> 1363.0 1389.0
## - loan_amount 1 1365.8 1389.8
## - serasa_banking_debts 1 1367.4 1391.4
## - serasa_dishonored_checks 1 1368.6 1392.6
## - age 1 1370.8 1394.8
## - serasa_restriction 1 1371.4 1395.4
## - monthly_payment 1 1379.5 1403.5
## - cpf_restriction 1 1384.1 1408.1
## - collateral_debt_amount 1 1484.7 1508.7
##
## Step: AIC=1387.09
## sent_to_analysis ~ age + monthly_income + collateral_value +
## loan_amount + collateral_debt_amount + serasa_restriction +
## serasa_dishonored_checks + serasa_expired_debts + serasa_banking_debts +
## cpf_restriction + monthly_payment
##
## Df Deviance AIC
## - monthly_income 1 1363.2 1385.2
## - collateral_value 1 1364.2 1386.2
## - serasa_expired_debts 1 1364.4 1386.4
## <none> 1363.1 1387.1
## - loan_amount 1 1365.9 1387.9
## - serasa_banking_debts 1 1367.5 1389.5
## - serasa_dishonored_checks 1 1368.8 1390.8
## - age 1 1370.9 1392.9
## - serasa_restriction 1 1371.7 1393.7
## - monthly_payment 1 1379.6 1401.6
## - cpf_restriction 1 1384.1 1406.1
## - collateral_debt_amount 1 1484.7 1506.7
##
## Step: AIC=1385.24
## sent_to_analysis ~ age + collateral_value + loan_amount + collateral_debt_amount +
## serasa_restriction + serasa_dishonored_checks + serasa_expired_debts +
## serasa_banking_debts + cpf_restriction + monthly_payment
##
## Df Deviance AIC
## - collateral_value 1 1364.4 1384.4
## - serasa_expired_debts 1 1364.5 1384.5
## <none> 1363.2 1385.2
## - loan_amount 1 1366.1 1386.1
## - serasa_banking_debts 1 1367.5 1387.5
## - serasa_dishonored_checks 1 1369.0 1389.0
## - age 1 1371.1 1391.1
## - serasa_restriction 1 1371.8 1391.8
## - monthly_payment 1 1380.0 1400.0
## - cpf_restriction 1 1384.2 1404.2
## - collateral_debt_amount 1 1485.0 1505.0
##
## Step: AIC=1384.39
## sent_to_analysis ~ age + loan_amount + collateral_debt_amount +
## serasa_restriction + serasa_dishonored_checks + serasa_expired_debts +
## serasa_banking_debts + cpf_restriction + monthly_payment
##
## Df Deviance AIC
## - serasa_expired_debts 1 1365.7 1383.7
## <none> 1364.4 1384.4
## - loan_amount 1 1368.4 1386.4
## - serasa_banking_debts 1 1368.6 1386.6
## - serasa_dishonored_checks 1 1370.2 1388.2
## - age 1 1372.2 1390.2
## - serasa_restriction 1 1373.0 1391.0
## - monthly_payment 1 1380.7 1398.7
## - cpf_restriction 1 1385.1 1403.1
## - collateral_debt_amount 1 1489.9 1507.9
##
## Step: AIC=1383.68
## sent_to_analysis ~ age + loan_amount + collateral_debt_amount +
## serasa_restriction + serasa_dishonored_checks + serasa_banking_debts +
## cpf_restriction + monthly_payment
##
## Df Deviance AIC
## <none> 1365.7 1383.7
## - loan_amount 1 1369.8 1385.8
## - serasa_banking_debts 1 1369.9 1385.9
## - serasa_dishonored_checks 1 1371.5 1387.5
## - age 1 1373.7 1389.7
## - serasa_restriction 1 1375.5 1391.5
## - monthly_payment 1 1382.2 1398.2
## - cpf_restriction 1 1386.0 1402.0
## - collateral_debt_amount 1 1490.9 1506.9
mod.final3##
## Call: glm(formula = sent_to_analysis ~ age + loan_amount + collateral_debt_amount +
## serasa_restriction + serasa_dishonored_checks + serasa_banking_debts +
## cpf_restriction + monthly_payment, family = binomial, data = credit[i_calibration2,
## ])
##
## Coefficients:
## (Intercept) age
## -0.7767 1.5529
## loan_amount collateral_debt_amount
## -6.3998 -2374.6379
## serasa_restriction serasa_dishonored_checks
## -0.8985 -14.2825
## serasa_banking_debts cpf_restriction
## -1.2392 -1.0591
## monthly_payment
## 11.4263
##
## Degrees of Freedom: 1247 Total (i.e. Null); 1239 Residual
## Null Deviance: 1628
## Residual Deviance: 1366 AIC: 1384
Precisamos de uma boa linha de base que crie "o melhor modelo simples" que traga um equilíbrio entre a melhor precisão possível com um modelo que ainda é simples o suficiente para entender.
coefficients(LogisticModel.1) * 20/log(2)## (Intercept) age monthly_income
## -3.539493e+01 2.751826e+01 -1.702993e+02
## collateral_value loan_amount collateral_debt_amount
## 3.085372e+00 5.523832e+01 -6.741140e+04
## serasa_restriction serasa_dishonored_checks serasa_expired_debts
## -8.002104e+00 -4.041904e+02 -4.051691e+02
## serasa_banking_debts serasa_commercial_debts serasa_protests
## -6.400382e+01 -3.521645e+01 -6.991561e-01
## cpf_restriction monthly_payment purpose
## -1.022171e+01 7.110040e+01 4.530113e+00
O pacote OneR serve para encontrar esse ponto e, assim, estabelecer uma nova linha de base Para modelos de classificação em Aprendizado de Máquinas (ML).
O pacote OneR está preenchendo uma lacuna de longa data porque apenas uma implementação baseada em JAVA estava disponível até agora (pacote RWeka como uma interface para a classe OneR JAVA). Além disso, vários aprimoramentos foram feitos.
Agora vamos usar o pacote OneR e comparar.
library("OneR")
#credit <- ndf
#credit[,c(1,2,7,8,18,21:25,27:33,35,36)] <- NULL
#ndf[is.na(ndf)] <- 0
#credit <- subset(credit,credit$monthly_payment != 0)
#ndf[is.na(ndf)] <- 0
modelOne <- OneR(sent_to_analysis ~ . , data = credit[i_test1,-c(12,15,17)], verbose = TRUE)##
## Attribute Accuracy
## 1 * monthly_payment 64.62%
## 2 loan_amount 64.38%
## 3 age 64.34%
## 3 monthly_income 64.34%
## 3 collateral_value 64.34%
## 3 collateral_debt_amount 64.34%
## 3 serasa_restriction 64.34%
## 3 serasa_dishonored_checks 64.34%
## 3 serasa_expired_debts 64.34%
## 3 serasa_banking_debts 64.34%
## 3 serasa_commercial_debts 64.34%
## 3 serasa_protests 64.34%
## 3 cpf_restriction 64.34%
## ---
## Chosen attribute due to accuracy
## and ties method (if applicable): '*'
Vamos mostrar as regras aprendidas e diagnósticos do modelo.
summary(modelOne)##
## Call:
## OneR.formula(formula = sent_to_analysis ~ ., data = credit[i_test1,
## -c(12, 15, 17)], verbose = TRUE)
##
## Rules:
## If monthly_payment = (0.0044,0.204] then sent_to_analysis = 0
## If monthly_payment = (0.204,0.403] then sent_to_analysis = 1
## If monthly_payment = (0.403,0.602] then sent_to_analysis = 1
## If monthly_payment = (0.602,0.801] then sent_to_analysis = 1
## If monthly_payment = (0.801,1] then sent_to_analysis = 0
##
## Accuracy:
## 1881 of 2911 instances classified correctly (64.62%)
##
## Contingency table:
## monthly_payment
## sent_to_analysis (0.0044,0.204] (0.204,0.403] (0.403,0.602] (0.602,0.801]
## 0 * 1854 18 0 0
## 1 1012 * 20 * 5 * 1
## Sum 2866 38 5 1
## monthly_payment
## sent_to_analysis (0.801,1] Sum
## 0 * 1 1873
## 1 0 1038
## Sum 1 2911
## ---
## Maximum in each column: '*'
##
## Pearson's Chi-squared test:
## X-squared = 16.303, df = 4, p-value = 0.002638
Agora sim temos um modelo mais performático.
Então vamos plotar o Diagnóstico do modelo
plot(modelOne)
Usando o modelo para prever dados
prediction <- predict(modelOne, credit[-i_test1,-c(12,15,17)])Avaliando as estatísticas de previsão
OLT <- eval_model(prediction, credit[-i_test1,-c(12,15,17)])##
## Confusion matrix (absolute):
## Actual
## Prediction 0 1 Sum
## 0 778 447 1225
## 1 10 13 23
## Sum 788 460 1248
##
## Confusion matrix (relative):
## Actual
## Prediction 0 1 Sum
## 0 0.62 0.36 0.98
## 1 0.01 0.01 0.02
## Sum 0.63 0.37 1.00
##
## Accuracy:
## 0.6338 (791/1248)
##
## Error rate:
## 0.3662 (457/1248)
##
## Error rate reduction (vs. base rate):
## 0.0065 (p-value = 0.4427)
OLT## $correct_instances
## [1] 791
##
## $total_instances
## [1] 1248
##
## $conf_matrix
## Actual
## Prediction 0 1
## 0 778 447
## 1 10 13
OLT <- OLT$correct_instances/OLT$total_instancesNão, esse modelo com 64,25% não é o modelo ideal para classificação de crédito com garantia de automóvel.
Usamos quatro modelos, e uma comparação entre eles, com os seguintes desempenhos:
| Algoritmo | Desempenho |
|---|---|
| Regressão Logística | 0.7453075 |
| Árvore de Regressão | 0.7196146 |
| Floresta aleatória | 0.7462712 |
| Comparação GLM x RF | 0.6394231 |
| One level decision trees | 0.6338141 |
Concluimos que o algoritmo Regressão Logística tem uma melhor adaptação a esses dados, mostrando resultados melhores. O mesmo para Random Forest. Recomenda-se usar ambos até que a distância de desempenho se justifique. Ao longo do tempo as avaliações podem passar por prova de hipótese para certificar estatisticamente o poder.
.