Untitled

Pacotes

library(tidyverse) 

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.1
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(MASS)

## 
## Anexando pacote: 'MASS'
## 
## O seguinte objeto é mascarado por 'package:dplyr':
## 
##     select

library(car)

## Carregando pacotes exigidos: carData
## 
## Anexando pacote: 'car'
## 
## O seguinte objeto é mascarado por 'package:dplyr':
## 
##     recode
## 
## O seguinte objeto é mascarado por 'package:purrr':
## 
##     some

library(e1071)
library(caret)

## Carregando pacotes exigidos: lattice
## 
## Anexando pacote: 'caret'
## 
## O seguinte objeto é mascarado por 'package:purrr':
## 
##     lift

library(cowplot)

## 
## Anexando pacote: 'cowplot'
## 
## O seguinte objeto é mascarado por 'package:lubridate':
## 
##     stamp

library(caTools)
library(pROC)

## Type 'citation("pROC")' for a citation.
## 
## Anexando pacote: 'pROC'
## 
## Os seguintes objetos são mascarados por 'package:stats':
## 
##     cov, smooth, var

library(ggcorrplot)
library(car)
library(lmtest)

## Carregando pacotes exigidos: zoo
## 
## Anexando pacote: 'zoo'
## 
## Os seguintes objetos são mascarados por 'package:base':
## 
##     as.Date, as.Date.numeric

Definições:

Sim, os modelos de longa duração ou fração de cura são tipos de modelos de regressão usados na análise de sobrevivência. Eles são projetados para lidar com situações em que uma fração dos indivíduos pode nunca experimentar o evento de interesse (como a cura em estudos médicos) e, portanto, não têm um tempo de sobrevivência observado.

“taxa de churn” é frequentemente utilizada como um termo padrão. Ela implica diretamente uma relação de clientes perdidos em relação ao total de clientes inicial, independentemente de ser expressa como uma taxa ou como uma porcentagem.

Taxa: Na demografia, para que uma quantidade seja chamada uma taxa, ela precisa ter um numerador que quantifica um número de eventos e um denominador que descreve o número de pessoas que em alguma medida podem ser expostas a este evento. Exemplo A taxa de cancelamento, também chamada de taxa de churn, seria a quantidade de clientes que cancelam seus contratos sobre o total de clientes em um determinado período.

Fim Definições

Legenda das Colunas:

customerID: Identificação única do cliente.

gender: Gênero do cliente.

SeniorCitizen: Indicação se o cliente é idoso (1 para sim, 0 para não).

Partner: Indicação se o cliente tem parceiro (1 para sim, 0 para não).

Dependents: Indicação se o cliente tem dependentes (1 para sim, 0 para não).

tenure: Tempo que o cliente permaneceu como cliente da empresa (em meses).

PhoneService: Indicação se o cliente possui serviço de telefone (1 para sim, 0 para não).

MultipleLines: Indicação se o cliente tem múltiplas linhas de telefone (por exemplo, celular e fixo) (Sim, Não, Sem serviço de telefone).

InternetService: Tipo de serviço de internet do cliente ou se nao tem internet (por exemplo, DSL, fibra ótica).

OnlineSecurity: Indicação se o cliente possui segurança online (Sim, Não, Sem serviço de internet).

OnlineBackup: Indicação se o cliente possui backup online (Sim, Não, Sem serviço de internet).

DeviceProtection: Indicação se o cliente possui proteção de dispositivo (Sim, Não, Sem serviço de internet).

TechSupport: Indicação se o cliente possui suporte técnico (Sim, Não, Sem serviço de internet).

StreamingTV: Indicação se o cliente possui serviço de streaming de TV (Sim, Não, Sem serviço de internet).

StreamingMovies: Indicação se o cliente possui serviço de streaming de filmes (Sim, Não, Sem serviço de internet).

Contract: Tipo de contrato do cliente (por exemplo, mensal, anual).

PaperlessBilling: Indicação se o cliente recebe faturas em formato eletrônico (1 para sim, 0 para não).

PaymentMethod: Método de pagamento do cliente. -Transfer Bank-TED-transferência eletrônica de fundos entre bancos diferentes que ocorre no mesmo dia útil -Debito em Conta Mailed Check-Cheque enviado por correio para o provedor pelo correio Cartao de credito

Electronic Check é quando você fornece as informações de um cheque (como número da conta, número do banco, valor) para uma empresa ou indivíduo para que eles possam debitar o valor diretamente da sua conta bancária. Não é um cheque físico, mas sim uma transação eletrônica que usa os dados do cheque para realizar o débito. No Brasil, isso pode ser feito através de débito autorizado, por exemplo.

MonthlyCharges: Valor da cobrança mensal do cliente.

TotalCharges: Valor total cobrado ao cliente.

Churn: Indicação se o cliente cancelou o serviço (1 para sim, 0 para não).

Lendo os dados

library(readr)

telco <- read.csv("Telecom_Churn.csv")
glimpse(telco)

## Rows: 7,043
## Columns: 21
## $ customerID       <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-CFOCW…
## $ gender           <chr> "Female", "Male", "Male", "Male", "Female", "Female",…
## $ SeniorCitizen    <int> 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           <int> 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…

#1. Situação dos dados

Mudando Nomes Colunas

# Novos nomes das colunas em português
novos_nomes <- c("IDCliente", "Genero", "Idoso", "Parceiro", "Dependentes",
                 "Tempo", "ServicoTelefone", "MultiplasLinhas", "ServicoInternet", 
                 "SegurancaOnline", "BackupOnline", "ProtecaoDispositivo", 
                 "SuporteTecnico", "StreamingTV", "StreamingFilmes", 
                 "Contrato", "FaturamentoEletronico", "MetodoPagamento", 
                 "CobrancaMensal", "CobrancaTotal", "Cancelamento")



# Renomeando as colunas
colnames(telco) <- novos_nomes

DT::datatable(telco)

## Warning in instance$preRenderHook(instance): It seems your data is too big for
## client-side DataTables. You may consider server-side processing:
## https://rstudio.github.io/DT/server.html

Contagem de NAs

colSums(is.na(telco))

##             IDCliente                Genero                 Idoso 
##                     0                     0                     0 
##              Parceiro           Dependentes                 Tempo 
##                     0                     0                     0 
##       ServicoTelefone       MultiplasLinhas       ServicoInternet 
##                     0                     0                     0 
##       SegurancaOnline          BackupOnline   ProtecaoDispositivo 
##                     0                     0                     0 
##        SuporteTecnico           StreamingTV       StreamingFilmes 
##                     0                     0                     0 
##              Contrato FaturamentoEletronico       MetodoPagamento 
##                     0                     0                     0 
##        CobrancaMensal         CobrancaTotal          Cancelamento 
##                     0                    11                     0

% NA nos dados

Porcentagem de valores ausentes em cada variável do conjunto de dados. A variável “TotalCharges” tem a maior proporção de valores ausentes, cerca de 0,15%. Todas as outras variáveis têm uma porcentagem muito pequena de valores ausentes, menos de 0,01%.

options(repr.plot.width = 6, repr.plot.height = 4)
missing_data <- telco %>% summarise_all(funs(sum(is.na(.))/n()))

## Warning: `funs()` was deprecated in dplyr 0.8.0.
## ℹ Please use a list of either functions or lambdas:
## 
## # Simple named list: list(mean = mean, median = median)
## 
## # Auto named with `tibble::lst()`: tibble::lst(mean, median)
## 
## # Using lambdas list(~ mean(., trim = .2), ~ median(., na.rm = TRUE))
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

missing_data <- gather(missing_data, key = "variables", value = "percent_missing")
ggplot(missing_data, aes(x = reorder(variables, percent_missing), y = percent_missing)) +
  geom_bar(stat = "identity", fill = "red", aes(color = I('white')), size = 0.3)+
  xlab('variables')+
  coord_flip()+ 
  theme_bw()

## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

Este gráfico mostra a porcentagem de valores ausentes em cada variável do conjunto de dados. A variável CobraçaTotal tem a maior proporção de valores ausentes, cerca de 0,15%. Todas as outras variáveis têm uma porcentagem muito pequena de valores ausentes, menos de 0,01%.

Além disso existe 3 variaveis continuas, CobraçaTotal,CobraçaMensal,Tempo E Idoso. Proximo passo é limpar os NA e

Tratamento Dados

Tirando as linhas que possuem os valores NA e mudando a coluna SeniorCitizen

telco <- telco[complete.cases(telco),]

telco$Idoso <- as.factor(ifelse(telco$Idoso==1, "Yes", "No"))
colSums(is.na(telco))

##             IDCliente                Genero                 Idoso 
##                     0                     0                     0 
##              Parceiro           Dependentes                 Tempo 
##                     0                     0                     0 
##       ServicoTelefone       MultiplasLinhas       ServicoInternet 
##                     0                     0                     0 
##       SegurancaOnline          BackupOnline   ProtecaoDispositivo 
##                     0                     0                     0 
##        SuporteTecnico           StreamingTV       StreamingFilmes 
##                     0                     0                     0 
##              Contrato FaturamentoEletronico       MetodoPagamento 
##                     0                     0                     0 
##        CobrancaMensal         CobrancaTotal          Cancelamento 
##                     0                     0                     0

3. Tratamento dos dados

Inicialmente: Limpeza dados Categoricos Padronizacao dos dados Continuos Criação de dados derivados Criação de dados para variaveis Fator Criação do conjunto de dados Final Treinamento e Validação Limpeza das variaveis no modelo

Apartir das infomações acima, existem algumas colunas que tem como resposta No, e Sem serviço de Internet ou Sem serviço Telefonico Transformaremos todas em No e limpar os dados.

valores_unicos <- lapply(telco[, c(2:5,7:18,21)], unique)
valores_unicos

## $Genero
## [1] "Female" "Male"  
## 
## $Idoso
## [1] No  Yes
## Levels: No Yes
## 
## $Parceiro
## [1] "Yes" "No" 
## 
## $Dependentes
## [1] "No"  "Yes"
## 
## $ServicoTelefone
## [1] "No"  "Yes"
## 
## $MultiplasLinhas
## [1] "No phone service" "No"               "Yes"             
## 
## $ServicoInternet
## [1] "DSL"         "Fiber optic" "No"         
## 
## $SegurancaOnline
## [1] "No"                  "Yes"                 "No internet service"
## 
## $BackupOnline
## [1] "Yes"                 "No"                  "No internet service"
## 
## $ProtecaoDispositivo
## [1] "No"                  "Yes"                 "No internet service"
## 
## $SuporteTecnico
## [1] "No"                  "Yes"                 "No internet service"
## 
## $StreamingTV
## [1] "No"                  "Yes"                 "No internet service"
## 
## $StreamingFilmes
## [1] "No"                  "Yes"                 "No internet service"
## 
## $Contrato
## [1] "Month-to-month" "One year"       "Two year"      
## 
## $FaturamentoEletronico
## [1] "Yes" "No" 
## 
## $MetodoPagamento
## [1] "Electronic check"          "Mailed check"             
## [3] "Bank transfer (automatic)" "Credit card (automatic)"  
## 
## $Cancelamento
## [1] "No"  "Yes"

Tranformando em No as Variaveis

telco <- data.frame(lapply(telco, function(x) {
                  gsub("No internet service", "No", x)}))

telco <- data.frame(lapply(telco, function(x) {
                  gsub("No phone service", "No", x)}))

valores_unicos <- lapply(telco[, c(2:5,7:18,21)], unique)
valores_unicos

## $Genero
## [1] "Female" "Male"  
## 
## $Idoso
## [1] "No"  "Yes"
## 
## $Parceiro
## [1] "Yes" "No" 
## 
## $Dependentes
## [1] "No"  "Yes"
## 
## $ServicoTelefone
## [1] "No"  "Yes"
## 
## $MultiplasLinhas
## [1] "No"  "Yes"
## 
## $ServicoInternet
## [1] "DSL"         "Fiber optic" "No"         
## 
## $SegurancaOnline
## [1] "No"  "Yes"
## 
## $BackupOnline
## [1] "Yes" "No" 
## 
## $ProtecaoDispositivo
## [1] "No"  "Yes"
## 
## $SuporteTecnico
## [1] "No"  "Yes"
## 
## $StreamingTV
## [1] "No"  "Yes"
## 
## $StreamingFilmes
## [1] "No"  "Yes"
## 
## $Contrato
## [1] "Month-to-month" "One year"       "Two year"      
## 
## $FaturamentoEletronico
## [1] "Yes" "No" 
## 
## $MetodoPagamento
## [1] "Electronic check"          "Mailed check"             
## [3] "Bank transfer (automatic)" "Credit card (automatic)"  
## 
## $Cancelamento
## [1] "No"  "Yes"

head(telco)

##    IDCliente Genero Idoso Parceiro Dependentes Tempo ServicoTelefone
## 1 7590-VHVEG Female    No      Yes          No     1              No
## 2 5575-GNVDE   Male    No       No          No    34             Yes
## 3 3668-QPYBK   Male    No       No          No     2             Yes
## 4 7795-CFOCW   Male    No       No          No    45              No
## 5 9237-HQITU Female    No       No          No     2             Yes
## 6 9305-CDSKC Female    No       No          No     8             Yes
##   MultiplasLinhas ServicoInternet SegurancaOnline BackupOnline
## 1              No             DSL              No          Yes
## 2              No             DSL             Yes           No
## 3              No             DSL             Yes          Yes
## 4              No             DSL             Yes           No
## 5              No     Fiber optic              No           No
## 6             Yes     Fiber optic              No           No
##   ProtecaoDispositivo SuporteTecnico StreamingTV StreamingFilmes       Contrato
## 1                  No             No          No              No Month-to-month
## 2                 Yes             No          No              No       One year
## 3                  No             No          No              No Month-to-month
## 4                 Yes            Yes          No              No       One year
## 5                  No             No          No              No Month-to-month
## 6                 Yes             No         Yes             Yes Month-to-month
##   FaturamentoEletronico           MetodoPagamento CobrancaMensal CobrancaTotal
## 1                   Yes          Electronic check          29.85         29.85
## 2                    No              Mailed check          56.95        1889.5
## 3                   Yes              Mailed check          53.85        108.15
## 4                    No Bank transfer (automatic)           42.3       1840.75
## 5                   Yes          Electronic check           70.7        151.65
## 6                   Yes          Electronic check          99.65         820.5
##   Cancelamento
## 1           No
## 2           No
## 3          Yes
## 4           No
## 5          Yes
## 6          Yes

Grafico clientes-Sobrevivencia

library(ggplot2)

head(telco[,c(1,6,21)])

##    IDCliente Tempo Cancelamento
## 1 7590-VHVEG     1           No
## 2 5575-GNVDE    34           No
## 3 3668-QPYBK     2          Yes
## 4 7795-CFOCW    45           No
## 5 9237-HQITU     2          Yes
## 6 9305-CDSKC     8          Yes

telco$Tempo=as.numeric(telco$Tempo)

attach(telco)

ggplot(telco[1:20,], aes(x = 0, xend = Tempo, y = IDCliente, yend = IDCliente)) +geom_segment(size = 1) + # Adiciona segmentos de linha para cada cliente
  theme(axis.text.y = element_text(angle = 0, hjust = 1)) + # Ajusta os rótulos do eixo y para melhor visualização
  labs(x = "Tempo", y = "ID do Cliente", title = "Linha do Tempo dos Clientes-Primeiros 20 cliente") + 
  theme_minimal()

