Regresion Logistica - Customer Churn

Teoría

La regresión logística es un método de aprendizaje automátio que sirve para predecir la probabilidad de que ocurra un evento categórico, con dos resultados posibles: Sí (1) o No (0).

Contexto

Una empresa de servicios por suscripción ha observado un incremento en la pérdida de Clientes, fenómeno conocido como customer Churn, se busca un modelo para estimar la probabilidad de que un cliente abandone el servicio.

Instalar paquetes y llamar librerías

#install.packages("caret")
library(caret)

## Loading required package: ggplot2

## Loading required package: lattice

#install.packages("tidyverse")
library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.2.1     ✔ readr     2.2.0
## ✔ forcats   1.0.1     ✔ stringr   1.6.0
## ✔ lubridate 1.9.5     ✔ tibble    3.3.1
## ✔ purrr     1.2.2     ✔ tidyr     1.3.2

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ✖ purrr::lift()   masks caret::lift()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

#install.packages("pROC")
library(pROC)

## Type 'citation("pROC")' for a citation.
## 
## Attaching package: 'pROC'
## 
## The following objects are masked from 'package:stats':
## 
##     cov, smooth, var

Instalar la base de datos

# file.choose()
df <- read.csv("/Users/gabotejeda/Desktop/codigos R/customer_churn.csv")

Entender la base de datos

df <- na.omit(df)
df$CustomerID <- NULL
df$Gender <- as.factor(df$Gender)
df$Subscription.Type <- as.factor(df$Subscription.Type)
df$Contract.Length <- as.factor(df$Contract.Length)
df$Churn <- as.factor(df$Churn)
summary(df)

##       Age           Gender           Tenure      Usage.Frequency
##  Min.   :18.00   Female:190580   Min.   : 1.00   Min.   : 1.00  
##  1st Qu.:29.00   Male  :250252   1st Qu.:16.00   1st Qu.: 9.00  
##  Median :39.00                   Median :32.00   Median :16.00  
##  Mean   :39.37                   Mean   :31.26   Mean   :15.81  
##  3rd Qu.:48.00                   3rd Qu.:46.00   3rd Qu.:23.00  
##  Max.   :65.00                   Max.   :60.00   Max.   :30.00  
##  Support.Calls    Payment.Delay   Subscription.Type  Contract.Length  
##  Min.   : 0.000   Min.   : 0.00   Basic   :143026   Annual   :177198  
##  1st Qu.: 1.000   1st Qu.: 6.00   Premium :148678   Monthly  : 87104  
##  Median : 3.000   Median :12.00   Standard:149128   Quarterly:176530  
##  Mean   : 3.604   Mean   :12.97                                       
##  3rd Qu.: 6.000   3rd Qu.:19.00                                       
##  Max.   :10.000   Max.   :30.00                                       
##   Total.Spend     Last.Interaction Churn     
##  Min.   : 100.0   Min.   : 1.00    0:190833  
##  1st Qu.: 480.0   1st Qu.: 7.00    1:249999  
##  Median : 661.0   Median :14.00              
##  Mean   : 631.6   Mean   :14.48              
##  3rd Qu.: 830.0   3rd Qu.:22.00              
##  Max.   :1000.0   Max.   :30.00

str(df)

## 'data.frame':    440832 obs. of  11 variables:
##  $ Age              : int  30 65 55 58 23 51 58 55 39 64 ...
##  $ Gender           : Factor w/ 2 levels "Female","Male": 1 1 1 2 2 2 1 1 2 1 ...
##  $ Tenure           : int  39 49 14 38 32 33 49 37 12 3 ...
##  $ Usage.Frequency  : int  14 1 4 21 20 25 12 8 5 25 ...
##  $ Support.Calls    : int  5 10 6 7 5 9 3 4 7 2 ...
##  $ Payment.Delay    : int  18 8 18 7 8 26 16 15 4 11 ...
##  $ Subscription.Type: Factor w/ 3 levels "Basic","Premium",..: 3 1 1 3 1 2 3 2 3 3 ...
##  $ Contract.Length  : Factor w/ 3 levels "Annual","Monthly",..: 1 2 3 2 2 1 3 1 3 3 ...
##  $ Total.Spend      : num  932 557 185 396 617 129 821 445 969 415 ...
##  $ Last.Interaction : int  17 6 3 29 20 8 24 30 13 29 ...
##  $ Churn            : Factor w/ 2 levels "0","1": 2 2 2 2 2 2 2 2 2 2 ...
##  - attr(*, "na.action")= 'omit' Named int 199296
##   ..- attr(*, "names")= chr "199296"

