Regresión Logística - Curtomer Churn

Teoría

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

Contexto

Es una empresa de servicios por suscripción ha observado un incremento en la pérdida de clientes, fenómenno conocido como Customer Chhurn. 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)
#install.packages("tidyverse")
library(tidyverse)
#install.packages("pROC")
library(pROC)

Crear la base de datos

df <- read.csv("C:\\Users\\natal\\OneDrive\\Carrera\\7moSemestre\\Modulo2\\customer_churn.csv")

Entender la base de datos

summary(df)

##    CustomerID          Age              Gender           Tenure     
##  Min.   :     2   Min.   :18.00   Length   :440833   Min.   : 1.00  
##  1st Qu.:113622   1st Qu.:29.00   N.unique :     3   1st Qu.:16.00  
##  Median :226126   Median :39.00   N.blank  :     1   Median :32.00  
##  Mean   :225399   Mean   :39.37   Min.nchar:     0   Mean   :31.26  
##  3rd Qu.:337739   3rd Qu.:48.00   Max.nchar:     6   3rd Qu.:46.00  
##  Max.   :449999   Max.   :65.00                      Max.   :60.00  
##  NAs    :1        NAs    :1                          NAs    :1      
##  Usage.Frequency Support.Calls    Payment.Delay   Subscription.Type 
##  Min.   : 1.00   Min.   : 0.000   Min.   : 0.00   Length   :440833  
##  1st Qu.: 9.00   1st Qu.: 1.000   1st Qu.: 6.00   N.unique :     4  
##  Median :16.00   Median : 3.000   Median :12.00   N.blank  :     1  
##  Mean   :15.81   Mean   : 3.604   Mean   :12.97   Min.nchar:     0  
##  3rd Qu.:23.00   3rd Qu.: 6.000   3rd Qu.:19.00   Max.nchar:     8  
##  Max.   :30.00   Max.   :10.000   Max.   :30.00                     
##  NAs    :1       NAs    :1        NAs    :1                         
##   Contract.Length    Total.Spend     Last.Interaction     Churn       
##  Length   :440833   Min.   : 100.0   Min.   : 1.00    Min.   :0.0000  
##  N.unique :     4   1st Qu.: 480.0   1st Qu.: 7.00    1st Qu.:0.0000  
##  N.blank  :     1   Median : 661.0   Median :14.00    Median :1.0000  
##  Min.nchar:     0   Mean   : 631.6   Mean   :14.48    Mean   :0.5671  
##  Max.nchar:     9   3rd Qu.: 830.0   3rd Qu.:22.00    3rd Qu.:1.0000  
##                     Max.   :1000.0   Max.   :30.00    Max.   :1.0000  
##                     NAs    :1        NAs    :1        NAs    :1

str(df)

## 'data.frame':    440833 obs. of  12 variables:
##  $ CustomerID       : int  2 3 4 5 6 8 9 10 11 12 ...
##  $ Age              : int  30 65 55 58 23 51 58 55 39 64 ...
##  $ Gender           : chr  "Female" "Female" "Female" "Male" ...
##  $ 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: chr  "Standard" "Basic" "Basic" "Standard" ...
##  $ Contract.Length  : chr  "Annual" "Monthly" "Quarterly" "Monthly" ...
##  $ 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            : int  1 1 1 1 1 1 1 1 1 1 ...

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)

Partir la base de datos

#Normalmente 80-20 o 70-30
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

#Normalmente 80-20 o 70-30
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.565e-01  4.137e-02  -18.285  < 2e-16 ***
## Age                        3.536e-02  5.914e-04   59.789  < 2e-16 ***
## GenderMale                -1.149e+00  1.414e-02  -81.267  < 2e-16 ***
## Tenure                    -7.987e-03  3.814e-04  -20.938  < 2e-16 ***
## Usage.Frequency           -1.513e-02  7.672e-04  -19.724  < 2e-16 ***
## Support.Calls              7.476e-01  3.671e-03  203.665  < 2e-16 ***
## Payment.Delay              1.124e-01  9.336e-04  120.411  < 2e-16 ***
## Subscription.TypePremium  -1.316e-01  1.610e-02   -8.176 2.93e-16 ***
## Subscription.TypeStandard -1.180e-01  1.612e-02   -7.320 2.49e-13 ***
## Contract.LengthMonthly     2.017e+01  3.174e+01    0.635    0.525    
## Contract.LengthQuarterly   9.906e-04  1.309e-02    0.076    0.940    
## Total.Spend               -6.053e-03  3.663e-05 -165.246  < 2e-16 ***
## Last.Interaction           6.068e-02  8.192e-04   74.076  < 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: 422253  on 308582  degrees of freedom
## Residual deviance: 150361  on 308570  degrees of freedom
## AIC: 150387
## 
## Number of Fisher Scoring iterations: 18

#exp(coef(modelo))
#Interpretación Por cada año de edad, la probabilidad de abandono crece 3.8

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

Predicción

Es una tabla de evaluación que desglosa el rendimiento del modelo de clasificación

nuevo_cliente <- data.frame(
  Age=45,
  Gender="Male",
  Tenure=8,
  Usage.Frequency=12,
  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

Puntaje de riesgo de abandono

#Agregar una columna con el puntaje de riesgo de abandono con las varibles de riesgo de no renovar y columna con texo 'riesgo bajo' 'riesgo medio' 'riesgo alto

# Probabilidad de no renovar
df$Puntaje.riesgo.abandono <- predict(
  modelo,
  newdata = df,
  type = "response"
)

# Clasificación del nivel de riesgo
df$Nivel.Riesgo <- cut(
  df$Puntaje.riesgo.abandono,
  breaks = c(-Inf, 0.33, 0.66, Inf),
  labels = c("Bajo", "Medio", "Alto")
)

df$Puntaje.riesgo.abandono <- df$Puntaje.riesgo.abandono * 100

head(df)

##   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
##   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
##   Puntaje.riesgo.abandono Nivel.Riesgo
## 1                69.30550         Alto
## 2               100.00000         Alto
## 3                99.86255         Alto
## 4               100.00000         Alto
## 5               100.00000         Alto
## 6                99.97925         Alto