KM-Sobrevivencia

attach(telco)

## Os seguintes objetos são mascarados por telco (pos = 3):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

library(survival)

## 
## Anexando pacote: 'survival'

## O seguinte objeto é mascarado por 'package:caret':
## 
##     cluster

telco$Cancelamento=ifelse(telco$Cancelamento=="Yes",1,0)

km_Tel <- survfit(Surv(telco$Tempo, telco$Cancelamento) ~ 1, data = telco)

plot(km_Tel, main="Kaplan-Meier",
       xlab = "Tempos", ylab = "S(t) estimada", 
       mark.time = TRUE, col=c(4,2))

Taxa Churn no Tempo

options(repr.plot.width = 6, repr.plot.height = 4)

telco %>% 
group_by(Cancelamento) %>% 
summarise(Count = n())%>% 
mutate(percent = prop.table(Count)*100)%>%
ggplot(aes(reorder(Cancelamento, -percent), percent), fill = Cancelamento)+
geom_col(fill = c("#b0b0b0", "#E7B800"))+
geom_text(aes(label = sprintf("%.2f%%", percent)), hjust = 0.01,vjust = -0.5, size =3)+ 
theme_bw()+  
xlab("Churn") + 
ylab("Percentual")+
ggtitle("Censura percentual 1-Sim e 0-Nao")

Distribuicao binomial

telco$Cancelamento=ifelse(telco$Cancelamento==1,"Yes","No")

frequencias <- table(telco$Cancelamento)
print(frequencias)

## 
##   No  Yes 
## 5163 1869

# Calcule a proporção de "Yes"
proporcao_sucessos <- frequencias["Yes"] / sum(frequencias)
proporcao_sucessos <- unname(proporcao_sucessos["Yes"])
print(proporcao_sucessos)

## [1] 0.265785

# Frequências observadas
observadas <- as.numeric(frequencias)

# Número total de observações
n_total <- sum(observadas)

# Frequências esperadas para uma distribuição binomial
# Vamos assumir um número de ensaios adequado (ex. n_total)
probabilidade_sucesso <- proporcao_sucessos
p=proporcao_sucessos
frequencias_esperadas <- c((1 - p) * n_total, p * n_total)
probabilidades <- c(1 - p, p)
# Teste qui-quadrado
teste_qui_quadrado <- chisq.test(observadas, p = probabilidades)

# Resultados do teste
print(teste_qui_quadrado)

## 
##  Chi-squared test for given probabilities
## 
## data:  observadas
## X-squared = 1.6021e-28, df = 1, p-value = 1

A variável Cancelamento parece seguir uma distribuição binomial

Resumo dados

summary(telco)

##   IDCliente            Genero             Idoso             Parceiro        
##  Length:7032        Length:7032        Length:7032        Length:7032       
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character  
##                                                                             
##                                                                             
##                                                                             
##  Dependentes            Tempo       ServicoTelefone    MultiplasLinhas   
##  Length:7032        Min.   : 1.00   Length:7032        Length:7032       
##  Class :character   1st Qu.: 9.00   Class :character   Class :character  
##  Mode  :character   Median :29.00   Mode  :character   Mode  :character  
##                     Mean   :32.42                                        
##                     3rd Qu.:55.00                                        
##                     Max.   :72.00                                        
##  ServicoInternet    SegurancaOnline    BackupOnline       ProtecaoDispositivo
##  Length:7032        Length:7032        Length:7032        Length:7032        
##  Class :character   Class :character   Class :character   Class :character   
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character   
##                                                                              
##                                                                              
##                                                                              
##  SuporteTecnico     StreamingTV        StreamingFilmes      Contrato        
##  Length:7032        Length:7032        Length:7032        Length:7032       
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character  
##                                                                             
##                                                                             
##                                                                             
##  FaturamentoEletronico MetodoPagamento    CobrancaMensal     CobrancaTotal     
##  Length:7032           Length:7032        Length:7032        Length:7032       
##  Class :character      Class :character   Class :character   Class :character  
##  Mode  :character      Mode  :character   Mode  :character   Mode  :character  
##                                                                                
##                                                                                
##                                                                                
##  Cancelamento      
##  Length:7032       
##  Class :character  
##  Mode  :character  
##                    
##                    
## 

Tempo

telco=subset(telco,telco$Tempo>0)

table(telco$Tempo)

## 
##   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15  16  17  18  19  20 
## 613 238 200 176 133 110 131 123 119 116  99 117 109  76  99  80  87  97  73  71 
##  21  22  23  24  25  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40 
##  63  90  85  94  79  79  72  57  72  72  65  69  64  65  88  50  65  59  56  64 
##  41  42  43  44  45  46  47  48  49  50  51  52  53  54  55  56  57  58  59  60 
##  70  65  65  51  61  74  68  64  66  68  68  80  70  68  64  80  65  67  60  76 
##  61  62  63  64  65  66  67  68  69  70  71  72 
##  76  70  72  80  76  89  98 100  95 119 170 362

summary(telco$Tempo)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    1.00    9.00   29.00   32.42   55.00   72.00

# Frequências observadas
frequencias_observadas <- table(telco$Tempo)

# Proporções
proporcoes <- prop.table(frequencias_observadas)*100

# Criar um data frame para plotagem
resultados <- data.frame(
  Valor = names(frequencias_observadas),
  Frequencia = as.numeric(frequencias_observadas),
  Proporcao = as.numeric(proporcoes)
)

# Calcular porcentagens acumuladas
resultados$Porcentagem_Acumulada <- cumsum(resultados$Proporcao)


DT::datatable(resultados)

boxplot(telco$Tempo, 
        main = "Boxplot de Tempo", 
        ylab = "Tenure", 
        col = "lightblue", 
        border = "blue",
        ylim = c(0, 72))  # Define o limite do eixo y de 0 a 72

seq_y <- seq(0, 72, by = 5)
for (i in seq_y) {
  abline(h = i, col = "gray", lty = 2)  # Adiciona linha horizontal com cor cinza e estilo pontilhado
}

summary(telco$Tempo)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    1.00    9.00   29.00   32.42   55.00   72.00

var(telco$Tempo)

## [1] 602.4698

hist(telco$Tempo, main = "Histograma da Variável Tempo")

Metade dos contratos tem menos de 28 meses e a outra metade tem mais; Mediana de 29 e media de 32 meses; e em Média os dados se dispersam em 25 meses; Max de 72; Isso sugere que há alguns valores altos que estão puxando a média para cima; A alta variância indica que há uma grande dispersão nos tempos de contrato

2. Analise Exploratoria dos Dados

Criando Temas

theme1 <- theme_bw()+theme(axis.text.x = element_text(angle = 0, hjust = 1, vjust = 0.5),legend.position="none")
theme2 <- theme_bw()+theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5),legend.position="none")


glimpse(telco)

