Regresión Logística - Customer Churn

Teoría

La regresión Logística es un método de aprendizaje automático 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)

## Cargando paquete requerido: ggplot2

## Cargando paquete requerido: 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.
## 
## Adjuntando el paquete: 'pROC'
## 
## The following objects are masked from 'package:stats':
## 
##     cov, smooth, var

Crear la base de datos

df = read_csv(file.choose())

## Rows: 440833 Columns: 12
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (3): Gender, Subscription Type, Contract Length
## dbl (9): CustomerID, Age, Tenure, Usage Frequency, Support Calls, Payment De...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

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)

## tibble [440,832 × 11] (S3: tbl_df/tbl/data.frame)
##  $ Age              : num [1:440832] 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           : num [1:440832] 39 49 14 38 32 33 49 37 12 3 ...
##  $ Usage Frequency  : num [1:440832] 14 1 4 21 20 25 12 8 5 25 ...
##  $ Support Calls    : num [1:440832] 5 10 6 7 5 9 3 4 7 2 ...
##  $ Payment Delay    : num [1:440832] 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 [1:440832] 932 557 185 396 617 129 821 445 969 415 ...
##  $ Last Interaction : num [1:440832] 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)
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 Type`Premium  -1.265e-01  1.606e-02   -7.877 3.35e-15 ***
## `Subscription Type`Standard -1.112e-01  1.605e-02   -6.928 4.27e-12 ***
## `Contract Length`Monthly     2.020e+01  3.174e+01    0.637    0.524    
## `Contract Length`Quarterly   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 
##                4.579154e-01                1.036308e+00 
##                  GenderMale                      Tenure 
##                3.146693e-01                9.921152e-01 
##           `Usage Frequency`             `Support Calls` 
##                9.853576e-01                2.100844e+00 
##             `Payment Delay`  `Subscription Type`Premium 
##                1.117928e+00                8.811827e-01 
## `Subscription Type`Standard    `Contract Length`Monthly 
##                8.947526e-01                5.941648e+08 
##  `Contract Length`Quarterly               `Total Spend` 
##                1.000892e+00                9.940013e-01 
##          `Last Interaction` 
##                1.063116e+00

# Interpretación: por cada año de edad, la probabilidad de abandonar crece 3.9%.

resultado_entrenamiento = predict(modelo, entrenamiento)
resultado_prueba = predict(modelo, prueba)

pred_clase_prueba = as.factor(ifelse(resultado_prueba > 0.5, 1, 0))

confusionMatrix(pred_clase_prueba, prueba$Churn)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction     0     1
##          0 54192 10653
##          1  3057 64346
##                                          
##                Accuracy : 0.8963         
##                  95% CI : (0.8947, 0.898)
##     No Information Rate : 0.5671         
##     P-Value [Acc > NIR] : < 2.2e-16      
##                                          
##                   Kappa : 0.7921         
##                                          
##  Mcnemar's Test P-Value : < 2.2e-16      
##                                          
##             Sensitivity : 0.9466         
##             Specificity : 0.8580         
##          Pos Pred Value : 0.8357         
##          Neg Pred Value : 0.9546         
##              Prevalence : 0.4329         
##          Detection Rate : 0.4098         
##    Detection Prevalence : 0.4903         
##       Balanced Accuracy : 0.9023         
##                                          
##        'Positive' Class : 0              
## 

curva_roc = roc(prueba$Churn, resultado_prueba)
plot(curva_roc, main="Curva ROC - Customer Churn")

auc(curva_roc)

## Area under the curve: 0.9607

Predicción

nuevo_cliente = data.frame(
  Age = 58,
  Gender = factor("Male"),
  Tenure = 38,
  `Usage Frequency` = 21,
  `Support Calls` = 7,
  `Payment Delay` = 7,
  `Subscription Type` = factor("Standard"),
  `Contract Length` = factor("Monthly"),
  `Total Spend` = 396,
  `Last Interaction` = 29,
  check.names = FALSE
)
predict(modelo, newdata = nuevo_cliente, type = "response")

## 1 
## 1

Tarea: Customer Churn Risk Score %

select(Prob_Churn, Risk_Score) %>% head(10)

# A tibble: 10 × 2

Prob_Churn Risk_Score

1 1.000 Alto

2 0.952 Alto

3 0.599 Medio

4 0.0604 Bajo

5 0.894 Alto

6 1.000 Alto

7 0.941 Alto

8 0.0489 Bajo

9 1.000 Alto

10 1.000 Alto

```

Conclusión

De los 132,248 clientes en el conjunto de prueba, el modelo clasificó a 65,974 (49.9%) en riesgo Alto de churn, 13,925 (10.5%) en riesgo Medio y 52,349 (39.6%) en riesgo Bajo. Para el equipo de retención esto implica que, en vez de tratar por igual a los 66,000 clientes de riesgo Alto, conviene usar el score dentro de ese grupo (por ejemplo, ordenando por Prob_Churn) para priorizar primero a los de mayor probabilidad.