Classificação Usando Logit
Heitor Gabriel S. Monteiro
28/04/2021
1 Objetivo
Meu objetivo é exercitar a criação e teste de modelos logit para previsão de cancelamento de serviço e publicar meus códigos para servirem de aprendizado. Uso os dados coletados da IBM, chamados de Telco. Para isso, farei um tratamento inicial do dado; uma breve descrição dele, com primeiras observações acerca dos cancelamentos. Separarei amostras aleatórias para treino e teste; criei dois modelos e, por fim, os comparei conforme o poder de predição. Como estamos lidando com previsão, pouco nos importa o poder de explicação das variáveis: todas variáveis, se nos ajudam minimamente a prever o cancelamento, serão usadas.
2 Dados
Carregando os pacotes necessários para a análise:
library(tidyverse) # padrão
library(stargazer) #
library(knitr) # produzir tabelas personalizadas
library(kableExtra) # mais ferramentas de personalização
library(gt)Definindo o diretório do código e do arquivo e importando-o.
setwd("/home/heitor/Área de Trabalho/R Projects/Análise Macro/Lab 4")
dt <- as_tibble(read_csv("Telco-Customer-Churn.csv"))
attach(dt)
glimpse(dt)## Rows: 7,043
## Columns: 21
## $ customerID <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CFOCW…
## $ gender <chr> "Female", "Male", "Male", "Male", "Female", "Female",…
## $ SeniorCitizen <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ Partner <chr> "Yes", "No", "No", "No", "No", "No", "No", "No", "Yes…
## $ Dependents <chr> "No", "No", "No", "No", "No", "No", "Yes", "No", "No"…
## $ tenure <dbl> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58, 49, 2…
## $ PhoneService <chr> "No", "Yes", "Yes", "No", "Yes", "Yes", "Yes", "No", …
## $ MultipleLines <chr> "No phone service", "No", "No", "No phone service", "…
## $ InternetService <chr> "DSL", "DSL", "DSL", "DSL", "Fiber optic", "Fiber opt…
## $ OnlineSecurity <chr> "No", "Yes", "Yes", "Yes", "No", "No", "No", "Yes", "…
## $ OnlineBackup <chr> "Yes", "No", "Yes", "No", "No", "No", "Yes", "No", "N…
## $ DeviceProtection <chr> "No", "Yes", "No", "Yes", "No", "Yes", "No", "No", "Y…
## $ TechSupport <chr> "No", "No", "No", "Yes", "No", "No", "No", "No", "Yes…
## $ StreamingTV <chr> "No", "No", "No", "No", "No", "Yes", "Yes", "No", "Ye…
## $ StreamingMovies <chr> "No", "No", "No", "No", "No", "Yes", "No", "No", "Yes…
## $ Contract <chr> "Month-to-month", "One year", "Month-to-month", "One …
## $ PaperlessBilling <chr> "Yes", "No", "Yes", "No", "Yes", "Yes", "Yes", "No", …
## $ PaymentMethod <chr> "Electronic check", "Mailed check", "Mailed check", "…
## $ MonthlyCharges <dbl> 29.85, 56.95, 53.85, 42.30, 70.70, 99.65, 89.10, 29.7…
## $ TotalCharges <dbl> 29.85, 1889.50, 108.15, 1840.75, 151.65, 820.50, 1949…
## $ Churn <chr> "No", "No", "Yes", "No", "Yes", "Yes", "No", "No", "Y…Retirei a variável de ID por razões óbvias. Transformarei a variável SeniorCitizen em categórica, com Yes ou No. ##E simplifiquei as variáveis que respondem com NoPhoneService para somente No.##
dt$customerID <- NULL
dt$SeniorCitizen [dt$SeniorCitizen==0] <- 'No'
dt$SeniorCitizen [dt$SeniorCitizen==1] <- 'Yes'
dt$SeniorCitizen <- as.factor(dt$SeniorCitizen)
#dt$MultipleLines [dt$PhoneService=='No'] <- 'No'
#dt$OnlineSecurity [dt$InternetService=='No'] <- 'No'
#dt$OnlineBackup [dt$InternetService=='No'] <- 'No'
#dt$DeviceProtection [dt$InternetService=='No'] <- 'No'
#dt$TechSupport [dt$InternetService=='No'] <- 'No'
#dt$StreamingTV [dt$InternetService=='No'] <- 'No'
#dt$StreamingMovies [dt$InternetService=='No'] <- 'No'
dt$InternetService <- as.factor(dt$InternetService)
dt$Partner <- as.factor(dt$Partner)
dt$Dependents <- as.factor(dt$Dependents)
dt$PhoneService <- as.factor(dt$PhoneService)
dt$MultipleLines <- as.factor(dt$MultipleLines)
dt$OnlineSecurity <- as.factor(dt$OnlineSecurity)
dt$OnlineBackup <- as.factor(dt$OnlineBackup)
dt$DeviceProtection <- as.factor(dt$DeviceProtection)
dt$TechSupport <- as.factor(dt$TechSupport)
dt$StreamingTV <- as.factor(dt$StreamingTV)
dt$StreamingMovies <- as.factor(dt$StreamingMovies)
dt$Contract <- as.factor(dt$Contract)
dt$PaperlessBilling <- as.factor(dt$PaperlessBilling)
dt$PaymentMethod <- as.factor(dt$PaymentMethod)3 Descrição dos Dados
Para começar a ter noção de quais variáveis respondem melhor a Churn, segue tabelas de proporção relativa e gráficos de barras categorizadas.
t1 <- table(Contract, Churn)
t2 <- table(InternetService, Churn)
t3 <- table(PhoneService, Churn)
t4 <- table(SeniorCitizen, Churn)
t5 <- table(Partner, Churn)
t6 <- table(Dependents, Churn)
t7 <- table(PaymentMethod, Churn)t1 %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
round(2) %>%
data.frame() %>%
pivot_wider(names_from = Churn, values_from = Freq) %>%
gt() %>% tab_header('Contrato contra Churn - %')| Contrato contra Churn - % | ||
|---|---|---|
| Contract | No | Yes |
| Month-to-month | 31.52 | 23.50 |
| One year | 18.56 | 2.36 |
| Two year | 23.38 | 0.68 |
ggplot(data = dt,
aes(x = factor(Contract),
y = prop.table(stat(count)),
fill = factor(Churn),
label = scales::percent(prop.table(stat(count))))) +
geom_bar(position = "dodge") +
geom_text(stat = 'count',
position = position_dodge(.9),
vjust = -0.5,
size = 3) +
scale_y_continuous(labels = scales::percent) +
labs(x = 'Contracts Types',
y = 'pct',
fill = 'Churn',
title = 'Proporção de Churn por Contratos')
As descrições do vencimento de contrato nos mostram que contratos mensais têm relativa maior chance de serem cancelados. Algum programa de fidelização ou de prolongamento de validade de contrato seria interessante para não perdê-los.
t2 %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
round(2) %>%
data.frame() %>%
pivot_wider(names_from = Churn,
values_from = Freq) %>%
gt() %>% tab_header('Serviço de Internet contra Churn - %')| Serviço de Internet contra Churn - % | ||
|---|---|---|
| InternetService | No | Yes |
| DSL | 27.86 | 6.52 |
| Fiber optic | 25.54 | 18.42 |
| No | 20.06 | 1.60 |
ggplot(data = dt,
aes(x = factor(InternetService),
y = prop.table(stat(count)),
fill = factor(Churn),
label = scales::percent(prop.table(stat(count))))) +
geom_bar(position = "dodge") +
geom_text(stat = 'count',
position = position_dodge(.9),
vjust = -0.5,
size = 3) +
scale_y_continuous(labels = scales::percent) +
labs(x = 'Internet Service Types',
y = 'pct',
fill = 'Churn',
title = 'Proporção de Churn por Tipos de Recebimento de Internet')
Os clientes que usam fibra óptica têm relativa maior chance de cancelarem os contratos. Resta-nos saber se tal tipo está associado a algum tipo de pacote ou configuração de plano:
table(Contract, PaymentMethod, InternetService) %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
data.frame() %>%
pivot_wider(names_from = InternetService,
values_from = Freq) %>%
select(-PaymentMethod) %>%
kable(#format = "latex",
booktabs = TRUE,
escape = FALSE,
digits = 2,
caption = "Proporções por Caraterísticas") %>%
pack_rows('Bank transfer', 1,3) %>%
pack_rows('Credit card', 4,6) %>%
pack_rows('Electronic check', 7,9) %>%
pack_rows('Mailed check', 10,12) %>%
kable_styling(latex_options = c("striped", "hold_position"),
position = "center",
full_width = F,
bootstrap_options = c("striped", "hover", "condensed", "responsive")) %>%
column_spec(1, bold = T) %>%
row_spec(0, bold = T) %>%
footnote( general = "Elaboração Própria.",
general_title = "Fonte:",
footnote_as_chunk = T,
title_format = c("italic"))| Contract | DSL | Fiber optic | No |
|---|---|---|---|
| Bank transfer | |||
| Month-to-month | 2.80 | 4.64 | 0.92 |
| One year | 2.06 | 2.23 | 1.26 |
| Two year | 3.18 | 2.30 | 2.53 |
| Credit card | |||
| Month-to-month | 2.63 | 4.16 | 0.92 |
| One year | 2.44 | 2.13 | 1.08 |
| Two year | 3.37 | 2.19 | 2.70 |
| Electronic check | |||
| Month-to-month | 6.73 | 18.56 | 0.98 |
| One year | 1.65 | 2.78 | 0.50 |
| Two year | 0.82 | 1.31 | 0.26 |
| Mailed check | |||
| Month-to-month | 5.21 | 2.85 | 4.61 |
| One year | 1.95 | 0.51 | 2.33 |
| Two year | 1.55 | 0.30 | 3.58 |
| Fonte: Elaboração Própria. | |||
Vemos que a fibra ótica está associado a pagamentos mensais e a cheques eletrônicos, é possível que haja endogeneidade desses fatores quando rodar o modelo logit. Fica o alerta para testar diferentes versões.
t3 %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
round(2) %>%
data.frame() %>%
pivot_wider(names_from = Churn,
values_from = Freq) %>%
gt() %>% tab_header('Serviço de Celular contra Churn - %')| Serviço de Celular contra Churn - % | ||
|---|---|---|
| PhoneService | No | Yes |
| No | 7.27 | 2.41 |
| Yes | 66.19 | 24.12 |
ggplot(data = dt,
aes(x = factor(PhoneService),
y = prop.table(stat(count)),
fill = factor(Churn),
label = scales::percent(prop.table(stat(count))))) +
geom_bar(position = "dodge") +
geom_text(stat = 'count',
position = position_dodge(.9),
vjust = -0.5,
size = 3) +
scale_y_continuous(labels = scales::percent) +
labs(x = 'Has Phone Service',
y = 'pct',
fill = 'Churn',
title = 'Proporção de Churn por Serviço de Celular')
Não ficou clara a discrepância relativa da variável.
t3 <- t3 %>% data.frame()
c(t3$Freq[3] / t3$Freq[1] , t3$Freq[4] / t3$Freq[2])## [1] 0.3320312 0.3644359Vemos que não há significativa diferença relativa para o cancelamento se o cliente tem ou não serviço telefônico.
t4 %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
round(2) %>%
data.frame() %>%
pivot_wider(names_from = Churn,
values_from = Freq) %>%
gt() %>% tab_header('Idosos contra Churn - %')| Idosos contra Churn - % | ||
|---|---|---|
| SeniorCitizen | No | Yes |
| 0 | 64.01 | 19.78 |
| 1 | 9.46 | 6.76 |
ggplot(data = dt,
aes(x = factor(SeniorCitizen),
y = prop.table(stat(count)),
fill = factor(Churn),
label = scales::percent(prop.table(stat(count))))) +
geom_bar(position = "dodge") +
geom_text(stat = 'count',
position = position_dodge(.9),
vjust = -0.5,
size = 3) +
scale_y_continuous(labels = scales::percent) +
labs(x = 'É idoso',
y = 'pct',
fill = 'Churn',
title = 'Proporção de Churn por Idosos')
Vemos que os idosos têm relativa maior chance de cancelar o serviço.
t5 %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
round(2) %>%
data.frame() %>%
pivot_wider(names_from = Churn,
values_from = Freq) %>%
gt() %>% tab_header('Compartilhamento contra Churn - %')| Compartilhamento contra Churn - % | ||
|---|---|---|
| Partner | No | Yes |
| No | 34.66 | 17.04 |
| Yes | 38.80 | 9.50 |
ggplot(data = dt,
aes(x = factor(Partner),
y = prop.table(stat(count)),
fill = factor(Churn),
label = scales::percent(prop.table(stat(count))))) +
geom_bar(position = "dodge") +
geom_text(stat = 'count',
position = position_dodge(.9),
vjust = -0.5,
size = 3) +
scale_y_continuous(labels = scales::percent) +
labs(x = 'Serviço Compartilhado',
y = 'pct',
fill = 'Churn',
title = 'Proporção de Churn por Compartilhamento')
Quem compartilha o serviço tem menos chance de cancelá-lo, é intuitivo: cancelar precisa da aprovação do outro, além de, muitas vezes, racharem a conta. Um questionamento derivado e interessante é até que ponto, dado a chance de não cancelar, temos perdas ou ganhos esperados entre 1) ter um cliente que compartilha, com chance menor de cancelar; e 2) ter dois clientes, digamos, com chance maior de cancelar. Dá pra fazer usando naive bayes, fica a ideia.
t6 %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
round(2) %>%
data.frame() %>%
pivot_wider(names_from = Churn,
values_from = Freq) %>%
gt() %>% tab_header('Dependentes contra Churn - %')| Dependentes contra Churn - % | ||
|---|---|---|
| Dependents | No | Yes |
| No | 48.13 | 21.91 |
| Yes | 25.33 | 4.63 |
ggplot(data = dt,
aes(x = factor(Dependents),
y = prop.table(stat(count)),
fill = factor(Churn),
label = scales::percent(prop.table(stat(count))))) +
geom_bar(position = "dodge") +
geom_text(stat = 'count',
position = position_dodge(.9),
vjust = -0.5,
size = 3) +
scale_y_continuous(labels = scales::percent) +
labs(x = 'Dependentes',
y = 'pct',
fill = 'Churn',
title = 'Proporção de Churn por Dependentes')
Clientes sem dependentes tem maior chance relativa de cancelar o contrato.
t7 %>%
ftable() %>%
prop.table() %>%
{.*100} %>%
round(2) %>%
data.frame() %>%
pivot_wider(names_from = Churn,
values_from = Freq) %>%
gt() %>% tab_header('Método de Pagamento contra Churn - %')| Método de Pagamento contra Churn - % | ||
|---|---|---|
| PaymentMethod | No | Yes |
| Bank transfer (automatic) | 18.26 | 3.66 |
| Credit card (automatic) | 18.32 | 3.29 |
| Electronic check | 18.37 | 15.21 |
| Mailed check | 18.51 | 4.37 |
ggplot(data = dt,
aes(x = factor(PaymentMethod),
y = prop.table(stat(count)),
fill = factor(Churn),
label = scales::percent(prop.table(stat(count))))) +
geom_bar(position = "dodge") +
geom_text(stat = 'count',
position = position_dodge(.9),
vjust = -0.5,
size = 3) +
scale_y_continuous(labels = scales::percent) +
labs(x = 'Método',
y = 'pct',
fill = 'Churn',
title = 'Proporção de Churn por Método de Pagamento')
É discrepante como o cheque eletrônico gera uma maior tendência relativa ao cancelamento de contrato.
ggplot(dt, aes(TotalCharges, Churn, fill=Churn)) +
geom_boxplot(na.rm = T) +
coord_flip()+
ggtitle('Box Plot de Churn por Total de Trocas')
ggplot(dt, aes(tenure, Churn, fill=Churn)) +
geom_boxplot(na.rm = T) +
coord_flip()+
ggtitle('Box Plot de Churn por Idade')
ggplot(dt, aes(MonthlyCharges, Churn, fill=Churn)) +
geom_boxplot(na.rm = T) +
coord_flip()+
ggtitle('Box Plot de Churn por Total de Trocas Mensais')
A variável de cancelamento sempre parece ter uma variabilidade maior.
Resumindo, contratos mensais, de fibra ótica, sem compartilhamento e sem dependentes, com pagamento de boleto e clientes idosos têm maiores chances de cancelar.
4 Separando Amostras de Treino e Teste
Foi aleatoriamente escolhida uma amostre de treino, sobre o qual o modelo será feito, de 80%. Portanto, o teste será feito na amostra restante, 20%.
dt$Churn2 <- dt$Churn
dt$Churn2[dt$Churn=='No'] <- 0
dt$Churn2[dt$Churn=='Yes'] <- 1
dt$Churn2 <- as.numeric(dt$Churn2)
train <- dt %>% select(-Churn) %>% sample_frac(.,0.8)
sid <- as.numeric(rownames(train))
test <- dt[-sid,] %>% select(-Churn)5 Modelos Logit
Primeiramente, fiz um modelo (logit1) com todas as variáveis e observei quais variáveis eram significantes para criar o logit2. Com outras variáveis que julguei interessantes, pelos resultados das descrições anteriores, fiz um modelo logit3 para comparação.
logit1 <- glm(Churn2~.,
family = binomial(link = "logit"),
data=train)
summary(logit1)##
## Call:
## glm(formula = Churn2 ~ ., family = binomial(link = "logit"),
## data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.9821 -0.6813 -0.2841 0.7040 3.4370
##
## Coefficients: (7 not defined because of singularities)
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.415e+00 9.111e-01 1.553 0.12051
## genderMale -1.978e-02 7.274e-02 -0.272 0.78567
## SeniorCitizenYes 2.333e-01 9.488e-02 2.459 0.01393 *
## PartnerYes -1.175e-02 8.718e-02 -0.135 0.89279
## DependentsYes -1.283e-01 1.009e-01 -1.271 0.20365
## tenure -6.464e-02 7.069e-03 -9.144 < 2e-16 ***
## PhoneServiceYes 6.135e-01 7.249e-01 0.846 0.39739
## MultipleLinesNo phone service NA NA NA NA
## MultipleLinesYes 5.838e-01 1.978e-01 2.951 0.00316 **
## InternetServiceFiber optic 2.265e+00 8.924e-01 2.538 0.01115 *
## InternetServiceNo -2.121e+00 9.019e-01 -2.351 0.01870 *
## OnlineSecurityNo internet service NA NA NA NA
## OnlineSecurityYes -3.845e-02 2.002e-01 -0.192 0.84768
## OnlineBackupNo internet service NA NA NA NA
## OnlineBackupYes 8.846e-02 1.968e-01 0.450 0.65304
## DeviceProtectionNo internet service NA NA NA NA
## DeviceProtectionYes 1.847e-01 1.957e-01 0.944 0.34517
## TechSupportNo internet service NA NA NA NA
## TechSupportYes -1.116e-01 2.013e-01 -0.554 0.57942
## StreamingTVNo internet service NA NA NA NA
## StreamingTVYes 8.165e-01 3.660e-01 2.231 0.02569 *
## StreamingMoviesNo internet service NA NA NA NA
## StreamingMoviesYes 8.257e-01 3.649e-01 2.263 0.02365 *
## ContractOne year -6.763e-01 1.219e-01 -5.548 2.89e-08 ***
## ContractTwo year -1.299e+00 1.946e-01 -6.676 2.45e-11 ***
## PaperlessBillingYes 4.442e-01 8.375e-02 5.304 1.13e-07 ***
## PaymentMethodCredit card (automatic) 2.038e-02 1.298e-01 0.157 0.87524
## PaymentMethodElectronic check 4.238e-01 1.066e-01 3.975 7.04e-05 ***
## PaymentMethodMailed check 7.828e-02 1.294e-01 0.605 0.54537
## MonthlyCharges -6.029e-02 3.547e-02 -1.700 0.08918 .
## TotalCharges 3.731e-04 7.949e-05 4.693 2.69e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 6525.4 on 5623 degrees of freedom
## Residual deviance: 4631.8 on 5600 degrees of freedom
## (10 observations deleted due to missingness)
## AIC: 4679.8
##
## Number of Fisher Scoring iterations: 6remove(logit1)logit_2 <- glm(Churn2~Contract+InternetService+TotalCharges+tenure+PaperlessBilling,
family = binomial(link = "logit"),
data=train)
summary(logit_2)##
## Call:
## glm(formula = Churn2 ~ Contract + InternetService + TotalCharges +
## tenure + PaperlessBilling, family = binomial(link = "logit"),
## data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.6030 -0.7044 -0.2982 0.8072 3.5116
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -5.028e-01 9.315e-02 -5.398 6.76e-08 ***
## ContractOne year -8.646e-01 1.174e-01 -7.365 1.77e-13 ***
## ContractTwo year -1.645e+00 1.901e-01 -8.653 < 2e-16 ***
## InternetServiceFiber optic 9.511e-01 9.491e-02 10.021 < 2e-16 ***
## InternetServiceNo -7.091e-01 1.335e-01 -5.310 1.10e-07 ***
## TotalCharges 3.421e-04 6.945e-05 4.926 8.38e-07 ***
## tenure -6.243e-02 6.578e-03 -9.491 < 2e-16 ***
## PaperlessBillingYes 5.442e-01 8.126e-02 6.697 2.13e-11 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 6525.4 on 5623 degrees of freedom
## Residual deviance: 4780.8 on 5616 degrees of freedom
## (10 observations deleted due to missingness)
## AIC: 4796.8
##
## Number of Fisher Scoring iterations: 6logit_3 <- glm(Churn2~Contract+TotalCharges+PaymentMethod+SeniorCitizen+Partner+Dependents,
family = binomial(link = "logit"),
data=train)
summary(logit_3)##
## Call:
## glm(formula = Churn2 ~ Contract + TotalCharges + PaymentMethod +
## SeniorCitizen + Partner + Dependents, family = binomial(link = "logit"),
## data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.4783 -0.8502 -0.3558 0.9259 2.8742
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -5.965e-01 9.888e-02 -6.033 1.61e-09 ***
## ContractOne year -1.450e+00 1.082e-01 -13.398 < 2e-16 ***
## ContractTwo year -2.598e+00 1.744e-01 -14.898 < 2e-16 ***
## TotalCharges -6.652e-05 2.126e-05 -3.129 0.00175 **
## PaymentMethodCredit card (automatic) 3.487e-02 1.219e-01 0.286 0.77490
## PaymentMethodElectronic check 8.394e-01 9.904e-02 8.475 < 2e-16 ***
## PaymentMethodMailed check -1.100e-01 1.167e-01 -0.942 0.34609
## SeniorCitizenYes 4.437e-01 8.836e-02 5.022 5.12e-07 ***
## PartnerYes -9.735e-02 8.107e-02 -1.201 0.22979
## DependentsYes -3.084e-01 9.466e-02 -3.258 0.00112 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 6525.4 on 5623 degrees of freedom
## Residual deviance: 5184.7 on 5614 degrees of freedom
## (10 observations deleted due to missingness)
## AIC: 5204.7
##
## Number of Fisher Scoring iterations: 6Apliquei logit2 e logit3 sobre a amostra de teste e criei dois novos conjuntos de dados (results_2 e results_3) para visualizar melhor o poder preditivo.
pred_2 <- predict(logit_2, newdata = test)
pred_3 <- predict(logit_3, newdata = test)results_2 <- data.frame(Churn_Original = test$Churn2,
Churn_Pred_2 = pred_2)
results_3 <- data.frame(Churn_Original = test$Churn2,
Churn_Pred_3 = pred_3)Determinei que todos os valores acima de 50% de chances devem ser 1, ou seja, o modelo prevê cancelamento, e abaixo de 50%, o modelo não prevê cancelamento.
results_2$Churn_Pred[results_2$Churn_Pred_2<0.5] <- 0
results_2$Churn_Pred[results_2$Churn_Pred_2>0.5] <- 1
results_2$Churn_Pred <- as.numeric(results_2$Churn_Pred)
results_3$Churn_Pred[results_3$Churn_Pred_3<0.5] <- 0
results_3$Churn_Pred[results_3$Churn_Pred_3>0.5] <- 1
results_3$Churn_Pred <- as.numeric(results_3$Churn_Pred)6 Poder de Previsão dos Modelos
Criei uma tebela de acertos e erros: nas diagonais, a quantidade de acertos do modelo, ou seja, quando o modelo preveu cancelamento ou não-cancelamento e foi condizente com o resultado original. Nomeei esse resultado como accuracy. Depois, vi a taxa de erros: falsos positivos (error_i_f1) e falsos negativos (error_i_f0) de cada modelo. Podemos concluir que, em todas as medidas, o modelo logit2 se saiu melhor.
rt_2 <- table(results_2$Churn_Original, results_2$Churn_Pred)
rt_3 <- table(results_3$Churn_Original, results_3$Churn_Pred)
rt_2 %>% data.frame() %>% gt() %>%
tab_header('Frequências de Churn Original vs Churn Previsto em Logit2') %>%
cols_label(Var1='Churn Original',
Var2='Churn Predito')| Frequências de Churn Original vs Churn Previsto em Logit2 | ||
|---|---|---|
| Churn Original | Churn Predito | Freq |
| 0 | 0 | 985 |
| 1 | 0 | 262 |
| 0 | 1 | 41 |
| 1 | 1 | 119 |
rt_3%>% data.frame() %>% gt() %>%
tab_header('Frequências de Churn Original vs Churn Previsto em Logit3') %>%
cols_label(Var1='Churn Original',
Var2='Churn Predito')| Frequências de Churn Original vs Churn Previsto em Logit3 | ||
|---|---|---|
| Churn Original | Churn Predito | Freq |
| 0 | 0 | 1007 |
| 1 | 0 | 341 |
| 0 | 1 | 19 |
| 1 | 1 | 40 |
accuracy_2 <- sum(diag(rt_2)) / sum(rt_2)
error_2_f0 <- rt_2[2,1] / sum(rt_2[,1])
error_2_f1 <- rt_2[1,2] / sum(rt_2[,2])
accuracy_3 <- sum(diag(rt_3)) / sum(rt_3)
error_3_f0 <- rt_3[2,1] / sum(rt_3[,1])
error_3_f1 <- rt_3[1,2] / sum(rt_3[,2])accur <- data.frame(Acurácia_Geral = c(accuracy_2, accuracy_3),
Falso_No = c(error_2_f0, error_3_f0),
Falso_Ys = c(error_2_f1, error_3_f1))
accur %>% {.*100} %>% round(2) %>% gt() %>% tab_header('Taxas de Poder dos Modelos')| Taxas de Poder dos Modelos | ||
|---|---|---|
| Acurácia_Geral | Falso_No | Falso_Ys |
| 78.46 | 21.01 | 25.62 |
| 74.41 | 25.30 | 32.20 |