## Rows: 7,032
## Columns: 21
## $ IDCliente             <chr> "7590-VHVEG", "5575-GNVDE", "3668-QPYBK", "7795-…
## $ Genero                <chr> "Female", "Male", "Male", "Male", "Female", "Fem…
## $ Idoso                 <chr> "No", "No", "No", "No", "No", "No", "No", "No", …
## $ Parceiro              <chr> "Yes", "No", "No", "No", "No", "No", "No", "No",…
## $ Dependentes           <chr> "No", "No", "No", "No", "No", "No", "Yes", "No",…
## $ Tempo                 <dbl> 1, 34, 2, 45, 2, 8, 22, 10, 28, 62, 13, 16, 58, …
## $ ServicoTelefone       <chr> "No", "Yes", "Yes", "No", "Yes", "Yes", "Yes", "…
## $ MultiplasLinhas       <chr> "No", "No", "No", "No", "No", "Yes", "Yes", "No"…
## $ ServicoInternet       <chr> "DSL", "DSL", "DSL", "DSL", "Fiber optic", "Fibe…
## $ SegurancaOnline       <chr> "No", "Yes", "Yes", "Yes", "No", "No", "No", "Ye…
## $ BackupOnline          <chr> "Yes", "No", "Yes", "No", "No", "No", "Yes", "No…
## $ ProtecaoDispositivo   <chr> "No", "Yes", "No", "Yes", "No", "Yes", "No", "No…
## $ SuporteTecnico        <chr> "No", "No", "No", "Yes", "No", "No", "No", "No",…
## $ StreamingTV           <chr> "No", "No", "No", "No", "No", "Yes", "Yes", "No"…
## $ StreamingFilmes       <chr> "No", "No", "No", "No", "No", "Yes", "No", "No",…
## $ Contrato              <chr> "Month-to-month", "One year", "Month-to-month", …
## $ FaturamentoEletronico <chr> "Yes", "No", "Yes", "No", "Yes", "Yes", "Yes", "…
## $ MetodoPagamento       <chr> "Electronic check", "Mailed check", "Mailed chec…
## $ CobrancaMensal        <chr> "29.85", "56.95", "53.85", "42.3", "70.7", "99.6…
## $ CobrancaTotal         <chr> "29.85", "1889.5", "108.15", "1840.75", "151.65"…
## $ Cancelamento          <chr> "No", "No", "Yes", "No", "Yes", "Yes", "No", "No…

% das variaveis Categoricas em relacao ao Churn

options(repr.plot.width = 6, repr.plot.height = 4)
telco %>% 
  group_by(Cancelamento) %>% 
  summarise(Count = n())%>% 
  mutate(percent = prop.table(Count)*100)%>%
  ggplot(aes(reorder(Cancelamento, -percent), percent), fill = Cancelamento)+
  geom_col(fill = c("#FC4E07", "#E7B800"))+
  geom_text(aes(label = sprintf("%.2f%%", percent)), hjust = 0.01,vjust = -0.5, size =3)+ 
  theme_bw()+  
  xlab("Cancelamento") + 
  ylab("Percentual")+
  ggtitle("Cancelamento Percentual")

Temos do Churn que cerca de 26% dos clientes deixaram a plataforma no ultimo mês.

% Churn pela Categoricas

attach(telco)

## Os seguintes objetos são mascarados por telco (pos = 4):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

## Os seguintes objetos são mascarados por telco (pos = 5):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

