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).

En este caso se utilizará para estimar la probabilidad de que un cliente abandone el servicio, es decir, que presente Customer Churn.

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 crear un modelo para estimar la probabilidad de que un cliente abandone el servicio y posteriormente generar un puntaje de riesgo que permita identificar a los clientes con mayor probabilidad de abandono.

Instalar paquetes y llamar librerías

library(caret)
library(tidyverse)
library(pROC)

Crear la base de datos

df_original <- read.csv(
  "/Users/kamilahchaidez/Downloads/customer_churn.csv"
)

df <- df_original

Entender la base de datos

# Eliminar valores faltantes
df <- na.omit(df)

# Guardar CustomerID antes de eliminarlo del modelo
CustomerID <- df$CustomerID

# Eliminar CustomerID porque solo es un identificador
df$CustomerID <- NULL

# Convertir variables categóricas a factor
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

Odds Ratio

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

El Odds Ratio permite interpretar cómo cambia el riesgo de abandono cuando cambia alguna de las variables.

Por ejemplo, si para Age se obtiene un valor de 1.039, significa que por cada año adicional de edad los odds de abandono aumentan aproximadamente 3.9%, manteniendo las demás variables constantes.

Predicciones del modelo

resultado_entrenamiento <- predict(
  modelo,
  newdata = entrenamiento,
  type = "response"
)

resultado_prueba <- predict(
  modelo,
  newdata = prueba,
  type = "response"
)

head(resultado_entrenamiento)

##         1         3         4         5         6         7 
## 0.6928683 0.9985614 1.0000000 1.0000000 0.9997792 0.7598864

head(resultado_prueba)

##          2         10         14         28         29         30 
## 1.00000000 0.95200706 0.59876693 0.06042663 0.89389183 1.00000000

Clasificación de las predicciones

Se utilizará un punto de corte de 0.50.

Si la probabilidad es mayor o igual a 0.50 se considera que el cliente puede presentar churn.

prediccion_entrenamiento <- ifelse(
  resultado_entrenamiento >= 0.50,
  "1",
  "0"
)

prediccion_prueba <- ifelse(
  resultado_prueba >= 0.50,
  "1",
  "0"
)

prediccion_entrenamiento <- factor(
  prediccion_entrenamiento,
  levels = levels(entrenamiento$Churn)
)

prediccion_prueba <- factor(
  prediccion_prueba,
  levels = levels(prueba$Churn)
)

Matriz de Confusión

matriz_entrenamiento <- confusionMatrix(
  prediccion_entrenamiento,
  entrenamiento$Churn
)

matriz_entrenamiento

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction      0      1
##          0 120973  19843
##          1  12611 155157
##                                           
##                Accuracy : 0.8948          
##                  95% CI : (0.8937, 0.8959)
##     No Information Rate : 0.5671          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.7872          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.9056          
##             Specificity : 0.8866          
##          Pos Pred Value : 0.8591          
##          Neg Pred Value : 0.9248          
##              Prevalence : 0.4329          
##          Detection Rate : 0.3920          
##    Detection Prevalence : 0.4563          
##       Balanced Accuracy : 0.8961          
##                                           
##        'Positive' Class : 0               
## 

matriz_prueba <- confusionMatrix(
  prediccion_prueba,
  prueba$Churn
)

matriz_prueba

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction     0     1
##          0 51917  8318
##          1  5332 66681
##                                           
##                Accuracy : 0.8968          
##                  95% CI : (0.8951, 0.8984)
##     No Information Rate : 0.5671          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.7911          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.9069          
##             Specificity : 0.8891          
##          Pos Pred Value : 0.8619          
##          Neg Pred Value : 0.9260          
##              Prevalence : 0.4329          
##          Detection Rate : 0.3926          
##    Detection Prevalence : 0.4555          
##       Balanced Accuracy : 0.8980          
##                                           
##        'Positive' Class : 0               
## 

Predicción de un nuevo cliente

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

probabilidad_nuevo_cliente <- predict(
  modelo,
  newdata = nuevo_cliente,
  type = "response"
)

probabilidad_nuevo_cliente

## 1 
## 1

Puntaje de Riesgo del Nuevo Cliente

La probabilidad obtenida se convierte a una escala de 0 a 100 para facilitar su interpretación.

puntaje_nuevo_cliente <- round(
  probabilidad_nuevo_cliente * 100,
  2
)

puntaje_nuevo_cliente

##   1 
## 100

nivel_nuevo_cliente <- ifelse(
  puntaje_nuevo_cliente < 30,
  "Bajo",
  ifelse(
    puntaje_nuevo_cliente < 60,
    "Medio",
    "Alto"
  )
)

nivel_nuevo_cliente

##      1 
## "Alto"

La clasificación utilizada es:

• 0 a 29: Riesgo Bajo
• 30 a 59: Riesgo Medio
• 60 a 100: Riesgo Alto

Tarea: Customer Churn Risk Score

