Customer Churn
Anuar Gamez A01234986
2026-08-27
Teoria < /span>
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 < /span>
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 < /span>
#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 curvaCrear la base de datos < /span>
#file.choose()
df <- read.csv("/Users/anuar/Desktop/customer_churn.csv")Entender los datos < /span>
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"Partir la base de datos < /span>
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 < /span>
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# 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 < /span>
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
## 1Tarea: Customer Churn Risk Score
Calcular riesgo de abandono
resultado_riesgo <- predict(
modelo,
newdata = df,
type = "response"
)
# Crear el Customer Churn Risk Score
# Convertimos la probabilidad a una escala de 0 a 100 para que sea más fácil de interpretar.
df_riesgo <- df %>%
mutate(
churn_risk_score = resultado_riesgo * 100
)Asignar nivel de riesgo
df_riesgo <- df_riesgo %>%
mutate(
nivel_riesgo = case_when(
churn_risk_score >= 80 ~ "Riesgo Muy Alto",
churn_risk_score >= 60 ~ "Riesgo Alto",
churn_risk_score >= 40 ~ "Riesgo Medio",
churn_risk_score >= 20 ~ "Riesgo Bajo",
TRUE ~ "Riesgo Muy Bajo"
)
)
head(df_riesgo)## 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
## churn_risk_score nivel_riesgo
## 1 69.28683 Riesgo Alto
## 2 100.00000 Riesgo Muy Alto
## 3 99.85614 Riesgo Muy Alto
## 4 100.00000 Riesgo Muy Alto
## 5 100.00000 Riesgo Muy Alto
## 6 99.97792 Riesgo Muy AltoCantidad clientes por nivel de riesgo
df_riesgo %>%
count(nivel_riesgo)## nivel_riesgo n
## 1 Riesgo Alto 25938
## 2 Riesgo Bajo 41757
## 3 Riesgo Medio 26968
## 4 Riesgo Muy Alto 201234
## 5 Riesgo Muy Bajo 144935# Porcentaje de clientes por nivel de riesgo
df_riesgo %>%
count(nivel_riesgo) %>%
mutate(
porcentaje = n / sum(n) * 100
)## nivel_riesgo n porcentaje
## 1 Riesgo Alto 25938 5.883874
## 2 Riesgo Bajo 41757 9.472316
## 3 Riesgo Medio 26968 6.117523
## 4 Riesgo Muy Alto 201234 45.648682
## 5 Riesgo Muy Bajo 144935 32.877604Identificar clientes con mayor riesgo
clientes_muy_alto_riesgo <- df_riesgo %>%
filter(nivel_riesgo == "Riesgo Muy Alto") %>%
arrange(desc(churn_risk_score))
head(clientes_muy_alto_riesgo)## Age Gender Tenure Usage.Frequency Support.Calls Payment.Delay
## 1 65 Male 14 12 9 30
## 2 56 Female 40 26 10 24
## 3 65 Female 16 29 8 27
## 4 59 Female 29 4 10 25
## 5 45 Female 5 11 8 29
## 6 45 Female 7 14 9 23
## Subscription.Type Contract.Length Total.Spend Last.Interaction Churn
## 1 Premium Monthly 158 18 1
## 2 Basic Monthly 184 5 1
## 3 Basic Monthly 295 27 1
## 4 Standard Monthly 212 7 1
## 5 Premium Monthly 262 28 1
## 6 Standard Monthly 176 26 1
## churn_risk_score nivel_riesgo
## 1 100 Riesgo Muy Alto
## 2 100 Riesgo Muy Alto
## 3 100 Riesgo Muy Alto
## 4 100 Riesgo Muy Alto
## 5 100 Riesgo Muy Alto
## 6 100 Riesgo Muy AltoPerfil de cada nivel de riesgo
df_riesgo %>%
group_by(nivel_riesgo) %>%
summarise(
clientes = n(),
edad_promedio = mean(Age),
antiguedad_promedio = mean(Tenure),
frecuencia_uso = mean(Usage.Frequency),
llamadas_soporte = mean(Support.Calls),
retrasos_pago = mean(Payment.Delay),
gasto_promedio = mean(Total.Spend),
interaccion_promedio = mean(Last.Interaction),
score_promedio = mean(churn_risk_score)
)## # A tibble: 5 × 10
## nivel_riesgo clientes edad_promedio antiguedad_promedio frecuencia_uso
## <chr> <int> <dbl> <dbl> <dbl>
## 1 Riesgo Alto 25938 41.5 30.6 15.5
## 2 Riesgo Bajo 41757 39.2 31.3 15.9
## 3 Riesgo Medio 26968 40.7 30.9 15.5
## 4 Riesgo Muy Alto 201234 42.2 30.3 15.4
## 5 Riesgo Muy Bajo 144935 34.8 32.8 16.5
## # ℹ 5 more variables: llamadas_soporte <dbl>, retrasos_pago <dbl>,
## # gasto_promedio <dbl>, interaccion_promedio <dbl>, score_promedio <dbl>Asignar estrategia a cada grupo
df_riesgo <- df_riesgo %>%
mutate(
estrategia = case_when(
nivel_riesgo == "Riesgo Muy Alto" ~
"Contacto inmediato y oferta de retención",
nivel_riesgo == "Riesgo Alto" ~
"Descuento o beneficio personalizado",
nivel_riesgo == "Riesgo Medio" ~
"Incentivar uso y ofrecer beneficios",
nivel_riesgo == "Riesgo Bajo" ~
"Mantener comunicación y engagement",
nivel_riesgo == "Riesgo Muy Bajo" ~
"Mantener relación y monitorear"
)
)Resultados
head(df_riesgo)## 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
## churn_risk_score nivel_riesgo estrategia
## 1 69.28683 Riesgo Alto Descuento o beneficio personalizado
## 2 100.00000 Riesgo Muy Alto Contacto inmediato y oferta de retención
## 3 99.85614 Riesgo Muy Alto Contacto inmediato y oferta de retención
## 4 100.00000 Riesgo Muy Alto Contacto inmediato y oferta de retención
## 5 100.00000 Riesgo Muy Alto Contacto inmediato y oferta de retención
## 6 99.97792 Riesgo Muy Alto Contacto inmediato y oferta de retencióndf_riesgo %>%
select(nivel_riesgo, estrategia) %>%
distinct()## nivel_riesgo estrategia
## 1 Riesgo Alto Descuento o beneficio personalizado
## 2 Riesgo Muy Alto Contacto inmediato y oferta de retención
## 3 Riesgo Medio Incentivar uso y ofrecer beneficios
## 4 Riesgo Muy Bajo Mantener relación y monitorear
## 5 Riesgo Bajo Mantener comunicación y engagement