options(repr.plot.width = 12, repr.plot.height = 8)
plot_grid(ggplot(telco, aes(x=Genero,fill=Cancelamento))+ geom_bar()+ theme1, 
          ggplot(telco, aes(x=Idoso,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1,
          ggplot(telco, aes(x=Parceiro,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1,
          ggplot(telco, aes(x=Dependentes,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1,
          ggplot(telco, aes(x=ServicoTelefone,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1,
          ggplot(telco, aes(x=MultiplasLinhas,fill=Cancelamento))+ geom_bar(position = 'fill')+theme_bw()+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          align = "h")

options(repr.plot.width = 12, repr.plot.height = 8)
plot_grid(ggplot(telco, aes(x=ServicoInternet,fill=Cancelamento))+ geom_bar(position = 'fill')+ theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)), 
          ggplot(telco, aes(x=SegurancaOnline,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          ggplot(telco, aes(x=BackupOnline,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          ggplot(telco, aes(x=ProtecaoDispositivo,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          ggplot(telco, aes(x=SuporteTecnico,fill=Cancelamento))+ geom_bar(position = 'fill')+theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          ggplot(telco, aes(x=StreamingTV,fill=Cancelamento))+ geom_bar(position = 'fill')+theme_bw()+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          align = "h")

plot_grid(ggplot(telco, aes(x=StreamingFilmes,fill=Cancelamento))+ 
          geom_bar(position = 'fill')+ theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)), 
          ggplot(telco, aes(x=Contrato,fill=Cancelamento))+ 
          geom_bar(position = 'fill')+theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          ggplot(telco, aes(x=FaturamentoEletronico,fill=Cancelamento))+ 
          geom_bar(position = 'fill')+theme1+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          ggplot(telco, aes(x=MetodoPagamento,fill=Cancelamento))+
          geom_bar(position = 'fill')+theme_bw()+
          scale_x_discrete(labels = function(x) str_wrap(x, width = 10)),
          align = "h")

Observações para o churn no ultimo mes:

-Para o sexo masculino e feminino é quase igual -É maior para os clientes que sao idosos -Clientes com parceiros e dependentes a taxa é menor -Para o tipo de serviço em que o cliente usa Fibra Otica a taxa é maior -Cliente que mais sairam no ultimo mes sao aqueles que nao possuem Segurança Online, Backup Online, Protecao de Dispositivo e Suporte Tecnico -Clientes que possuem o contrato mensal cancelaram mais do que os outros tipos de contratos -Clientes que recebem o boleto de pagamento online tem a taxa maior do que os que não recebem -Cliente que usam o debio em conta tem a maior taxa

options(repr.plot.width =6, repr.plot.height = 2)
ggplot(telco, aes(y= Tempo, x = "", fill = Cancelamento)) + 
geom_boxplot()+ 
theme_bw()+
xlab(" ")

-O tempo mediano para quem cancelou no ultimo mes é de 10 meses

telco$CobrancaMensal <- as.numeric(telco$CobrancaMensal)
telco$CobrancaTotal <- as.numeric(telco$CobrancaTotal)



ggplot(telco, aes(y= CobrancaMensal, x = "", fill = Cancelamento)) + 
geom_boxplot()+ 
theme_bw()+
xlab(" ")

-Clientes que cancelaram possuem a mediana de pagamento de 75 mensalmente

ggplot(telco, aes(y= CobrancaTotal, x = "", fill = Cancelamento)) + 
geom_boxplot()+ 
theme_bw()+
xlab(" ")

A mediana dos cutos totais dos que cancelaram no ultimo mes é relativamente baixa

Correlacao dos dados continuos

options(repr.plot.width =6, repr.plot.height = 4)
telco_cor <- round(cor(telco[,c("Tempo","CobrancaMensal","CobrancaTotal")]), 1)
telco_cor 

##                Tempo CobrancaMensal CobrancaTotal
## Tempo            1.0            0.2           0.8
## CobrancaMensal   0.2            1.0           0.7
## CobrancaTotal    0.8            0.7           1.0

ggcorrplot(telco_cor,  title = "Correlation")+theme(plot.title = element_text(hjust = 0.5))

Observe que a correlacao entre o pagamento total é positiva entre o tempo e os custos mensais

options(repr.plot.width =4, repr.plot.height = 4)
boxplot(telco$Tempo,xlab="Tempo")$out

## numeric(0)

boxplot(telco$CobrancaMensal,xlab="CobrancaMental")$out

## numeric(0)

boxplot(telco$CobrancaTotal,xlab="CobbrancaTotal")$out

## numeric(0)

Observe que nao se tem dado Outliers nas variaveis Continuas

num_columns <- c("Tempo", "CobrancaMensal", "CobrancaTotal")
telco[num_columns] <- sapply(telco[num_columns], as.numeric)

Padronizacao dos dados Continuos

num_columns <- c("Tempo", "CobrancaMensal", "CobrancaTotal")
telco[num_columns] <- sapply(telco[num_columns], as.numeric)

telco_int <- telco[,c("Tempo","CobrancaMensal", "CobrancaTotal")]

head(telco_int)

##   Tempo CobrancaMensal CobrancaTotal
## 1     1          29.85         29.85
## 2    34          56.95       1889.50
## 3     2          53.85        108.15
## 4    45          42.30       1840.75
## 5     2          70.70        151.65
## 6     8          99.65        820.50

Criando Categoria Tempo

telco <- telco %>%
  mutate(Categoria_Tempo = cut(Tempo,
breaks = c(0, 12, 24, 36, 48, 60, 72),
labels = c('1 ano', '1-2 anos', '2-3 anos', '3-4 anos', '4-5 anos', '5-6 anos')))

# Convertendo para fator
telco$Categoria_Tempo <- as.factor(telco$Categoria_Tempo)


DT::datatable(telco)

## Warning in instance$preRenderHook(instance): It seems your data is too big for
## client-side DataTables. You may consider server-side processing:
## https://rstudio.github.io/DT/server.html

attach(telco)

## Os seguintes objetos são mascarados por telco (pos = 3):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

## Os seguintes objetos são mascarados por telco (pos = 5):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

## Os seguintes objetos são mascarados por telco (pos = 6):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

library(plotly)

## 
## Anexando pacote: 'plotly'

## O seguinte objeto é mascarado por 'package:MASS':
## 
##     select

## O seguinte objeto é mascarado por 'package:ggplot2':
## 
##     last_plot

## O seguinte objeto é mascarado por 'package:stats':
## 
##     filter

## O seguinte objeto é mascarado por 'package:graphics':
## 
##     layout

plot_ly(telco, labels = ~ Categoria_Tempo, type = 'pie')

options(repr.plot.width =6, repr.plot.height = 3)
ggplot(telco, aes(Categoria_Tempo, fill = Categoria_Tempo)) + geom_bar()+ theme1

Os clientes estao concentrado em duas faixa de tempo de contrato: 0 até 1 ano e 5 a 6 anos

attach(telco)

## Os seguintes objetos são mascarados por telco (pos = 4):
## 
##     BackupOnline, Cancelamento, Categoria_Tempo, CobrancaMensal,
##     CobrancaTotal, Contrato, Dependentes, FaturamentoEletronico,
##     Genero, IDCliente, Idoso, MetodoPagamento, MultiplasLinhas,
##     Parceiro, ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

## Os seguintes objetos são mascarados por telco (pos = 5):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

## Os seguintes objetos são mascarados por telco (pos = 7):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

## Os seguintes objetos são mascarados por telco (pos = 8):
## 
##     BackupOnline, Cancelamento, CobrancaMensal, CobrancaTotal,
##     Contrato, Dependentes, FaturamentoEletronico, Genero, IDCliente,
##     Idoso, MetodoPagamento, MultiplasLinhas, Parceiro,
##     ProtecaoDispositivo, SegurancaOnline, ServicoInternet,
##     ServicoTelefone, StreamingFilmes, StreamingTV, SuporteTecnico,
##     Tempo

library(plotly)
plot_ly(telco, labels = ~ Contrato, type = 'pie')

options(repr.plot.width =6, repr.plot.height = 3)
ggplot(telco, aes(Contrato, fill = Contrato)) + geom_bar()+ theme1

unique(Contrato)

## [1] "Month-to-month" "One year"       "Two year"

Criando Variaveis Indicadores para Categoricas

telco_cat <- telco[,-c(6,19,20)]

dummy<- data.frame(lapply(telco_cat, as.factor))

DataFrame Final

telco <- cbind(telco_int,dummy)
telco$Cancelamento=as.factor(telco$Cancelamento)

Treino e Teste

telco$Cancelamento=as.factor(telco$Cancelamento)

library(caTools)

set.seed(123)
indices <- sample.split(telco$Cancelamento, SplitRatio = 0.7)
train <- telco[indices, ]
validation <- telco[!indices, ]


train=train[,-4]
validation=validation[,-4]

Modelo 1

Modelo Geral

model_1 = glm(train$Cancelamento ~ ., data = train, family = binomial(link = "logit"))

Usando Step AIC

Com o step AIC iremos escolher as melhores variaveis para o melhor modelo

#Modelo 2

Modelo stepAIC

Resumo Modelo 2

model_2=glm(formula = Cancelamento ~ Tempo + CobrancaMensal + Idoso + 
    ServicoTelefone + MultiplasLinhas + ServicoInternet + BackupOnline + 
    ProtecaoDispositivo + StreamingTV + StreamingFilmes + Contrato + 
    FaturamentoEletronico + MetodoPagamento + Categoria_Tempo, 
    family = binomial(link = "logit"), data = train)

summary( model_2)

## 
## Call:
## glm(formula = Cancelamento ~ Tempo + CobrancaMensal + Idoso + 
##     ServicoTelefone + MultiplasLinhas + ServicoInternet + BackupOnline + 
##     ProtecaoDispositivo + StreamingTV + StreamingFilmes + Contrato + 
##     FaturamentoEletronico + MetodoPagamento + Categoria_Tempo, 
##     family = binomial(link = "logit"), data = train)
## 
## Coefficients:
##                                        Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                             1.77247    0.40356   4.392 1.12e-05 ***
## Tempo                                  -0.09241    0.01169  -7.904 2.71e-15 ***
## CobrancaMensal                         -0.06574    0.01338  -4.913 8.99e-07 ***
## IdosoYes                                0.36992    0.10031   3.688 0.000226 ***
## ServicoTelefoneYes                      0.94396    0.31615   2.986 0.002828 ** 
## MultiplasLinhasYes                      0.63050    0.11673   5.401 6.61e-08 ***
## ServicoInternetFiber optic              2.49005    0.33675   7.394 1.42e-13 ***
## ServicoInternetNo                      -2.63286    0.40977  -6.425 1.32e-10 ***
## BackupOnlineYes                         0.21694    0.11512   1.885 0.059489 .  
## ProtecaoDispositivoYes                  0.35501    0.11808   3.007 0.002643 ** 
## StreamingTVYes                          0.93766    0.16648   5.632 1.78e-08 ***
## StreamingFilmesYes                      0.89947    0.16562   5.431 5.61e-08 ***
## ContratoOne year                       -0.70050    0.12967  -5.402 6.59e-08 ***
## ContratoTwo year                       -1.68273    0.23173  -7.262 3.82e-13 ***
## FaturamentoEletronicoYes                0.38932    0.09053   4.301 1.70e-05 ***
## MetodoPagamentoCredit card (automatic) -0.04711    0.13698  -0.344 0.730885    
## MetodoPagamentoElectronic check         0.25508    0.11362   2.245 0.024768 *  
## MetodoPagamentoMailed check            -0.06266    0.13769  -0.455 0.649026    
## Categoria_Tempo1-2 anos                 0.13127    0.19060   0.689 0.491012    
## Categoria_Tempo2-3 anos                 0.97404    0.31427   3.099 0.001939 ** 
## Categoria_Tempo3-4 anos                 1.99310    0.44523   4.477 7.59e-06 ***
## Categoria_Tempo4-5 anos                 2.88379    0.57841   4.986 6.17e-07 ***
## Categoria_Tempo5-6 anos                 3.74847    0.71853   5.217 1.82e-07 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 5699.5  on 4921  degrees of freedom
## Residual deviance: 3988.0  on 4899  degrees of freedom
## AIC: 4034
## 
## Number of Fisher Scoring iterations: 6

MULTICOLINEARIDADE

library(car)
vif(model_2)

##                            GVIF Df GVIF^(1/(2*Df))
## Tempo                 39.314335  1        6.270114
## CobrancaMensal        83.252283  1        9.124269
## Idoso                  1.099051  1        1.048356
## ServicoTelefone        5.916309  1        2.432346
## MultiplasLinhas        2.165843  1        1.471680
## ServicoInternet       44.492207  2        2.582682
## BackupOnline           1.885703  1        1.373209
## ProtecaoDispositivo    1.974924  1        1.405320
## StreamingTV            4.342736  1        2.083923
## StreamingFilmes        4.336961  1        2.082537
## Contrato               1.714739  2        1.144325
## FaturamentoEletronico  1.126871  1        1.061542
## MetodoPagamento        1.399229  3        1.057584
## Categoria_Tempo       41.559587  5        1.451667

Removendo

CobrancaMensal CobrancaTotal Categoria_Tempo

model_2=glm(formula = Cancelamento ~ Tempo + Idoso + 
    ServicoTelefone + MultiplasLinhas + ServicoInternet + BackupOnline + 
    ProtecaoDispositivo + StreamingTV + StreamingFilmes + Contrato + 
    FaturamentoEletronico + MetodoPagamento, 
    family = binomial(link = "logit"), data = train)

library(car)
vif(model_2)

##                           GVIF Df GVIF^(1/(2*Df))
## Tempo                 2.051899  1        1.432445
## Idoso                 1.086695  1        1.042447
## ServicoTelefone       1.392930  1        1.180224
## MultiplasLinhas       1.441062  1        1.200442
## ServicoInternet       2.097860  2        1.203494
## BackupOnline          1.183903  1        1.088073
## ProtecaoDispositivo   1.253554  1        1.119622
## StreamingTV           1.449552  1        1.203973
## StreamingFilmes       1.441859  1        1.200775
## Contrato              1.490932  2        1.105006
## FaturamentoEletronico 1.118965  1        1.057812
## MetodoPagamento       1.354376  3        1.051857

pacotes

library(car)           # Para multicolinearidade e análises de influência
library(ResourceSelection)  # Para teste de Hosmer-Lemeshow

## ResourceSelection 0.3-6   2023-06-27

library(pscl)          # Para Pseudo-R²

## Classes and Methods for R originally developed in the
## Political Science Computational Laboratory
## Department of Political Science
## Stanford University (2002-2015),
## by and under the direction of Simon Jackman.
## hurdle and zeroinfl functions by Achim Zeileis.

library(splines)

Verificar independência dos observações

car::durbinWatsonTest(model_2)

##  lag Autocorrelation D-W Statistic p-value
##    1     -0.02399829      2.047614   0.102
##  Alternative hypothesis: rho != 0

Como o p-valor é maior que 0.05, não temos evidências estatísticas para rejeitar a hipótese nula, sugerindo que não há autocorrelação significativa nos resíduos. Com base na estatística de Durbin-Watson e no p-valor, não há indícios de autocorrelação significativa nos resíduos do modelo. Isso sugere que os resíduos são aproximadamente independentes, o que é uma condição desejável para garantir a validade das inferências no modelo de regressão.

RESIDUOS MODELO 2

Resíduos de Pearson e Deviance

pearson=residuals(model_2, type = "pearson")
deviance=residuals(model_2, type = "deviance")


# Crie o gráfico de resíduos de deviance
plot(deviance, pch = 16, main = "Gráfico de Resíduos de Deviance", xlab = "Observações", ylab = "Resíduos de Deviance")
abline(h = 0, col = "red")

# Crie o gráfico de resíduos de pearson
plot(pearson, pch = 16, main = "Gráfico de Resíduos de Pearson", xlab = "Observações", ylab = "Resíduos de Pearson")
abline(h = 0, col = "red")

Identificação de Pontos Influentes

cooksD <- cooks.distance(model_2)
summary(cooksD)

##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
## 2.800e-08 5.246e-06 6.090e-05 2.017e-04 2.440e-04 4.251e-03

plot(cooksD, main = "Distância de Cook", ylab = "Distância de Cook")
abline(h = 4/(nrow(train) - length(coef(model_2))), col = "red", lty = 2)

Leverage (hii) Plot para Detecção de Observações Alavanca

leverage <- hatvalues(model_2)
summary(leverage)

##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
## 0.0001851 0.0018509 0.0033387 0.0034539 0.0048901 0.0127110

plot(leverage, main = "Valores de Leverage (hii)", ylab = "Leverage")
abline(h = 2 * mean(leverage), col = "red", lty = 2)

Gráfico de Resíduos Padronizados

plot(rstandard(model_2), main = "Resíduos Padronizados", ylab = "Resíduo Padronizado")
abline(h = c(-2, 2), col = "red", lty = 2)

Graficos Envelope

set.seed(2000)
require(hnp)

## Carregando pacotes exigidos: hnp

hnp(model_2,print.on = T,pch=19,cex=1.0)

## Binomial model

# Observe que tem apenas um ponto fora do envelope, o modelo é bem ajustado

Este QQ plot indica que os resíduos do modelo seguem bem a distribuição teórica esperada. Isso sugere que o modelo ajustado é apropriado em termos de aderência dos resíduos, um bom sinal de ajuste do modelo.

##Verificação Adequação Geral do modelo

O teste de Hosmer-Lemeshow, que é um teste estatístico de bondade de ajuste aplicado em modelos de regressão logística.

Hipóteses do Teste:

H0 (hipótese nula): Não há diferença significativa entre os valores previstos pelo modelo e os valores observados. Ou seja, o modelo se ajusta bem aos dados.

H1 (hipótese alternativa): Existe uma diferença significativa entre os valores previstos e observados. Portanto, o modelo não se ajusta bem aos dados.

glmtoolbox:

O glmtoolbox é uma coleção de ferramentas adicionais para modelos lineares generalizados (GLM), incluindo o teste de Hosmer-Lemeshow.

#install.packages("glmtoolbox")

library(glmtoolbox)
hltest(model_2)

## 
##    The Hosmer-Lemeshow goodness-of-fit test
## 
##  Group Size Observed   Expected
##      1  493        3   3.531079
##      2  492       11  10.052221
##      3  492       21  22.105637
##      4  492       48  44.635475
##      5  492       81  75.215443
##      6  492      110 113.364747
##      7  492      167 163.482258
##      8  493      203 224.019817
##      9  492      295 291.886191
##     10  492      369 359.707133
## 
##          Statistic =  5.86621 
## degrees of freedom =  8 
##            p-value =  0.66222

O valor p do teste de Hosmer-Lemeshow é maior que 0,05 (0.66222), o que significa que não há evidências estatísticas para rejeitar a hipótese nula de que o modelo se ajusta bem aos dados. Em outras palavras, o modelo apresenta um ajuste aceitável em relação à variável resposta.

Avaliado o Modelo Dados Teste

Ponto de Corte 0.5

final_model=model_2
actual_churn <- validation$Cancelamento

pred <- predict(final_model, type = "response", newdata = validation[,-24])
summary(pred)

##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
## 0.002562 0.042666 0.190475 0.269132 0.464396 0.867405

validation$prob <- pred

# Using probability cutoff of 50%.

cutoff_churn <- factor(ifelse(pred >=0.50, "Yes", "No"))
conf_final <- caret::confusionMatrix(cutoff_churn, actual_churn, positive = "Yes")
accuracy <- conf_final$overall[1]
sensitivity <- conf_final$byClass[1]
specificity <- conf_final$byClass[2]
accuracy

##  Accuracy 
## 0.7990521

sensitivity

## Sensitivity 
##   0.5508021

specificity

## Specificity 
##   0.8889606

Como podemos ver acima, quando usamos um corte de 0,50, obtemos uma boa acuracia e especificidade, mas a sensibilidade é muito menor.

Portanto, precisamos encontrar o corte de probabilidade ideal que dará a máxima precisão, sensibilidade e especificidade

Curva ROC

Biblioteca: (pROC)

require(pROC)
roc1 <- roc(validation$Cancelamento, pred)

## Setting levels: control = No, case = Yes

## Setting direction: controls < cases

# Plote a curva ROC com as personalizações desejadas
plot(roc1,
     print.auc = TRUE,              # Exibe o AUC no gráfico
     auc.polygon = TRUE,            # Preenche a área sob a curva
     grid = c(0.1, 0.2),            # Define a densidade do grid
     grid.col = c("green", "red"),  # Define as cores do grid
     max.auc.polygon = TRUE,        # Preenche até o ponto máximo da curva
     auc.polygon.col = "lightgreen",# Cor do preenchimento da área sob a curva
     print.thres = TRUE)            # Exibe os pontos de corte no gráfico

Vamos escolher um valor de corte de 0,293 para o modelo final, onde as curvas de precisão, especificidade e sensibilidade se encontram e maximiza ambas.

Melhor Ponto de Corte

actual_churn <- validation$Cancelamento

# Previsões do modelo
pred <- predict(final_model, type = "response", newdata = validation[,-24])
validation$prob <- pred

cutoff_churn <- factor(ifelse(pred >=0.293, "Yes", "No"))
conf_final <- caret::confusionMatrix(cutoff_churn, actual_churn, positive = "Yes")
conf_final

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction   No  Yes
##        No  1145  126
##        Yes  404  435
##                                           
##                Accuracy : 0.7488          
##                  95% CI : (0.7297, 0.7672)
##     No Information Rate : 0.7341          
##     P-Value [Acc > NIR] : 0.06579         
##                                           
##                   Kappa : 0.4444          
##                                           
##  Mcnemar's Test P-Value : < 2e-16         
##                                           
##             Sensitivity : 0.7754          
##             Specificity : 0.7392          
##          Pos Pred Value : 0.5185          
##          Neg Pred Value : 0.9009          
##              Prevalence : 0.2659          
##          Detection Rate : 0.2062          
##    Detection Prevalence : 0.3976          
##       Balanced Accuracy : 0.7573          
##                                           
##        'Positive' Class : Yes             
## 

accuracy <- conf_final$overall[1]
sensitivity <- conf_final$byClass[1]
specificity <- conf_final$byClass[2]
accuracy

##  Accuracy 
## 0.7488152

sensitivity

## Sensitivity 
##   0.7754011

specificity

## Specificity 
##   0.7391866

A regressão logística com valor de probabilidade de corte de 0,256 nos fornece melhores valores de precisão, sensibilidade e especificidade nos dados de validação.

Acurácia (Accuracy): 74,88% isso indica a proporção de todas as previsões corretas feitas pelo modelo.

Sensibilidade (Sensitivity):A proporção de verdadeiros positivos (instâncias positivas corretamente previstas) em relação a todas as instâncias positivas reais. Neste caso, é 77,54%.

Especificidade (Specificity): A proporção de verdadeiros negativos (instâncias negativas corretamente previstas) em relação a todas as instâncias negativas reais. Neste caso, é 73,92%.

valores_unicos <- lapply(train[,c(5,8,9,10,12,13,15,16,17,18,19)], unique)
# Criação de uma tabela com as variáveis categóricas e seus níveis

# Dados das variáveis categóricas e níveis
categorias <- data.frame(
  Variavel = c("Idoso", "ServicoTelefone", "MultiplasLinhas", "ServicoInternet",
               "BackupOnline", "ProtecaoDispositivo", "StreamingTV", "StreamingFilmes",
               "Contrato", "FaturamentoEletronico", "MetodoPagamento"),
  Niveis = c("No, Yes",
             "No, Yes",
             "No, Yes",
             "DSL, Fiber optic, No",
             "No, Yes",
             "No, Yes",
             "No, Yes",
             "No, Yes",
             "Month-to-month, One year, Two year",
             "No, Yes",
             "Bank transfer (automatic), Credit card (automatic), Electronic check, Mailed check")
)


DT::datatable(categorias)

#REPRESENTACAO MATEMATICA

Para representar o modelo de regressão logística com o link logit, a fórmula matemática para a probabilidade de cancelamento \(p\) é dada por:

\[ p = \frac{1}{1 + e^{-(\beta_0 + \beta_1 X_1 + \beta_2 X_2 + \dots + \beta_n X_n)}} \]

onde:

Exemplo

##Cliente João tem as seguintes observações:

Tempo = 10 meses

Idoso = Yes

ServicoTelefone = Yes

MultiplasLinhas = Yes

ServicoInternet = Fiber optic

BackupOnline = No

ProtecaoDispositivo =No

StreamingTV = Yes

StreamingFilmes = No

Contrato = One year

FaturamentoEletronico = Yes

MetodoPagamento = Electronic check

final_model$coefficients

##                            (Intercept)                                  Tempo 
##                            -0.46557547                            -0.03670718 
##                               IdosoYes                     ServicoTelefoneYes 
##                             0.40057739                            -0.39326101 
##                     MultiplasLinhasYes             ServicoInternetFiber optic 
##                             0.24896363                             0.94164496 
##                      ServicoInternetNo                        BackupOnlineYes 
##                            -0.74263758                            -0.11692944 
##                 ProtecaoDispositivoYes                         StreamingTVYes 
##                            -0.01721924                             0.24968637 
##                     StreamingFilmesYes                       ContratoOne year 
##                             0.21495696                            -0.73288236 
##                       ContratoTwo year               FaturamentoEletronicoYes 
##                            -1.68905812                             0.38170335 
## MetodoPagamentoCredit card (automatic)        MetodoPagamentoElectronic check 
##                            -0.03091178                             0.33622045 
##            MetodoPagamentoMailed check 
##                             0.01954290

# Definindo os coeficientes do modelo
coef <- c(
  Intercept = -0.46557547,
  Tempo = -0.03670718,
  IdosoYes = 0.40057739,
  ServicoTelefoneYes = -0.39326101,
  MultiplasLinhasYes = 0.24896363,
  ServicoInternetFiberOptic = 0.94164496,
  ServicoInternetNo = -0.74263758,
  BackupOnlineYes = -0.11692944,
  ProtecaoDispositivoYes = -0.01721924,
  StreamingTVYes = 0.24968637,
  StreamingFilmesYes = 0.21495696,
  ContratoOneYear = -0.73288236,
  ContratoTwoYear = -1.68905812,
  FaturamentoEletronicoYes = 0.38170335,
  MetodoPagamentoCreditCardAutomatic = -0.03091178,
  MetodoPagamentoElectronicCheck = 0.33622045,
  MetodoPagamentoMailedCheck = 0.01954290
)

# Definindo os valores para o cliente João
joao <- c(
  1,                  # Intercept
  10,                 # Tempo
  1,                  # IdosoYes
  1,                  # ServicoTelefoneYes
  1,                  # MultiplasLinhasYes
  1,                  # ServicoInternetFiberOptic
  0,                  # ServicoInternetNo
  0,                  # BackupOnlineYes (não possui backup)
  0,                  # ProtecaoDispositivoYes (não possui proteção)
  1,                  # StreamingTVYes
  0,                  # StreamingFilmesYes (não possui streaming de filmes)
  1,                  # ContratoOneYear
  0,                  # ContratoTwoYear
  1,                  # FaturamentoEletronicoYes
  0,                  # MetodoPagamentoCreditCardAutomatic
  1,                  # MetodoPagamentoElectronicCheck
  0                   # MetodoPagamentoMailedCheck
)

# Calculando eta (soma ponderada das variáveis)
eta <- sum(coef * joao)

# Calculando a probabilidade de cancelamento
prob_cancelamento <- 1 / (1 + exp(-eta))

# Exibindo o resultado
prob_cancelamento

## [1] 0.6456576

Isso significa que, com os valores fornecidos para as variáveis (Tempo = 10 meses, Idoso = Yes, ServicoTelefone = Yes, etc.), o modelo calcula que há uma chance de 64,57% de que o cliente cancele o serviço.

Coeficientes

final_model$coefficients

##                            (Intercept)                                  Tempo 
##                            -0.46557547                            -0.03670718 
##                               IdosoYes                     ServicoTelefoneYes 
##                             0.40057739                            -0.39326101 
##                     MultiplasLinhasYes             ServicoInternetFiber optic 
##                             0.24896363                             0.94164496 
##                      ServicoInternetNo                        BackupOnlineYes 
##                            -0.74263758                            -0.11692944 
##                 ProtecaoDispositivoYes                         StreamingTVYes 
##                            -0.01721924                             0.24968637 
##                     StreamingFilmesYes                       ContratoOne year 
##                             0.21495696                            -0.73288236 
##                       ContratoTwo year               FaturamentoEletronicoYes 
##                            -1.68905812                             0.38170335 
## MetodoPagamentoCredit card (automatic)        MetodoPagamentoElectronic check 
##                            -0.03091178                             0.33622045 
##            MetodoPagamentoMailed check 
##                             0.01954290

Exp coeficientes

k=exp(final_model$coefficients)

sort(k,decreasing = T)

##             ServicoInternetFiber optic                               IdosoYes 
##                              2.5641960                              1.4926863 
##               FaturamentoEletronicoYes        MetodoPagamentoElectronic check 
##                              1.4647775                              1.3996475 
##                         StreamingTVYes                     MultiplasLinhasYes 
##                              1.2836228                              1.2826954 
##                     StreamingFilmesYes            MetodoPagamentoMailed check 
##                              1.2398085                              1.0197351 
##                 ProtecaoDispositivoYes MetodoPagamentoCredit card (automatic) 
##                              0.9829282                              0.9695611 
##                                  Tempo                        BackupOnlineYes 
##                              0.9639584                              0.8896480 
##                     ServicoTelefoneYes                            (Intercept) 
##                              0.6748526                              0.6277737 
##                       ContratoOne year                      ServicoInternetNo 
##                              0.4805220                              0.4758571 
##                       ContratoTwo year 
##                              0.1846934

# Extraindo os coeficientes e calculando odds ratios
coeficientes <- summary(final_model)$coefficients[, "Estimate"]
odds_ratios <- exp(coeficientes)

# Calculando os intervalos de confiança para os odds ratios
IC <- confint(final_model)

## Waiting for profiling to be done...

IC_odds_ratios <- exp(IC)

# Criando uma lista completa de categorias de referência
# Inclui NA para variáveis contínuas e o intercepto
categorias_referencia_completo <- c(NA, sapply(final_model$xlevels, function(x) x[1]))
categorias_referencia_completo <- categorias_referencia_completo[1:length(coeficientes)]  # Ajustando o comprimento

# Criando uma tabela com as informações desejadas
tabela_resultados <- data.frame(
  Variavel = names(coeficientes),
  Coeficiente = coeficientes,
  Categoria_Referencia = categorias_referencia_completo,
  Odds_Ratio = odds_ratios,
  IC_Odds_Ratio_2.5 = IC_odds_ratios[, 1],
  IC_Odds_Ratio_97.5 = IC_odds_ratios[, 2]
)

# Exibindo a tabela
DT::datatable(tabela_resultados)

Tabela Odds

# Calculando os coeficientes (betas)
betas <- final_model$coefficients

# Calculando os intervalos de confiança dos betas (95% IC)
IC_betas <- confint(final_model)

## Waiting for profiling to be done...

# Calculando as razões de chances (odds ratios)
odds_ratios <- exp(betas)

# Calculando os intervalos de confiança das odds ratios
IC_odds_ratios <- exp(IC_betas)

# Calculando o percentual associado aos odds ratios
percentual_odds <- (odds_ratios - 1) * 100  # Converte para aumento ou redução percentual

# Criando uma tabela com as interpretações
tabela_final <- data.frame(
  Variavel = names(betas),
  Beta = betas,
  IC_2.5 = IC_betas[, 1],
  IC_97.5 = IC_betas[, 2],
  Odds_Ratio = odds_ratios,
  IC_Odds_2.5 = IC_odds_ratios[, 1],
  IC_Odds_97.5 = IC_odds_ratios[, 2],
  Percentual = percentual_odds  # Coluna com o percentual
)

# Visualizando a tabela final com os percentuais
DT::datatable(tabela_final)

# Gera gráfico para visualização dos Odds Ratios com ggplot2
library(ggplot2)

# Classificação das covariáveis
tabela_final$Categoria <- ifelse(
  tabela_final$IC_Odds_97.5 < 1, "Protetoras",
  ifelse(tabela_final$IC_Odds_2.5 > 1, "Risco", "Irrelevantes")
)

# Gera gráfico com ponto para Odds Ratio e barra de erro para o intervalo de confiança
ggplot(tabela_final, aes(x = reorder(Variavel, Odds_Ratio), y = Odds_Ratio, color = Categoria)) +
  geom_point(size = 4) +  # Bolinha colorida para o Odds Ratio
  geom_errorbar(aes(ymin = IC_Odds_2.5, ymax = IC_Odds_97.5), width = 0.2, color = "black") +  # Barra de erro para IC
  coord_flip() +  # Inverte os eixos para melhor visualização
  geom_hline(yintercept = 1, linetype = "dashed", color = "black") +  # Linha de referência em 1
  geom_text(aes(label = paste0("OR=", round(Odds_Ratio, 2), " (", round(IC_Odds_2.5, 2), "-", round(IC_Odds_97.5, 2), ")\n", round(Percentual, 1), "%")), 
            hjust = -0.1, size = 3.5, color = "black", position = position_dodge(width = 0.9)) +
  scale_color_manual(values = c("Protetoras" = "blue", "Irrelevantes" = "gray", "Risco" = "red")) +  # Define as cores
  labs(title = "Razoes de Chances (Odds Ratios) e Intervalos de Confianca",
       x = "Variavel",
       y = "Odds Ratio") +
  theme_minimal() +
  theme(legend.title = element_blank())  # Remove título da legenda

Interpretação dos Coeficientes

Os odds ratios acima de 1 indicam que as variáveis associadas aumentam as chances de cancelamento (aumenta em . Exemplo

Os odds ratios abaixo de 1 indicam uma redução nas chances de cancelamento.

Resumindo: ( Exp(Coeficientes) -1 )*100) Se for negativo reduz,se for positivo aumenta.

Interpretação dos Coeficientes Exponenciados Intercepto (0.5054):

Quando todas as variáveis estão nas suas categorias de referência, as chances de cancelamento são aproximadamente 49,46% menores em relação às chances de não cancelamento.

ServicoInternet (Fiber optic) (2.0516):

Clientes com serviço de internet via fibra óptica têm uma chance de cancelamento aproximadamente 105,16% maior em comparação aos clientes que utilizam a categoria de referência (DSL), mantendo todas as outras variáveis constantes.

exportando telco

actual_churn <- telco$Cancelamento
# Previsões do modelo
pred <- predict(final_model, type = "response", newdata =telco)
telco$prob <- pred

cutoff_churn <- factor(ifelse(pred >=0.293, "Yes", "No"))
conf_final <- caret::confusionMatrix(cutoff_churn, actual_churn, positive = "Yes")
conf_final

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction   No  Yes
##        No  3878  417
##        Yes 1285 1452
##                                           
##                Accuracy : 0.758           
##                  95% CI : (0.7478, 0.7679)
##     No Information Rate : 0.7342          
##     P-Value [Acc > NIR] : 2.85e-06        
##                                           
##                   Kappa : 0.4599          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.7769          
##             Specificity : 0.7511          
##          Pos Pred Value : 0.5305          
##          Neg Pred Value : 0.9029          
##              Prevalence : 0.2658          
##          Detection Rate : 0.2065          
##    Detection Prevalence : 0.3892          
##       Balanced Accuracy : 0.7640          
##                                           
##        'Positive' Class : Yes             
## 

accuracy <- conf_final$overall[1]
sensitivity <- conf_final$byClass[1]
specificity <- conf_final$byClass[2]



# Carregar o pacote openxlsx
library(openxlsx)

# Escrever o dataframe para um arquivo Excel
write.xlsx(telco, file = "telcoProbabilidades.xlsx", rowNames = FALSE)

# Confirmação de exportação
print("Exportação para Excel concluída.")

## [1] "Exportação para Excel concluída."