Partir la base de datos

set.seed(123)
renglones_entrenamiento <- createDataPartition(df$Churn, p=0.7, list=FALSE)
entrenamiento <- df[renglones_entrenamiento, ]
prueba <- df[-renglones_entrenamiento, ]

Modelo de regresión logística

modelo <- glm(Churn ~., data=entrenamiento, family=binomial)

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

summary(modelo)

## 
## Call:
## glm(formula = Churn ~ ., family = binomial, data = entrenamiento)
## 
## Coefficients:
##                             Estimate Std. Error  z value Pr(>|z|)    
## (Intercept)               -7.811e-01  4.126e-02  -18.932  < 2e-16 ***
## Age                        3.566e-02  5.896e-04   60.489  < 2e-16 ***
## GenderMale                -1.156e+00  1.410e-02  -81.997  < 2e-16 ***
## Tenure                    -7.916e-03  3.801e-04  -20.828  < 2e-16 ***
## Usage.Frequency           -1.475e-02  7.657e-04  -19.265  < 2e-16 ***
## Support.Calls              7.423e-01  3.642e-03  203.852  < 2e-16 ***
## Payment.Delay              1.115e-01  9.302e-04  119.835  < 2e-16 ***
## Subscription.TypePremium  -1.265e-01  1.606e-02   -7.877 3.35e-15 ***
## Subscription.TypeStandard -1.112e-01  1.605e-02   -6.928 4.27e-12 ***
## Contract.LengthMonthly     2.020e+01  3.174e+01    0.637    0.524    
## Contract.LengthQuarterly   8.920e-04  1.305e-02    0.068    0.946    
## Total.Spend               -6.017e-03  3.648e-05 -164.949  < 2e-16 ***
## Last.Interaction           6.120e-02  8.162e-04   74.990  < 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: 422213  on 308583  degrees of freedom
## Residual deviance: 151251  on 308571  degrees of freedom
## AIC: 151277
## 
## Number of Fisher Scoring iterations: 18

exp(coef(modelo))

##               (Intercept)                       Age                GenderMale 
##              4.579154e-01              1.036308e+00              3.146693e-01 
##                    Tenure           Usage.Frequency             Support.Calls 
##              9.921152e-01              9.853576e-01              2.100844e+00 
##             Payment.Delay  Subscription.TypePremium Subscription.TypeStandard 
##              1.117928e+00              8.811827e-01              8.947526e-01 
##    Contract.LengthMonthly  Contract.LengthQuarterly               Total.Spend 
##              5.941648e+08              1.000892e+00              9.940013e-01 
##          Last.Interaction 
##              1.063116e+00

# interpretación: Por cada año de edad, la probabilidad de abandono crece 3.9%

resultado_entrenamiento <- predict(modelo,entrenamiento)
resultado_prueba <- predict(modelo,prueba)

Predicción

nuevo_cliente <- data.frame(
  Age=58,
  Gender="Male",
  Tenure=38,
  Usage.Frequency=21,
  Support.Calls=7,
  Payment.Delay=7,
  Subscription.Type="Standard",
  Contract.Length="Monthly",
  Total.Spend=396,
  Last.Interaction=29
)

predict(modelo, newdata=nuevo_cliente, type="response")

## 1 
## 1

Tarea: Customer Churn Risk Score

Modelo Logistico con variables numericas

entrenamiento_numerico <- entrenamiento %>%
  select(where(is.numeric), Churn)

prueba_numerico <- prueba %>%
  select(where(is.numeric), Churn)

str(entrenamiento_numerico)

