Teoría

La regresion logistica es un 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 subscription ha observado un incremento en la perdida de clientes, fenomeno conocido como costumer churn. Se busca un modelo para estimar la probabilidad de que un cliente abandone el serivico.

Instalar paquetes y llamar librerias 

#install.packages("caret")
library(caret)
## Loading required package: ggplot2
## Loading required package: 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.
## 
## Attaching package: 'pROC'
## 
## The following objects are masked from 'package:stats':
## 
##     cov, smooth, var
#file.choose()
df <- read.csv("/Users/fedecolyerjr/Desktop/customer_churn.csv")

Entender 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 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 logisitca 

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
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: Costumer Churn Risk score

Modelo Logistico con variables numericas

modelo_num <- glm(
  Churn ~ Age + Tenure + Usage.Frequency + Support.Calls +
    Payment.Delay + Total.Spend + Last.Interaction,
  data = entrenamiento,
  family = binomial
)

Juntar columna de Churn Risk Score y Rating

entrenamiento$risk_score <- predict(modelo_num, newdata = entrenamiento, type = "response")

entrenamiento <- entrenamiento %>%
  mutate(impacto_riesgo = case_when(
    risk_score < 0.20 ~ "Muy Bajo",
    risk_score < 0.40 ~ "Bajo",
    risk_score < 0.60 ~ "Medio",
    risk_score < 0.80 ~ "Alto",
    TRUE              ~ "Muy Alto"
  ),
  impacto_riesgo = factor(impacto_riesgo,
                           levels = c("Muy Bajo", "Bajo", "Medio", "Alto", "Muy Alto"),
                           ordered = TRUE))

head(entrenamiento %>%
       select(Age, Tenure, Total.Spend, risk_score, impacto_riesgo))
##   Age Tenure Total.Spend risk_score impacto_riesgo
## 1  30     39         932  0.6336840           Alto
## 3  55     14         185  0.9968646       Muy Alto
## 4  58     38         396  0.9930951       Muy Alto
## 5  23     32         617  0.7465956           Alto
## 6  51     33         129  0.9998015       Muy Alto
## 7  58     49         821  0.6872691           Alto

Ver tabla final

set.seed(123) 
ejemplo_por_categoria <- entrenamiento %>%
  group_by(impacto_riesgo) %>%
  slice_sample(n = 1) %>%
  ungroup() %>%
  select(Age, Tenure, Total.Spend, risk_score, impacto_riesgo)

ejemplo_por_categoria
## # A tibble: 5 × 5
##     Age Tenure Total.Spend risk_score impacto_riesgo
##   <int>  <int>       <dbl>      <dbl> <ord>         
## 1    41     50        814.      0.143 Muy Bajo      
## 2    33     24        658       0.231 Bajo          
## 3    42     31        872       0.484 Medio         
## 4    45     43        607.      0.786 Alto          
## 5    65     58        553       0.983 Muy Alto