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: Si (1) o No (0).
Uma emrpesa de servicios por subscripción ha observado un incremento en la perdida de clientes, fenómeno conocido como Customer Churn. Se busca un modelo para estimar la probabilidad de que un cliente abandone el servicio.
#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") #Cálculo de á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, vardf <-read.csv("/Users/ceciliabalditbautista/Downloads/customer_churn.csv")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.00str(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"#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 <- glm(Churn ~., data=entrenamiento, family=binomial)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredsummary (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: 18exp(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#Interpretación: por cada año de edad, la probabilidad de abandono crece 3.9%.
resultado_entrenamiento <- predict(modelo, entrenamiento)
resultado_prueba <- predict(modelo, prueba)nuevo_cliente <-data.frame (
Age=45,
Gender="Male",
Tenure=8,
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