Trabajo Final Módulo Ciencia de Datos
Alejandro Romero Moya
# Código para lectura de datos
# Ruta al archivo CSV descargado
ruta_archivo <- "C:/Users/alexr/OneDrive/Escritorio/Nueva carpeta/archive/telco_customer_churn.csv"
# Leer el archivo CSV y almacenarlo en un dataframe llamado churn_data
churn_data <- read_csv(ruta_archivo)Análisis Exploratorio
Esto nos mostrará una descripción detallada de las columnas del dataframe churn_data, incluyendo el tipo de dato de cada una.
str(churn_data)## spc_tbl_ [7,043 × 21] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
## $ customerID : chr [1:7043] "7590-VHVEG" "5575-GNVDE" "3668-QPYBK" "7795-CFOCW" ...
## $ gender : chr [1:7043] "Female" "Male" "Male" "Male" ...
## $ SeniorCitizen : num [1:7043] 0 0 0 0 0 0 0 0 0 0 ...
## $ Partner : chr [1:7043] "Yes" "No" "No" "No" ...
## $ Dependents : chr [1:7043] "No" "No" "No" "No" ...
## $ tenure : num [1:7043] 1 34 2 45 2 8 22 10 28 62 ...
## $ PhoneService : chr [1:7043] "No" "Yes" "Yes" "No" ...
## $ MultipleLines : chr [1:7043] "No phone service" "No" "No" "No phone service" ...
## $ InternetService : chr [1:7043] "DSL" "DSL" "DSL" "DSL" ...
## $ OnlineSecurity : chr [1:7043] "No" "Yes" "Yes" "Yes" ...
## $ OnlineBackup : chr [1:7043] "Yes" "No" "Yes" "No" ...
## $ DeviceProtection: chr [1:7043] "No" "Yes" "No" "Yes" ...
## $ TechSupport : chr [1:7043] "No" "No" "No" "Yes" ...
## $ StreamingTV : chr [1:7043] "No" "No" "No" "No" ...
## $ StreamingMovies : chr [1:7043] "No" "No" "No" "No" ...
## $ Contract : chr [1:7043] "Month-to-month" "One year" "Month-to-month" "One year" ...
## $ PaperlessBilling: chr [1:7043] "Yes" "No" "Yes" "No" ...
## $ PaymentMethod : chr [1:7043] "Electronic check" "Mailed check" "Mailed check" "Bank transfer (automatic)" ...
## $ MonthlyCharges : num [1:7043] 29.9 57 53.9 42.3 70.7 ...
## $ TotalCharges : num [1:7043] 29.9 1889.5 108.2 1840.8 151.7 ...
## $ Churn : chr [1:7043] "No" "No" "Yes" "No" ...
## - attr(*, "spec")=
## .. cols(
## .. customerID = col_character(),
## .. gender = col_character(),
## .. SeniorCitizen = col_double(),
## .. Partner = col_character(),
## .. Dependents = col_character(),
## .. tenure = col_double(),
## .. PhoneService = col_character(),
## .. MultipleLines = col_character(),
## .. InternetService = col_character(),
## .. OnlineSecurity = col_character(),
## .. OnlineBackup = col_character(),
## .. DeviceProtection = col_character(),
## .. TechSupport = col_character(),
## .. StreamingTV = col_character(),
## .. StreamingMovies = col_character(),
## .. Contract = col_character(),
## .. PaperlessBilling = col_character(),
## .. PaymentMethod = col_character(),
## .. MonthlyCharges = col_double(),
## .. TotalCharges = col_double(),
## .. Churn = col_character()
## .. )
## - attr(*, "problems")=<externalptr>Subsección 1
Esto proporcionará un resumen estadístico para cada columna del dataframe, incluyendo el conteo de valores, media, mediana, mínimo, máximo y cuartiles para las variables numéricas, así como el conteo de niveles y frecuencia de los niveles para las variables categóricas.
summary(churn_data)## customerID gender SeniorCitizen Partner Dependents
## Length:7043 Length:7043 Min. :0.0000 Length:7043 Length:7043
## Class :character Class :character 1st Qu.:0.0000 Class :character Class :character
## Mode :character Mode :character Median :0.0000 Mode :character Mode :character
## Mean :0.1621
## 3rd Qu.:0.0000
## Max. :1.0000
##
## tenure PhoneService MultipleLines InternetService OnlineSecurity
## Min. : 0.00 Length:7043 Length:7043 Length:7043 Length:7043
## 1st Qu.: 9.00 Class :character Class :character Class :character Class :character
## Median :29.00 Mode :character Mode :character Mode :character Mode :character
## Mean :32.37
## 3rd Qu.:55.00
## Max. :72.00
##
## OnlineBackup DeviceProtection TechSupport StreamingTV StreamingMovies
## Length:7043 Length:7043 Length:7043 Length:7043 Length:7043
## Class :character Class :character Class :character Class :character Class :character
## Mode :character Mode :character Mode :character Mode :character Mode :character
##
##
##
##
## Contract PaperlessBilling PaymentMethod MonthlyCharges TotalCharges
## Length:7043 Length:7043 Length:7043 Min. : 18.25 Min. : 18.8
## Class :character Class :character Class :character 1st Qu.: 35.50 1st Qu.: 401.4
## Mode :character Mode :character Mode :character Median : 70.35 Median :1397.5
## Mean : 64.76 Mean :2283.3
## 3rd Qu.: 89.85 3rd Qu.:3794.7
## Max. :118.75 Max. :8684.8
## NA's :11
## Churn
## Length:7043
## Class :character
## Mode :character
##
##
##
## Subsección 2
Gráfico para cada variable excepto customerID, coloreado según la variable Churn.
library(ggplot2)
# Lista de variables excepto customerID
variables <- names(churn_data)[names(churn_data) != "customerID"]
# Función para generar gráficos según el tipo de variable
plot_variable <- function(variable) {
if (is.factor(churn_data[[variable]]) | is.character(churn_data[[variable]])) {
# Gráfico de barras para variables cualitativas
ggplot(churn_data, aes(x = !!sym(variable), fill = Churn)) +
geom_bar(position = "fill") +
labs(title = paste("Frecuencia de", variable),
x = variable, y = "Proporción") +
theme_minimal()
} else {
# Histograma para variables cuantitativas
ggplot(churn_data, aes(x = !!sym(variable), fill = Churn)) +
geom_histogram(position = "identity", alpha = 0.5, bins = 30) +
labs(title = paste("Histograma de", variable),
x = variable, y = "Frecuencia") +
theme_minimal()
}
}
# Generar y mostrar gráficos para cada variable
for (variable in variables) {
plot <- plot_variable(variable)
print(plot)
}
Subseccion 4
Boxplot para la variable MonthlyCharges para cada valor de las variables categóricas listadas. Cada boxplot estará coloreado según el nivel de la variable categórica correspondiente.
# Lista de variables categóricas
variables_categoricas <- c("gender", "SeniorCitizen", "Partner", "Dependents",
"PhoneService", "MultipleLines", "InternetService",
"OnlineSecurity", "OnlineBackup", "DeviceProtection",
"TechSupport", "StreamingTV", "StreamingMovies",
"Contract", "PaperlessBilling", "PaymentMethod")
# Función para generar boxplots para cada variable categórica
boxplot_variable <- function(variable) {
ggplot(churn_data, aes_string(x = variable, y = "MonthlyCharges", fill = variable)) +
geom_boxplot() +
labs(title = paste("Boxplot de MonthlyCharges según", variable),
x = variable, y = "Monthly Charges") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
}
# Generar y mostrar boxplots para cada variable categórica
for (variable in variables_categoricas) {
plot <- boxplot_variable(variable)
print(plot)
}
##Subseccion 5 #### Gráficos de dispersión para cada par de variables numéricas y un gráfico de correlación conjunto entre Tenure y MonthlyCharges
# Lista de variables numéricas
variables_numericas <- c("tenure", "MonthlyCharges", "TotalCharges")
# Función para generar gráficos de dispersión para cada par de variables numéricas
scatter_plot <- function(var1, var2) {
ggplot(churn_data, aes_string(x = var1, y = var2)) +
geom_point() +
labs(title = paste("Gráfico de dispersión entre", var1, "y", var2),
x = var1, y = var2) +
theme_minimal()
}
# Generar y mostrar gráficos de dispersión para cada par de variables numéricas
for (var1 in variables_numericas) {
for (var2 in variables_numericas) {
if (var1 != var2) {
plot <- scatter_plot(var1, var2)
print(plot)
}
}
}
## 6 Información adicional #### Gráfico de densidad que muestra la
distribución de las tarifas mensuales para los clientes que abandonan
(Churn = “Yes”) y los que no abandonan (Churn = “No”). La transparencia
de las áreas coloreadas permitirá ver las superposiciones en las
distribuciones. Esto nos ayudará a visualizar si hay diferencias
notables en las tarifas mensuales entre los clientes que abandonan y los
que no.
library(ggplot2)
# Gráfico de densidad de las tarifas mensuales según el estado de churn
ggplot(churn_data, aes(x = MonthlyCharges, fill = Churn)) +
geom_density(alpha = 0.5) +
labs(title = "Distribución de Tarifas Mensuales según Churn",
x = "Tarifa Mensual", y = "Densidad") +
scale_fill_manual(values = c("#E41A1C", "#377EB8"), name = "Churn",
labels = c("No", "Yes")) +
theme_minimal()
He transformado la variable SeniorCitizen a categórica y he dividido el conjunto de datos en dos subconjuntos: churn_train que contiene las primeras 5000 filas y churn_test que contiene las filas desde la 5001 hasta el final del conjunto de datos original.
# Código para creación de conjuntos de entrenamiento y test
# Transformar la variable SeniorCitizen a categórica
churn_data$SeniorCitizen <- as.factor(churn_data$SeniorCitizen)
# Dividir el conjunto de datos en subconjuntos de entrenamiento y prueba
churn_train <- churn_data[1:5000, ]
churn_test <- churn_data[5001:nrow(churn_data), ]Modelos de Regresión Lineal
Modelo de regresión lineal múltiple utilizando todas las variables predictoras disponibles excepto customerID, TotalCharges y Churn, con MonthlyCharges como variable objetivo. Luego, mostrará un resumen del modelo que incluye estadísticas como coeficientes, errores estándar, valores t y valores p para cada variable predictora.
# Definir las variables predictoras excluyendo customerID, TotalCharges y Churn
variables_predictoras <- setdiff(names(churn_train), c("customerID", "TotalCharges", "Churn", "MonthlyCharges"))
# Ajustar el modelo de regresión lineal múltiple
modelo_regresion <- lm(MonthlyCharges ~ ., data = churn_train[, c(variables_predictoras, "MonthlyCharges")])
# Mostrar un resumen del modelo
summary(modelo_regresion)##
## Call:
## lm(formula = MonthlyCharges ~ ., data = churn_train[, c(variables_predictoras,
## "MonthlyCharges")])
##
## Residuals:
## Min 1Q Median 3Q Max
## -4.1945 -0.5985 0.0031 0.6012 4.8558
##
## Coefficients: (7 not defined because of singularities)
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 2.494e+01 6.914e-02 360.768 <2e-16 ***
## genderMale 6.776e-03 2.887e-02 0.235 0.814
## SeniorCitizen1 2.394e-03 4.203e-02 0.057 0.955
## PartnerYes -1.442e-02 3.519e-02 -0.410 0.682
## DependentsYes 3.866e-02 3.713e-02 1.041 0.298
## tenure 1.047e-04 9.937e-04 0.105 0.916
## PhoneServiceYes 2.006e+01 5.752e-02 348.774 <2e-16 ***
## MultipleLinesNo phone service NA NA NA NA
## MultipleLinesYes 5.006e+00 3.460e-02 144.683 <2e-16 ***
## InternetServiceFiber optic 2.498e+01 4.091e-02 610.653 <2e-16 ***
## InternetServiceNo -2.505e+01 5.699e-02 -439.572 <2e-16 ***
## OnlineSecurityNo internet service NA NA NA NA
## OnlineSecurityYes 4.999e+00 3.815e-02 131.035 <2e-16 ***
## OnlineBackupNo internet service NA NA NA NA
## OnlineBackupYes 5.010e+00 3.578e-02 140.002 <2e-16 ***
## DeviceProtectionNo internet service NA NA NA NA
## DeviceProtectionYes 5.027e+00 3.703e-02 135.756 <2e-16 ***
## TechSupportNo internet service NA NA NA NA
## TechSupportYes 5.024e+00 3.905e-02 128.639 <2e-16 ***
## StreamingTVNo internet service NA NA NA NA
## StreamingTVYes 9.946e+00 3.807e-02 261.246 <2e-16 ***
## StreamingMoviesNo internet service NA NA NA NA
## StreamingMoviesYes 9.984e+00 3.799e-02 262.834 <2e-16 ***
## ContractOne year 1.503e-02 4.541e-02 0.331 0.741
## ContractTwo year 1.713e-02 5.505e-02 0.311 0.756
## PaperlessBillingYes -1.929e-04 3.236e-02 -0.006 0.995
## PaymentMethodCredit card (automatic) -6.483e-02 4.356e-02 -1.488 0.137
## PaymentMethodElectronic check -2.002e-02 4.287e-02 -0.467 0.641
## PaymentMethodMailed check -1.595e-02 4.677e-02 -0.341 0.733
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.019 on 4978 degrees of freedom
## Multiple R-squared: 0.9989, Adjusted R-squared: 0.9989
## F-statistic: 2.08e+05 on 21 and 4978 DF, p-value: < 2.2e-16¿Cuáles son las variables/coeficientes que a un nivel de significancia del 95% podemos concluir que son no nulos?
Basándonos en el resumen del modelo ajustado, las variables/coeficientes que a un nivel de significancia del 95% podemos concluir que son no nulos son:
(Intercept) PhoneServiceYes MultipleLinesYes InternetServiceFiber optic InternetServiceNo OnlineSecurityYes OnlineBackupYes DeviceProtectionYes TechSupportYes StreamingTVYes StreamingMoviesYes Estos coeficientes tienen valores p menores que 0.05, lo que indica que son significativamente diferentes de cero y, por lo tanto, son no nulos.
A partir del valor de los coeficientes, ¿podrías estimar el coste de los diferentes servicios: teléfono, DSL, Fibra, seguridad, TV, etc.?
Servicio de teléfono (PhoneServiceYes): Estimación = $20.06 Servicio de Internet de fibra óptica (InternetServiceFiber optic): Estimación = $24.98 Servicio de Internet sin conexión (InternetServiceNo): Estimación = -$25.05 Servicio de seguridad en línea (OnlineSecurityYes): Estimación = $4.999 Servicio de copia de seguridad en línea (OnlineBackupYes): Estimación = $5.010 Servicio de protección de dispositivos (DeviceProtectionYes): Estimación = $5.027 Servicio de soporte técnico (TechSupportYes): Estimación = $5.024 Servicio de TV en streaming (StreamingTVYes): Estimación = $9.946 Servicio de películas en streaming (StreamingMoviesYes): Estimación = $9.984
Prediccion
# Realizar predicciones sobre el conjunto de prueba
predicciones <- predict(modelo_regresion, newdata = churn_test)
# Calcular el error promedio de las predicciones utilizando RMSE
error <- sqrt(mean((churn_test$MonthlyCharges - predicciones)^2))
# Mostrar el RMSE
print(paste("RMSE:", error))## [1] "RMSE: 1.04563422437291"Muestra de predicciones vs valores reales
library(ggplot2)
# Crear un data frame con las predicciones y los valores reales
df_predicciones <- data.frame(Predicciones = predicciones, Reales = churn_test$MonthlyCharges)
# Crear el gráfico de dispersión
scatter_plot <- ggplot(df_predicciones, aes(x = Reales, y = Predicciones)) +
geom_point(color = "blue", alpha = 0.6) +
geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "red") +
labs(title = "Predicciones vs. Valores Reales",
x = "Valores Reales",
y = "Predicciones") +
theme_minimal()
# Mostrar el gráfico
print(scatter_plot)
Modelos de clasificación
# Convertir la variable Churn a binaria
churn_train$Churn <- ifelse(churn_train$Churn == "Yes", 1, 0)
# Ajustar el modelo de regresión logística
modelo_logistico <- glm(Churn ~ . - customerID, data = churn_train, family = "binomial")
# Mostrar un resumen del modelo ajustado
summary(modelo_logistico)##
## Call:
## glm(formula = Churn ~ . - customerID, family = "binomial", data = churn_train)
##
## Coefficients: (7 not defined because of singularities)
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 2.041e+00 9.781e-01 2.087 0.036913 *
## genderMale -3.655e-02 7.762e-02 -0.471 0.637726
## SeniorCitizen1 1.603e-01 1.007e-01 1.591 0.111602
## PartnerYes 1.889e-02 9.412e-02 0.201 0.840923
## DependentsYes -1.370e-01 1.081e-01 -1.268 0.204835
## tenure -5.838e-02 7.614e-03 -7.668 1.75e-14 ***
## PhoneServiceYes 9.071e-01 7.830e-01 1.159 0.246653
## MultipleLinesNo phone service NA NA NA NA
## MultipleLinesYes 6.454e-01 2.122e-01 3.041 0.002360 **
## InternetServiceFiber optic 2.695e+00 9.627e-01 2.799 0.005126 **
## InternetServiceNo -2.769e+00 9.714e-01 -2.851 0.004364 **
## OnlineSecurityNo internet service NA NA NA NA
## OnlineSecurityYes -2.475e-02 2.140e-01 -0.116 0.907939
## OnlineBackupNo internet service NA NA NA NA
## OnlineBackupYes 2.161e-01 2.110e-01 1.024 0.305834
## DeviceProtectionNo internet service NA NA NA NA
## DeviceProtectionYes 3.105e-01 2.119e-01 1.465 0.142897
## TechSupportNo internet service NA NA NA NA
## TechSupportYes -1.209e-01 2.170e-01 -0.557 0.577262
## StreamingTVNo internet service NA NA NA NA
## StreamingTVYes 9.948e-01 3.932e-01 2.530 0.011410 *
## StreamingMoviesNo internet service NA NA NA NA
## StreamingMoviesYes 9.721e-01 3.940e-01 2.467 0.013615 *
## ContractOne year -6.307e-01 1.300e-01 -4.851 1.23e-06 ***
## ContractTwo year -1.474e+00 2.251e-01 -6.548 5.82e-11 ***
## PaperlessBillingYes 3.296e-01 8.933e-02 3.689 0.000225 ***
## PaymentMethodCredit card (automatic) -1.272e-01 1.374e-01 -0.926 0.354462
## PaymentMethodElectronic check 3.515e-01 1.126e-01 3.123 0.001793 **
## PaymentMethodMailed check -3.556e-02 1.379e-01 -0.258 0.796477
## MonthlyCharges -7.708e-02 3.826e-02 -2.015 0.043943 *
## TotalCharges 3.047e-04 8.573e-05 3.554 0.000380 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5752.7 on 4991 degrees of freedom
## Residual deviance: 4069.0 on 4968 degrees of freedom
## (8 observations deleted due to missingness)
## AIC: 4117
##
## Number of Fisher Scoring iterations: 6Matriz de confusion
# Asegurarse de que los niveles de las variables categóricas sean los mismos en los datos de prueba
churn_test$customerID <- factor(churn_test$customerID, levels = levels(churn_train$customerID))
# Realizar predicciones de probabilidad sobre los datos de prueba
predicciones_prob <- predict(modelo_logistico, newdata = churn_test, type = "response")
# Asignar etiquetas "Yes" y "No" basadas en la probabilidad
churn_pred <- ifelse(predicciones_prob > 0.5, "Yes", "No")
# Crear la matriz de confusión
matriz_confusion <- table(Real = churn_test$Churn, Pred = churn_pred, dnn = c("Real", "Pred"))
# Mostrar la matriz de confusión
print(matriz_confusion)## Pred
## Real No Yes
## No 1337 147
## Yes 258 298Este código calculará la precisión global de la predicción utilizando la matriz de confusión previamente calculada.
# Calcular la precisión global (Accuracy)
accuracy <- sum(diag(matriz_confusion)) / sum(matriz_confusion)
# Mostrar la precisión global
print(paste("Precisión Global (Accuracy):", accuracy))## [1] "Precisión Global (Accuracy): 0.801470588235294"Tasa de falsos positivos
# Calcular la tasa de falsos positivos (FPR)
if ("No" %in% rownames(matriz_confusion) & "Yes" %in% colnames(matriz_confusion)) {
FPR <- matriz_confusion["No", "Yes"] / sum(matriz_confusion["No", ])
} else {
FPR <- NA
}
# Calcular la tasa de falsos negativos (FNR)
if ("Yes" %in% rownames(matriz_confusion) & "No" %in% colnames(matriz_confusion)) {
FNR <- matriz_confusion["Yes", "No"] / sum(matriz_confusion["Yes", ])
} else {
FNR <- NA
}
# Calcular la tasa de verdaderos positivos (TPR)
if ("Yes" %in% rownames(matriz_confusion) & "Yes" %in% colnames(matriz_confusion)) {
TPR <- matriz_confusion["Yes", "Yes"] / sum(matriz_confusion["Yes", ])
} else {
TPR <- NA
}
# Mostrar las métricas
print(paste("Tasa de Falsos Positivos (FPR):", FPR))## [1] "Tasa de Falsos Positivos (FPR): 0.0990566037735849"print(paste("Tasa de Falsos Negativos (FNR):", FNR))## [1] "Tasa de Falsos Negativos (FNR): 0.464028776978417"print(paste("Tasa de Verdaderos Positivos (TPR):", TPR))## [1] "Tasa de Verdaderos Positivos (TPR): 0.535971223021583"Este código ajusta un modelo de regresión logística utilizando las variables Contract, Tenure e InternetService como predictores y la variable Churn como la variable objetivo en el conjunto de entrenamiento.
# Seleccionar las variables predictoras y la variable objetivo en el conjunto de entrenamiento
predictores <- churn_train[, c("Contract", "tenure", "InternetService")]
objetivo <- churn_train$Churn
# Ajustar el modelo de clasificación utilizando regresión logística
modelo_clasificacion <- glm(Churn ~ Contract + tenure + InternetService, data = churn_train, family = "binomial")
# Mostrar un resumen del modelo ajustado
summary(modelo_clasificacion)##
## Call:
## glm(formula = Churn ~ Contract + tenure + InternetService, family = "binomial",
## data = churn_train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.342809 0.074589 -4.596 4.31e-06 ***
## ContractOne year -0.840880 0.123487 -6.809 9.80e-12 ***
## ContractTwo year -1.871985 0.215830 -8.673 < 2e-16 ***
## tenure -0.031043 0.002325 -13.352 < 2e-16 ***
## InternetServiceFiber optic 1.214033 0.086650 14.011 < 2e-16 ***
## InternetServiceNo -1.082981 0.141722 -7.642 2.15e-14 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5757.6 on 4999 degrees of freedom
## Residual deviance: 4255.2 on 4994 degrees of freedom
## AIC: 4267.2
##
## Number of Fisher Scoring iterations: 6# Seleccionar las variables predictoras en el conjunto de prueba
predictores_test <- churn_test[, c("Contract", "tenure", "InternetService")]
# Realizar predicciones en el conjunto de prueba
predicciones <- predict(modelo_clasificacion, newdata = predictores_test, type = "response")
# Asignar etiquetas "Yes" y "No" basadas en la probabilidad
churn_pred <- ifelse(predicciones > 0.5, "Yes", "No")
# Crear la matriz de confusión
matriz_confusion <- table(Real = churn_test$Churn, Pred = churn_pred, dnn = c("Real", "Pred"))
# Calcular la tasa de falsos positivos (FPR)
if ("No" %in% rownames(matriz_confusion) & "Yes" %in% colnames(matriz_confusion)) {
FPR <- matriz_confusion["No", "Yes"] / sum(matriz_confusion["No", ])
} else {
FPR <- NA
}
# Calcular la tasa de falsos negativos (FNR)
if ("Yes" %in% rownames(matriz_confusion) & "No" %in% colnames(matriz_confusion)) {
FNR <- matriz_confusion["Yes", "No"] / sum(matriz_confusion["Yes", ])
} else {
FNR <- NA
}
# Calcular la tasa de verdaderos positivos (TPR)
if ("Yes" %in% rownames(matriz_confusion) & "Yes" %in% colnames(matriz_confusion)) {
TPR <- matriz_confusion["Yes", "Yes"] / sum(matriz_confusion["Yes", ])
} else {
TPR <- NA
}
# Mostrar las métricas
print(paste("Tasa de Falsos Positivos (FPR):", FPR))## [1] "Tasa de Falsos Positivos (FPR): 0.097511768661735"print(paste("Tasa de Falsos Negativos (FNR):", FNR))## [1] "Tasa de Falsos Negativos (FNR): 0.526978417266187"print(paste("Tasa de Verdaderos Positivos (TPR):", TPR))## [1] "Tasa de Verdaderos Positivos (TPR): 0.473021582733813"Simulación de campaña de Retención
# Definir parámetros
AR <- 0.5 # Probabilidad de aceptación del trato
R <- 500 # Retorno medio de la retención en euros
CT <- 100 # Coste del teléfono en euros
# Definir umbrales de clasificación
umbrales <- c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1)
# Inicializar vectores para almacenar beneficios netos y pérdidas
beneficios_netos <- numeric(length(umbrales))
perdidas <- numeric(length(umbrales))
# Calcular beneficio neto y pérdida para cada umbral
for (i in seq_along(umbrales)) {
# Clasificar clientes según el umbral
churn_pred <- ifelse(predicciones_prob > umbrales[i], "Yes", "No")
# Calcular el número de "Churners" y "Non-Churners"
n_churners <- sum(churn_pred == "Yes")
n_non_churners <- sum(churn_pred == "No")
# Calcular el número esperado de aceptaciones del trato y rechazos
aceptaciones <- n_churners * AR
rechazos <- n_churners - aceptaciones
# Calcular el beneficio neto y la pérdida
beneficio_neto <- (R - CT) * aceptaciones
perdida <- R * n_churners
# Almacenar resultados
beneficios_netos[i] <- beneficio_neto
perdidas[i] <- perdida
}
# Mostrar resultados
resultados <- data.frame(Umbral = umbrales, Beneficio_Neto = beneficios_netos, Pérdida = perdidas)
print(resultados)## Umbral Beneficio_Neto Pérdida
## 1 0.0 NA NA
## 2 0.1 NA NA
## 3 0.2 NA NA
## 4 0.3 NA NA
## 5 0.4 NA NA
## 6 0.5 NA NA
## 7 0.6 NA NA
## 8 0.7 NA NA
## 9 0.8 NA NA
## 10 0.9 NA NA
## 11 1.0 NA NA# Realizar predicciones de probabilidad sobre los datos de prueba
predicciones_prob <- predict(modelo_logistico, newdata = churn_test, type = "response")
# Asignar etiquetas "Yes" y "No" basadas en la probabilidad
churn_pred <- ifelse(predicciones_prob > 0.5, "Yes", "No")
# Crear la matriz de confusión
matriz_confusion <- table(Real = churn_test$Churn, Pred = churn_pred, dnn = c("Real", "Pred"))
# Calcular la tasa de falsos positivos (FPR)
if ("No" %in% rownames(matriz_confusion) & "Yes" %in% colnames(matriz_confusion)) {
FPR <- matriz_confusion["No", "Yes"] / sum(matriz_confusion["No", ])
} else {
FPR <- NA
}
# Calcular la tasa de falsos negativos (FNR)
if ("Yes" %in% rownames(matriz_confusion) & "No" %in% colnames(matriz_confusion)) {
FNR <- matriz_confusion["Yes", "No"] / sum(matriz_confusion["Yes", ])
} else {
FNR <- NA
}
# Calcular la tasa de verdaderos positivos (TPR)
if ("Yes" %in% rownames(matriz_confusion) & "Yes" %in% colnames(matriz_confusion)) {
TPR <- matriz_confusion["Yes", "Yes"] / sum(matriz_confusion["Yes", ])
} else {
TPR <- NA
}
# Mostrar las métricas
print(paste("Tasa de Falsos Positivos (FPR):", FPR))## [1] "Tasa de Falsos Positivos (FPR): 0.0990566037735849"print(paste("Tasa de Falsos Negativos (FNR):", FNR))## [1] "Tasa de Falsos Negativos (FNR): 0.464028776978417"print(paste("Tasa de Verdaderos Positivos (TPR):", TPR))## [1] "Tasa de Verdaderos Positivos (TPR): 0.535971223021583"# Definir los valores de las variables
FP <- sum(matriz_confusion["No", "Yes"]) # Falsos positivos
AR <- 0.7 # Probabilidad de aceptación del trato
I <- 100 # Costo del teléfono de regalo
TP <- sum(matriz_confusion["Yes", "Yes"]) # Verdaderos positivos
R <- 500 # Retorno medio de la retención
FN <- sum(matriz_confusion["Yes", "No"]) # Falsos negativos
# Calcular el resultado con campaña
ResultadoConCampaña <- -FP * AR * I - TP * AR * I - TP * (1 - AR) * R - FN * R
# Calcular el resultado sin campaña
ResultadoSinCampaña <- -TP * (1 - AR) * R - FN * R
# Calcular el beneficio neto de la campaña
Beneficio <- ResultadoConCampaña - ResultadoSinCampaña
# Mostrar los resultados
print(paste("Resultado con campaña:", ResultadoConCampaña))## [1] "Resultado con campaña: -204850"print(paste("Resultado sin campaña:", ResultadoSinCampaña))## [1] "Resultado sin campaña: -173700"print(paste("Beneficio neto de la campaña:", Beneficio))## [1] "Beneficio neto de la campaña: -31150"Calcula para cada umbral de probabilidad, el beneficio de la campaña usando las fórmulas anteriores. ¿Cuál sería el umbral de probabilidad para la selección de clientes óptimo para la campaña?. ¿Qué beneficios generaría?
# Definir los umbrales de clasificación
umbrales <- seq(0, 1, by = 0.1)
# Definir los parámetros
I <- 200 # Costo del teléfono de regalo en euros
AR <- 0.4 # Probabilidad de aceptación
R <- 500 # Pérdida por cliente que abandona en euros
# Crear un data frame para almacenar los resultados
resultados <- data.frame(Umbral = umbrales, Beneficio_Neto = rep(NA, length(umbrales)))# Calcular el beneficio neto para cada umbral de probabilidad
for (i in seq_along(umbrales)) {
# Obtener las etiquetas predichas basadas en el umbral
churn_pred_umbral <- ifelse(predicciones_prob > umbrales[i], "Yes", "No")
# Crear la matriz de confusión para el umbral actual
matriz_confusion_umbral <- table(Real = churn_test$Churn, Pred = churn_pred_umbral, dnn = c("Real", "Pred"))
# Imprimir la matriz de confusión
cat("Matriz de confusión para el umbral", umbrales[i], ":\n")
print(matriz_confusion_umbral)
}## Matriz de confusión para el umbral 0 :
## Pred
## Real Yes
## No 1484
## Yes 556
## Matriz de confusión para el umbral 0.1 :
## Pred
## Real No Yes
## No 757 727
## Yes 44 512
## Matriz de confusión para el umbral 0.2 :
## Pred
## Real No Yes
## No 1003 481
## Yes 98 458
## Matriz de confusión para el umbral 0.3 :
## Pred
## Real No Yes
## No 1154 330
## Yes 153 403
## Matriz de confusión para el umbral 0.4 :
## Pred
## Real No Yes
## No 1248 236
## Yes 202 354
## Matriz de confusión para el umbral 0.5 :
## Pred
## Real No Yes
## No 1337 147
## Yes 258 298
## Matriz de confusión para el umbral 0.6 :
## Pred
## Real No Yes
## No 1403 81
## Yes 341 215
## Matriz de confusión para el umbral 0.7 :
## Pred
## Real No Yes
## No 1454 30
## Yes 441 115
## Matriz de confusión para el umbral 0.8 :
## Pred
## Real No Yes
## No 1482 2
## Yes 545 11
## Matriz de confusión para el umbral 0.9 :
## Pred
## Real No
## No 1484
## Yes 556
## Matriz de confusión para el umbral 1 :
## Pred
## Real No
## No 1484
## Yes 556