## 'data.frame':    308584 obs. of  8 variables:
##  $ Age             : int  30 55 58 23 51 58 55 39 29 52 ...
##  $ Tenure          : int  39 14 38 32 33 49 37 12 18 21 ...
##  $ Usage.Frequency : int  14 4 21 20 25 12 8 5 9 6 ...
##  $ Support.Calls   : int  5 6 7 5 9 3 4 7 0 3 ...
##  $ Payment.Delay   : int  18 18 7 8 26 16 15 4 30 26 ...
##  $ Total.Spend     : num  932 185 396 617 129 821 445 969 930 830 ...
##  $ Last.Interaction: int  17 3 29 20 8 24 30 13 18 19 ...
##  $ Churn           : Factor w/ 2 levels "0","1": 2 2 2 2 2 2 2 2 2 2 ...
##  - attr(*, "na.action")= 'omit' Named int 199296
##   ..- attr(*, "names")= chr "199296"

Creación del modelo logístico numérico

modelo_numerico <- glm(
  Churn ~ .,
  data = entrenamiento_numerico,
  family = binomial
)

summary(modelo_numerico)

## 
## Call:
## glm(formula = Churn ~ ., family = binomial, data = entrenamiento_numerico)
## 
## Coefficients:
##                    Estimate Std. Error z value Pr(>|z|)    
## (Intercept)      -8.635e-01  3.225e-02  -26.77   <2e-16 ***
## Age               3.355e-02  4.769e-04   70.35   <2e-16 ***
## Tenure           -6.952e-03  3.161e-04  -21.99   <2e-16 ***
## Usage.Frequency  -1.268e-02  6.365e-04  -19.92   <2e-16 ***
## Support.Calls     6.644e-01  2.927e-03  227.02   <2e-16 ***
## Payment.Delay     1.003e-01  7.536e-04  133.06   <2e-16 ***
## Total.Spend      -5.322e-03  2.915e-05 -182.57   <2e-16 ***
## Last.Interaction  4.038e-02  6.399e-04   63.11   <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: 422213  on 308583  degrees of freedom
## Residual deviance: 213386  on 308576  degrees of freedom
## AIC: 213402
## 
## Number of Fisher Scoring iterations: 6

Odds Ratio del modelo numérico

exp(coef(modelo_numerico))

##      (Intercept)              Age           Tenure  Usage.Frequency 
##        0.4216632        1.0341215        0.9930722        0.9874036 
##    Support.Calls    Payment.Delay      Total.Spend Last.Interaction 
##        1.9433418        1.1054777        0.9946923        1.0412097

Predicción del modelo numérico

probabilidad_numerico <- predict(
  modelo_numerico,
  newdata = prueba_numerico,
  type = "response"
)

head(probabilidad_numerico)

##          2         10         14         28         29         30 
## 0.99662640 0.91217325 0.52112949 0.07015062 0.84457261 0.89317852

Clasificación del modelo numérico

prediccion_numerico <- ifelse(
  probabilidad_numerico >= 0.5,
  1,
  0
)

head(prediccion_numerico)

##  2 10 14 28 29 30 
##  1  1  1  0  1  1

Modelo Logístico con variables numéricas

modelo_numerico <- glm(
  Churn ~ .,
  data = entrenamiento_numerico,
  family = binomial
)

summary(modelo_numerico)

## 
## Call:
## glm(formula = Churn ~ ., family = binomial, data = entrenamiento_numerico)
## 
## Coefficients:
##                    Estimate Std. Error z value Pr(>|z|)    
## (Intercept)      -8.635e-01  3.225e-02  -26.77   <2e-16 ***
## Age               3.355e-02  4.769e-04   70.35   <2e-16 ***
## Tenure           -6.952e-03  3.161e-04  -21.99   <2e-16 ***
## Usage.Frequency  -1.268e-02  6.365e-04  -19.92   <2e-16 ***
## Support.Calls     6.644e-01  2.927e-03  227.02   <2e-16 ***
## Payment.Delay     1.003e-01  7.536e-04  133.06   <2e-16 ***
## Total.Spend      -5.322e-03  2.915e-05 -182.57   <2e-16 ***
## Last.Interaction  4.038e-02  6.399e-04   63.11   <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: 422213  on 308583  degrees of freedom
## Residual deviance: 213386  on 308576  degrees of freedom
## AIC: 213402
## 
## Number of Fisher Scoring iterations: 6