El objetivo es asignar un puntaje de riesgo a cada cliente, identificar las variables más importantes para calcular este riesgo y generar un ranking para saber qué clientes requieren mayor atención.

Variables más importantes para el riesgo

Para identificar las variables con mayor influencia se revisan los coeficientes de la regresión logística.

Entre mayor sea el valor absoluto del coeficiente, mayor es su influencia dentro del modelo.

coeficientes <- summary(modelo)$coefficients

importancia_variables <- data.frame(
  Variable = rownames(coeficientes),
  Coeficiente = coeficientes[, "Estimate"],
  P.value = coeficientes[, "Pr(>|z|)"]
)

# Eliminar intercepto
importancia_variables <- importancia_variables[
  importancia_variables$Variable != "(Intercept)",
]

# Magnitud del efecto
importancia_variables$Importancia <- abs(
  importancia_variables$Coeficiente
)

# Ordenar de mayor a menor
importancia_variables <- importancia_variables %>%
  arrange(desc(Importancia))

importancia_variables

##                                            Variable  Coeficiente      P.value
## Contract.LengthMonthly       Contract.LengthMonthly 20.202667338 5.244044e-01
## GenderMale                               GenderMale -1.156232938 0.000000e+00
## Support.Calls                         Support.Calls  0.742339205 0.000000e+00
## Subscription.TypePremium   Subscription.TypePremium -0.126490288 3.351352e-15
## Payment.Delay                         Payment.Delay  0.111476940 0.000000e+00
## Subscription.TypeStandard Subscription.TypeStandard -0.111207992 4.268926e-12
## Last.Interaction                   Last.Interaction  0.061203918 0.000000e+00
## Age                                             Age  0.035664547 0.000000e+00
## Usage.Frequency                     Usage.Frequency -0.014750700 1.061826e-82
## Tenure                                       Tenure -0.007916089 2.411111e-96
## Total.Spend                             Total.Spend -0.006016743 0.000000e+00
## Contract.LengthQuarterly   Contract.LengthQuarterly  0.000892040 9.455108e-01
##                            Importancia
## Contract.LengthMonthly    20.202667338
## GenderMale                 1.156232938
## Support.Calls              0.742339205
## Subscription.TypePremium   0.126490288
## Payment.Delay              0.111476940
## Subscription.TypeStandard  0.111207992
## Last.Interaction           0.061203918
## Age                        0.035664547
## Usage.Frequency            0.014750700
## Tenure                     0.007916089
## Total.Spend                0.006016743
## Contract.LengthQuarterly   0.000892040

Top 5 Variables más importantes

head(importancia_variables, 5)

##                                          Variable Coeficiente      P.value
## Contract.LengthMonthly     Contract.LengthMonthly  20.2026673 5.244044e-01
## GenderMale                             GenderMale  -1.1562329 0.000000e+00
## Support.Calls                       Support.Calls   0.7423392 0.000000e+00
## Subscription.TypePremium Subscription.TypePremium  -0.1264903 3.351352e-15
## Payment.Delay                       Payment.Delay   0.1114769 0.000000e+00
##                          Importancia
## Contract.LengthMonthly    20.2026673
## GenderMale                 1.1562329
## Support.Calls              0.7423392
## Subscription.TypePremium   0.1264903
## Payment.Delay              0.1114769

Las primeras variables de esta tabla son las que presentan una mayor influencia dentro del modelo para calcular el riesgo de Customer Churn.

Calcular Puntaje de Riesgo para todos los clientes

Primero se calcula la probabilidad de churn para todos los clientes.

probabilidad_clientes <- predict(
  modelo,
  newdata = df,
  type = "response"
)

puntaje_clientes <- round(
  probabilidad_clientes * 100,
  2
)

Clasificar el Nivel de Riesgo

nivel_riesgo <- ifelse(
  puntaje_clientes < 30,
  "Bajo",
  ifelse(
    puntaje_clientes < 60,
    "Medio",
    "Alto"
  )
)

Crear Ranking de Riesgo

El cliente con mayor probabilidad de abandono ocupará la posición 1 del ranking.

ranking_riesgo <- rank(
  -puntaje_clientes,
  ties.method = "min"
)

Agregar Puntaje a la Tabla Original

Se vuelve a agregar CustomerID y se incorporan el nivel de riesgo, ranking y puntaje.

El Risk.Score se agrega como la última columna de la tabla.

tabla_riesgo <- df

tabla_riesgo$CustomerID <- CustomerID

# Colocar CustomerID como primera columna
tabla_riesgo <- tabla_riesgo %>%
  select(CustomerID, everything())

# Agregar nivel de riesgo
tabla_riesgo$Risk.Level <- nivel_riesgo

# Agregar posición en el ranking
tabla_riesgo$Risk.Rank <- ranking_riesgo

# Agregar puntaje como ÚLTIMA columna
tabla_riesgo$Risk.Score <- puntaje_clientes

head(tabla_riesgo)

