Customer Churn

Teoria

La regresion logistica es una metodo de aprendizaje automatico que sirve para predecir la probabilidad de que ocurra un evento categorico, con dos resultados posibles: Si (1) o No (0).

Contexto

Una empresa de servicios por suscripcion ha observado un incremento en la perdida de clientes, fenomeno conocido como Customer Churn. Se busca un modelo para estimar la probabilidad de que un cliente abandone el servicio.

Instalar paquetes y librerias

#install.packages("caret") # Modelos de aprendizaje automatico
library(caret)
#install.packages("tidyverse") # Manipulacion de datos
library(tidyverse)
#install.packages("pROC") # Calculo del area bajo la curva

Crear la base de datos

#file.choose()
df <- read.csv("/Users/eurielgomeztamez/Library/Mobile Documents/com~apple~CloudDocs/Tec/7/M2/customer_churn.csv")

Entender los 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 regresion logistica

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

# Interpretacion: Por cada año de edad, la probabilidad de abandono crece 3.9%. 

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

Prediccion

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

# Probabilidad de abandono, de 0 a 100
prueba$Risk_Score <- predict(modelo, prueba, type="response") * 100

# Grupo 3 = bajo, 2 = medio, 1 = alto
prueba$Grupo <- 3
prueba$Grupo[prueba$Risk_Score >= 30] <- 2
prueba$Grupo[prueba$Risk_Score >= 70] <- 1

# Ver resultados
head(prueba[, c("Risk_Score", "Grupo")])

##    Risk_Score Grupo
## 2  100.000000     1
## 10  95.200706     1
## 14  59.876693     2
## 28   6.042663     3
## 29  89.389183     1
## 30 100.000000     1

table(prueba$Grupo)

## 
##     1     2     3 
## 64454 17157 50637