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 evernto categórico, con dos resultados posibles: Sí (1) o No (0)

contexto

Una empresa 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.

Librerías y Paquetes

# install.packages("caret") # modelos de aprendizaje automático
library(caret)

## Loading required package: ggplot2

## Loading required package: lattice

# install.packages("tidyverse") # manipulación de datos
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") # calculo del área bajo la curva
library(pROC)

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

Leer la base de datos

file.choose()

df <- read.csv("/Users/marcelosalazar/Downloads/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 de 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.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

# interpreteación: por cada año de edad,la probabiliad 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

El objetivo es asignar a cada cliente un puntaje de riesgo de abandono de 0 a 100, identificar qué variables pesan más en ese puntaje y agregarlo como última columna de la tabla original.

Variables más importantes

En una regresión logística la importancia de cada variable se mide con el valor absoluto de su estadístico z. Mientras más grande, más peso tiene esa variable para separar a los clientes que abandonan de los que se quedan.

importancia <- varImp(modelo)
importancia$Variable <- rownames(importancia)
importancia <- importancia %>% arrange(desc(Overall))
importancia

##                                Overall                  Variable
## Support.Calls             203.85219067             Support.Calls
## Total.Spend               164.94850631               Total.Spend
## Payment.Delay             119.83536451             Payment.Delay
## GenderMale                 81.99676922                GenderMale
## Last.Interaction           74.98963901          Last.Interaction
## Age                        60.48946655                       Age
## Tenure                     20.82804348                    Tenure
## Usage.Frequency            19.26474724           Usage.Frequency
## Subscription.TypePremium    7.87707447  Subscription.TypePremium
## Subscription.TypeStandard   6.92797984 Subscription.TypeStandard
## Contract.LengthMonthly      0.63657089    Contract.LengthMonthly
## Contract.LengthQuarterly    0.06834528  Contract.LengthQuarterly

ggplot(importancia, aes(x = reorder(Variable, Overall), y = Overall)) +
  geom_col(fill = "steelblue") +
  coord_flip() +
  labs(title = "Importancia de las variables en el riesgo de abandono",
       x = "", y = "Importancia (valor z absoluto)")

Las variables con más peso son las llamadas a soporte, el gasto total, el retraso en pagos y los días desde la última interacción. Las llamadas a soporte son con diferencia la señal más fuerte: cada llamada adicional duplica las probabilidades de abandono. El gasto total va en dirección contraria, es decir, mientras más gasta un cliente, menos probable es que se vaya.

Calcular el puntaje de riesgo

El modelo devuelve una probabilidad entre 0 y 1. Multiplicada por 100 se convierte en un puntaje interpretable por el área comercial.

# type="response" es indispensable: sin ese argumento predict() devuelve
# log-odds en lugar de probabilidades
df$Probabilidad_Churn <- predict(modelo, newdata = df, type = "response")
df$Risk_Score <- round(df$Probabilidad_Churn * 100, 1)

summary(df$Risk_Score)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    0.00   10.90   65.50   56.72   99.80  100.00

Clasificar el riesgo en niveles

df$Nivel_Riesgo <- cut(df$Risk_Score,
                       breaks = c(-1, 33, 66, 100),
                       labels = c("Bajo", "Medio", "Alto"))

table(df$Nivel_Riesgo)

## 
##   Bajo  Medio   Alto 
## 174728  46390 219714

df %>%
  group_by(Nivel_Riesgo) %>%
  summarise(
    Clientes            = n(),
    Riesgo_promedio     = mean(Risk_Score),
    Abandono_real       = mean(as.numeric(as.character(Churn))),
    Llamadas_soporte    = mean(Support.Calls),
    Gasto_promedio      = mean(Total.Spend)
  )

## # A tibble: 3 × 6
##   Nivel_Riesgo Clientes Riesgo_promedio Abandono_real Llamadas_soporte
##   <fct>           <int>           <dbl>         <dbl>            <dbl>
## 1 Bajo           174728            10.1         0.106             1.32
## 2 Medio           46390            48.4         0.435             2.73
## 3 Alto           219714            95.6         0.961             5.61
## # ℹ 1 more variable: Gasto_promedio <dbl>

La columna de abandono real sirve para verificar que el puntaje funciona: el porcentaje de clientes que efectivamente abandonaron debe subir conforme sube el nivel de riesgo.

Validar el puntaje con la curva ROC

prob_prueba <- predict(modelo, newdata = prueba, type = "response")
curva <- roc(prueba$Churn, prob_prueba)
auc(curva)

## Area under the curve: 0.9607

plot(curva, main = "Curva ROC del modelo de abandono")

El área bajo la curva (AUC) resume la capacidad del modelo para ordenar bien a los clientes. Un valor de 0.5 equivale a adivinar y uno de 1.0 sería perfecto.

Tabla final con el puntaje

head(df, 10)

##    Age Gender Tenure Usage.Frequency Support.Calls Payment.Delay
## 1   30 Female     39              14             5            18
## 2   65 Female     49               1            10             8
## 3   55 Female     14               4             6            18
## 4   58   Male     38              21             7             7
## 5   23   Male     32              20             5             8
## 6   51   Male     33              25             9            26
## 7   58 Female     49              12             3            16
## 8   55 Female     37               8             4            15
## 9   39   Male     12               5             7             4
## 10  64 Female      3              25             2            11
##    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
## 7           Standard       Quarterly         821               24     1
## 8            Premium          Annual         445               30     1
## 9           Standard       Quarterly         969               13     1
## 10          Standard       Quarterly         415               29     1
##    Probabilidad_Churn Risk_Score Nivel_Riesgo
## 1           0.6928683       69.3         Alto
## 2           1.0000000      100.0         Alto
## 3           0.9985614       99.9         Alto
## 4           1.0000000      100.0         Alto
## 5           1.0000000      100.0         Alto
## 6           0.9997792      100.0         Alto
## 7           0.7598864       76.0         Alto
## 8           0.9883792       98.8         Alto
## 9           0.4457791       44.6        Medio
## 10          0.9520071       95.2         Alto

# clientes con mayor riesgo, que son los que debe atacar primero el área comercial
df %>% arrange(desc(Risk_Score)) %>% head(10)

##    Age Gender Tenure Usage.Frequency Support.Calls Payment.Delay
## 1   65 Female     49               1            10             8
## 2   58   Male     38              21             7             7
## 3   23   Male     32              20             5             8
## 4   51   Male     33              25             9            26
## 5   52 Female     21               6             3            26
## 6   22   Male     41              17            10            25
## 7   24   Male     44              13             5             4
## 8   39 Female     43               2             4            15
## 9   27 Female     52               8             7             3
## 10  59   Male     26              21             0            10
##    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          Annual         129                8     1
## 5            Premium         Monthly         830               19     1
## 6              Basic       Quarterly         265               23     1
## 7            Premium         Monthly         669               13     1
## 8              Basic         Monthly         577                6     1
## 9           Standard         Monthly         434               19     1
## 10           Premium         Monthly         822               17     1
##    Probabilidad_Churn Risk_Score Nivel_Riesgo
## 1           1.0000000        100         Alto
## 2           1.0000000        100         Alto
## 3           1.0000000        100         Alto
## 4           0.9997792        100         Alto
## 5           1.0000000        100         Alto
## 6           0.9997507        100         Alto
## 7           1.0000000        100         Alto
## 8           1.0000000        100         Alto
## 9           1.0000000        100         Alto
## 10          1.0000000        100         Alto

# exportar la tabla con el puntaje
write.csv(df, "/Users/marcelosalazar/Downloads/customer_churn_scored.csv", row.names = FALSE)

Conclusiones

El puntaje de riesgo convierte la salida del modelo en una herramienta operativa: en lugar de una predicción de sí o no, el área comercial recibe una lista priorizada de clientes con el porcentaje de probabilidad de que abandonen. Las llamadas a soporte son la variable más informativa, lo que sugiere que el abandono está precedido por problemas no resueltos, y que el mejor punto de intervención es la calidad del servicio de atención y no los descuentos. El retraso en pagos y los días desde la última interacción funcionan como alertas tempranas complementarias.

Hay que señalar dos limitaciones. La primera es que el puntaje se calculó sobre toda la base, incluidos los registros con los que se entrenó el modelo, por lo que en esos clientes el riesgo está algo inflado. La segunda es que el modelo mide asociación, no causalidad: reducir las llamadas a soporte no reduce el abandono por sí mismo si el problema de fondo sigue ahí.