##   CustomerID Age Gender Tenure Usage.Frequency Support.Calls Payment.Delay
## 1          2  30 Female     39              14             5            18
## 2          3  65 Female     49               1            10             8
## 3          4  55 Female     14               4             6            18
## 4          5  58   Male     38              21             7             7
## 5          6  23   Male     32              20             5             8
## 6          8  51   Male     33              25             9            26
##   Subscription.Type Contract.Length Total.Spend Last.Interaction Churn
## 1          Standard          Annual         932               17     1
## 2             Basic         Monthly         557                6     1
## 3             Basic       Quarterly         185                3     1
## 4          Standard         Monthly         396               29     1
## 5             Basic         Monthly         617               20     1
## 6           Premium          Annual         129                8     1
##   Risk.Level Risk.Rank Risk.Score
## 1       Alto    215712      69.29
## 2       Alto         1     100.00
## 3       Alto    106040      99.86
## 4       Alto         1     100.00
## 5       Alto         1     100.00
## 6       Alto     90604      99.98

Ranking de Clientes

Ordenamos los clientes desde el que tiene mayor riesgo de abandono hasta el que tiene menor riesgo.

ranking_clientes <- tabla_riesgo %>%
  arrange(Risk.Rank)

head(
  ranking_clientes,
  10
)

##    CustomerID Age Gender Tenure Usage.Frequency Support.Calls Payment.Delay
## 1           3  65 Female     49               1            10             8
## 2           5  58   Male     38              21             7             7
## 3           6  23   Male     32              20             5             8
## 4          14  52 Female     21               6             3            26
## 5          21  24   Male     44              13             5             4
## 6          24  39 Female     43               2             4            15
## 7          26  27 Female     52               8             7             3
## 8          27  59   Male     26              21             0            10
## 9          32  18   Male     37              15             8             6
## 10         35  35   Male     40              27             8            28
##    Subscription.Type Contract.Length Total.Spend Last.Interaction Churn
## 1              Basic         Monthly         557                6     1
## 2           Standard         Monthly         396               29     1
## 3              Basic         Monthly         617               20     1
## 4            Premium         Monthly         830               19     1
## 5            Premium         Monthly         669               13     1
## 6              Basic         Monthly         577                6     1
## 7           Standard         Monthly         434               19     1
## 8            Premium         Monthly         822               17     1
## 9            Premium         Monthly         800               29     1
## 10           Premium         Monthly         232               17     1
##    Risk.Level Risk.Rank Risk.Score
## 1        Alto         1        100
## 2        Alto         1        100
## 3        Alto         1        100
## 4        Alto         1        100
## 5        Alto         1        100
## 6        Alto         1        100
## 7        Alto         1        100
## 8        Alto         1        100
## 9        Alto         1        100
## 10       Alto         1        100

La posición 1 corresponde al cliente con el mayor riesgo de churn.

Top 10 Clientes con Mayor Riesgo

top10_riesgo <- ranking_clientes %>%
  select(
    CustomerID,
    Risk.Level,
    Risk.Rank,
    Risk.Score
  ) %>%
  head(10)

top10_riesgo

##    CustomerID Risk.Level Risk.Rank Risk.Score
## 1           3       Alto         1        100
## 2           5       Alto         1        100
## 3           6       Alto         1        100
## 4          14       Alto         1        100
## 5          21       Alto         1        100
## 6          24       Alto         1        100
## 7          26       Alto         1        100
## 8          27       Alto         1        100
## 9          32       Alto         1        100
## 10         35       Alto         1        100

Cantidad de Clientes por Nivel de Riesgo

table(tabla_riesgo$Risk.Level)

## 
##   Alto   Bajo  Medio 
## 227181 168916  44735

Resumen del Puntaje de Riesgo

summary(tabla_riesgo$Risk.Score)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    0.05   10.91   65.50   56.72   99.81  100.00

Gráfica del Puntaje de Riesgo

hist(
  tabla_riesgo$Risk.Score,
  main = "Distribución del Puntaje de Riesgo",
  xlab = "Puntaje de Riesgo",
  ylab = "Número de Clientes"
)

Exportar Tabla con Puntaje de Riesgo

write.csv(
  tabla_riesgo,
  "customer_churn_risk_score.csv",
  row.names = FALSE
)

Conclusiones

El modelo de regresión logística permitió calcular la probabilidad de abandono de cada cliente.

Esta probabilidad se convirtió en un Risk Score de 0 a 100, donde los puntajes más altos representan un mayor riesgo de churn.

Además, se creó un ranking, en el cual el cliente número 1 representa al cliente con mayor riesgo de abandono.

Los clientes también fueron clasificados en tres niveles:

• Bajo: puntaje menor a 30.
• Medio: puntaje entre 30 y 59.
• Alto: puntaje de 60 o más.

Finalmente, el puntaje de riesgo fue agregado como la última columna de la tabla, permitiendo que la empresa pueda identificar rápidamente a los clientes de mayor riesgo y priorizar estrategias de retención.