PROYECTO DE ML PREDICTIVO PARA MODELO DE PREVENCIÓN DE ABANDONO
Jorge Márquez Serret
14/10/2020
df <- read.csv('Telco-Customer-Churn.csv')
df<- as.data.frame(df)1 INTRODUCCIÓN
1.1 CASO DE NEGOCIO
En este proyecto, aplicaremos técnicas de machine learning predictivo sobre un conjunto de datos liberados por la Compañía IBM. Este conjunto de datos, recoge la información sobre los clientes de una compañía de telecomunicaciones. Entre los datos recogidos, se encuentra la información de si el cliente a abandonado la compañía o no.
El objetivo de este proyecto, es desarrollar un modelo que sea capaz de predecir el abandono de un cliente en función de la información procedente de los datos recogidos por la compañía. Este modelo, permitirá a la compañía adelantarse a la decisión de abandono, actuando en consecuencia para maximizar la relación con el cliente en el tiempo y minimizar la pérdida de ingresos generados por el abandono.
1.2 METODOLOGÍA
Para este proyecto, he seguido una metodología situada a medio camino entre las metodologías tradicionales de CRISP-DM y SEMMA, que se adapta mejor en mi opinión al contexto del negocio.
image: 
2 CALIDAD DE DATOS.
2.1 ANÁLISIS EXPLORATORIO GENERAL Y DE TIPOLOGÍA DE VARIABLES.
Este primer apartado, nos sirve como primera toma de contacto con los datos. Vamos a hacer un análisis de la distribución de las variables y la información que contienen, para ver con que herramientas contamos para enfrentarnos al problema, el abandono de los clientes.
Analizando la información importada en el dataset, nos encontramos con un data set compuesto por 21 variables y 7043 observaciones. Procedentes de la información de una compañía de telecomunicaciones. La información es estática y no tenemos una ventana temporal para analizar.
También, podemos observar que a priori muchas de las variables del data set, no han sido codificadas correctamente, en la siguiente fase analizaremos una a una cada variable y realizaremos las recodificaciones necesarias.
str(df)## 'data.frame': 7043 obs. of 21 variables:
## $ customerID : chr "7590-VHVEG" "5575-GNVDE" "3668-QPYBK" "7795-CFOCW" ...
## $ gender : chr "Female" "Male" "Male" "Male" ...
## $ SeniorCitizen : int 0 0 0 0 0 0 0 0 0 0 ...
## $ Partner : chr "Yes" "No" "No" "No" ...
## $ Dependents : chr "No" "No" "No" "No" ...
## $ tenure : int 1 34 2 45 2 8 22 10 28 62 ...
## $ PhoneService : chr "No" "Yes" "Yes" "No" ...
## $ MultipleLines : chr "No phone service" "No" "No" "No phone service" ...
## $ InternetService : chr "DSL" "DSL" "DSL" "DSL" ...
## $ OnlineSecurity : chr "No" "Yes" "Yes" "Yes" ...
## $ OnlineBackup : chr "Yes" "No" "Yes" "No" ...
## $ DeviceProtection: chr "No" "Yes" "No" "Yes" ...
## $ TechSupport : chr "No" "No" "No" "Yes" ...
## $ StreamingTV : chr "No" "No" "No" "No" ...
## $ StreamingMovies : chr "No" "No" "No" "No" ...
## $ Contract : chr "Month-to-month" "One year" "Month-to-month" "One year" ...
## $ PaperlessBilling: chr "Yes" "No" "Yes" "No" ...
## $ PaymentMethod : chr "Electronic check" "Mailed check" "Mailed check" "Bank transfer (automatic)" ...
## $ MonthlyCharges : num 29.9 57 53.9 42.3 70.7 ...
## $ TotalCharges : num 29.9 1889.5 108.2 1840.8 151.7 ...
## $ Churn : chr "No" "No" "Yes" "No" ...sapply(df, summary)## $customerID
## Length Class Mode
## 7043 character character
##
## $gender
## Length Class Mode
## 7043 character character
##
## $SeniorCitizen
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0000 0.0000 0.0000 0.1621 0.0000 1.0000
##
## $Partner
## Length Class Mode
## 7043 character character
##
## $Dependents
## Length Class Mode
## 7043 character character
##
## $tenure
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.00 9.00 29.00 32.37 55.00 72.00
##
## $PhoneService
## Length Class Mode
## 7043 character character
##
## $MultipleLines
## Length Class Mode
## 7043 character character
##
## $InternetService
## Length Class Mode
## 7043 character character
##
## $OnlineSecurity
## Length Class Mode
## 7043 character character
##
## $OnlineBackup
## Length Class Mode
## 7043 character character
##
## $DeviceProtection
## Length Class Mode
## 7043 character character
##
## $TechSupport
## Length Class Mode
## 7043 character character
##
## $StreamingTV
## Length Class Mode
## 7043 character character
##
## $StreamingMovies
## Length Class Mode
## 7043 character character
##
## $Contract
## Length Class Mode
## 7043 character character
##
## $PaperlessBilling
## Length Class Mode
## 7043 character character
##
## $PaymentMethod
## Length Class Mode
## 7043 character character
##
## $MonthlyCharges
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 18.25 35.50 70.35 64.76 89.85 118.75
##
## $TotalCharges
## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## 18.8 401.4 1397.5 2283.3 3794.7 8684.8 11
##
## $Churn
## Length Class Mode
## 7043 character character2.2 ANÁLISIS DE LA DISTRIBUCIÓN DE LAS VARIABLES Y LA PENETRACIÓN DE LA TARGET
En este punto, analizaremos individualmente cada variable, con el objetivo de poder ver más al detalle la información que aportan, como se distribuyen y como afecta la penetración de la variable Target en cada variable. La variable Target o variable objetivo del análisis, es la variable Churn, que recoge la información sobre el abandono del cliente.
2.2.1 gender:
La variable gender, hace referencia al sexo del cliente, la variable es de tipo factor y está distribuida prácticamente al 50% entre mujeres y hombres. La penetración de la Target es igual en ambas categorías.
#analizamos la variable gender.
df$gender <- as.factor(df$gender)
summary(df$gender)## Female Male
## 3488 3555ggplot(df,aes(gender, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "gender") #realizamos un gráfico de barras para observar la distribución y la penetración de la target por cada categoría.
2.2.2 SeniorCitizen:
La variable SeniorCitizen, determina si el cliente es una persona es mayores (1) o no (0). Probablemente para determinar su comportamiento en función de la edad. Es de tipo factor, y esta puede tomar los valores 0 / 1. Distribuida en un 80% (5901) por 0 y un 20% (1142) por 1. Recategorizamos la variable a tipo factor.
La penetración de la Target en esta variable es mayor para la categoría 0, los clientes mayores abandonan menos la compañía que los que no lo son.
#analizamos la variable SeniorCitizen
df$SeniorCitizen<-as.factor(df$SeniorCitizen)# recategorizamos la variable a factor
table(df$SeniorCitizen)##
## 0 1
## 5901 1142ggplot(df,aes(SeniorCitizen, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "SeniorCitizen")
2.2.3 Partner:
La variable Partner, se refiere a si el cliente tiene o no pareja, se trata de una variable de tipo factor, con dos categorías, sí o no, por lo que la recategorizamos a factor. Para facilitar la comprensión de los datos, cambiaremos las etiquetas por 0/1 de forma que guarden coherencia con el resto de variables.
Se distribuye 51,7 % 0 y 48,3% 1. La penetración de la Target es mayor para los clientes que no tienen pareja. Los clientes sin pareja tienden a abandonar la compañía más que los clientes con pareja. Esto puede deberse a que, por lo general, es más sencillo cambiar de compañía una única persona que varias.
#analizamos la variable partner.
df$Partner <- as.factor(df$Partner)
class(df$Partner)## [1] "factor"levels(df$Partner)[levels(df$Partner)=='Yes']<- 1
levels(df$Partner)[levels(df$Partner)=='No']<- 0
summary(df$Partner)## 0 1
## 3641 3402ggplot(df,aes(Partner, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "Partner")
2.2.4 Dependents:
La variable Dependents, hace referencia a si el cliente depende de alguna otra persona/cliente, esto puede entenderse si el cliente se trata de un menor de edad o un joven que depende de sus padres o si se trata de un trabajador que depende del responsable de la empresa. Es decir, si el cliente puede tomar decisiones relevantes sobre los productos por su cuenta o si no puede. Se trata de una variable que debe ser de tipo factor 0/1.
Se distribuye 0= 70% ( 4933) 1= 30% (2110 ) y la penetración de la Target tiene mayor incidencia para el grupo de clientes que no es dependiente de otra persona. Esto, desde el punto de vista de negocio, es coherente, ya que es más fácil que el cliente cambie de compañía si la decisión depende de él.
#analizamos la variable dependents.
df$Dependents <- as.factor(df$Dependents)#pasamos la variable a factor
levels(df$Dependents)[levels(df$Dependents)=='Yes']<- 1 # cambiamos yes/no por 0/1
levels(df$Dependents)[levels(df$Dependents)=='No']<- 0
summary(df$Dependents)## 0 1
## 4933 2110ggplot(df,aes(Dependents, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "Dependents")
2.2.5 Tenure:
La variable tenure hace referencia al número de meses que el cliente lleva en la compañía. Es una variable de tipo entero y se distribuye de la siguiente manera:
#analizamos la variable tenure.
summary(df$tenure)#estadísticos básicos## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.00 9.00 29.00 32.37 55.00 72.00table(df$tenure) # para ver que cauntos registros tiene el valor 72 ( max ) ya que se concentra un número de registros significativamente más alto que en el resto de registros.##
## 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
## 11 613 238 200 176 133 110 131 123 119 116 99 117 109 76 99 80 87 97 73
## 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
## 71 63 90 85 94 79 79 72 57 72 72 65 69 64 65 88 50 65 59 56
## 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59
## 64 70 65 65 51 61 74 68 64 66 68 68 80 70 68 64 80 65 67 60
## 60 61 62 63 64 65 66 67 68 69 70 71 72
## 76 76 70 72 80 76 89 98 100 95 119 170 362ggplot(df,aes(tenure, fill=Churn)) + geom_histogram() + scale_x_continuous(breaks=seq(0, 72, 5))## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Podemos observar como el 75% de la distribución de los clientes, se concentran entorno a los 55 meses de antigüedad, es decir 4,6 años de antigüedad. Por lo que se puede deducir que la relación con la compañía es de largo plazo. Por otro lado, vemos que hay un gran peso también en las nuevas captaciones, entre 0 y 2 meses de antigüedad, el mayor número de registros está concentrado en clientes con 1 mes de antigüedad, podría responder a una campaña comercial (600 registros) .
De media los clientes tienen una antigüedad de 2,7 años y como máximo 6 años.
Otro aspecto a tener en cuenta, es la concentración de valores en torno al valor 72 que registra 362 entradas, lo que es un valor muy elevado teniendo en cuenta el resto de los registros de la variable. Esto puede estar debido a un problema a la hora de registrar la variable o a un cambio en el modo de registrarla. Siendo hace 72 meses el momento en el que se hizo el cambio y todos los registros anteriores a esa fecha, se imputaron a ese momento. Por ejemplo.
La penetración de la Target, tiene mayor incidencia en los clientes con menor antigüedad, la compañía es capaz de mantener los clientes a largo plazo, esta es una buena señal.
2.2.6 PhoneService:
La variable PhoneService, hace referencia a si el cliente tiene contratado el servicio de telefonía. Debe ser de tipo factor 0= no contratado, 1 = contratado. La variable se distribuye en un 9,76 % 0 y un 90% 1, lo que quiere decir que la gran mayoría de los clientes, tiene contratada línea de teléfono. La variable está desbalanceada y tiene una penetración de la Target significativamente mayor, para los clientes que tienen contratado el servicio de teléfono.
#analizamos la variable PhoneService.
df$PhoneService<- as.factor(df$PhoneService)
levels(df$PhoneService)[levels(df$PhoneService)=='No']<- 0
levels(df$PhoneService)[levels(df$PhoneService)=='Yes']<- 1
table(df$PhoneService)##
## 0 1
## 682 6361ggplot(df,aes(PhoneService, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "PhoneService")
2.2.7 MultipleLines:
La variable MultipleLines, hace referencia a si el cliente tiene contratadas varias líneas o si por el contrario solo tiene 1 o ninguna línea. Es una variable de tipo factor con 1= tiene varias líneas, 0= tiene 1 línea , no phone service = no tiene servicio de teléfono, el número de registros para esta última categoría coincide con el de los clientes que no tenían contratados línea de teléfono en la anterior variable (PhoneService ), por lo que determinamos que esta variable es una variable dependiente de la variable PhoneService.
En cuanto a la distribución, de los 7043 clientes, 682 no tienen línea (9,7%), 3390 tienen una única línea (48%) y 2971 tienen más de una línea (42%). La penetración de la variable target, es muy similar en las distintas categorías, los clientes abandonan la compañía de igual manera si tienen una o varias líneas. La penetración de la categoría ’ No Internet Service’ es la misma que la observada anteriormente en la variable PhoneService, lo que confirma lo que habíamos descrito.
#analizamos la variable MultipleLines
df$MultipleLines<- as.factor(df$MultipleLines)
levels(df$MultipleLines)[levels(df$MultipleLines)=='No']<- 0
levels(df$MultipleLines)[levels(df$MultipleLines)=='Yes']<- 1
table(df$MultipleLines)##
## 0 No phone service 1
## 3390 682 2971ggplot(df,aes(MultipleLines, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "MultipleLines")
2.2.8 InternetService:
La variable InternetService, hace referencia a si el cliente tiene/ no tiene internet contratado. De tenerlo, lo diferencia en dos tipos: adsl y fibra opt. En la distribución de la variable, del total de 7043 clientes, 1526 ( 21,66% ) no tienen contratado el servicio de internet, 5517 ( 78,7% de los clientes) tienen contratado internet 2421 ( 43% ) adsl y 3096 ( 56%) fibra.
Podemos ver, que los clientes que tienen contratado el servicio de fibra, que son la mayoría, tienen una tasa de abandono mucho mayor que los clientes que tienen contratado adsl o no tienen internet. De este comportamiento de los clientes se puede identificar un fallo o deficiencia en el servicio ofrecido, que está haciendo que los clientes no estén contentos y abandonen la compañía. La empresa debería de comprobarlo.
#analizamos InternetService
summary(df$InternetService)## Length Class Mode
## 7043 character characterdf$InternetService<- as.factor(df$InternetService)
ggplot(df,aes(InternetService, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "InternetService")
2.2.9 OnlineSecurity:
La variable OnlineSecurity, hace referencia a si el cliente tiene/ no tiene servicio de protección de internet contratado. Tiene tres categorías, Si / no / no tiene internet contratado.
Esta variable, al igual que sucedía con PhoneService y MultipleLines, depende de la variable InternetService y muestra la misma información que está en la categoría ‘No Internet Service’ ( renombrada a No).
En la distribución, del total de 7043 clientes, 1526 ( 21,66% ) no tienen contratado el servicio de internet. 3498 ( 63,40% ) no tienen el servicio de protección contratado. 2019 (36,6%) tienen el servicio de protección contratado.
En cuanto al abandono de los clientes, podemos observar cómo es significativamente mayor para los clientes que no tienen contratado el servicio de protección. Esto podría estar debido a una mayor dificultad de cambio de compañía cuantos más servicios se tienen contratados.
#analizamos OnlineSecurity.
table(df$OnlineSecurity)##
## No No internet service Yes
## 3498 1526 2019df$OnlineSecurity<- as.factor(df$OnlineSecurity)
levels(df$OnlineSecurity)[levels(df$OnlineSecurity)=='No']<- 0
levels(df$OnlineSecurity)[levels(df$OnlineSecurity)=='Yes']<- 1
ggplot(df,aes(OnlineSecurity, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "OnlineSecurity")
2.2.10 OnlineBackup:
La variable OnlineBuckup hace referencia a si el cliente tiene contratado el servicio de respaldo online para archivos. Es una variable de tipo factor con tres labels, Si / No / No interenet. Igual que sucedía con la variable anterior, esta depende de la variable InternetService.
En la distribución, del total de 7043 clientes, 1526 ( 21,66% ) no tienen contratado el servicio de internet. 5517 ( 78,7% de los clientes) tienen contratado internet. De los cuales, 3088 ( 56% ) no tiene contratado el respaldo y 2429 (44%) tiene contratado el respaldo.
En cuanto al abandono, vemos como la tasa es mayor para los clientes que no tienen contratado el servicio, debido probablemente a una mayor facilidad de cambio cuando no se tienen muchos servicios contratados con la misma compañía.
#analizamos OnlineBackup
table(df$OnlineBackup)##
## No No internet service Yes
## 3088 1526 2429df$OnlineBackup<- as.factor(df$OnlineBackup)
levels(df$OnlineBackup)[levels(df$OnlineBackup)=='No']<- 0
levels(df$OnlineBackup)[levels(df$OnlineBackup)=='Yes']<- 1
ggplot(df,aes(OnlineBackup, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "OnlineBackup")
2.2.11 DeviceProtection:
La variable DeviceProtection, hace referencia a si el cliente tiene contratado el servicio de protección para sus dispositivos. Igual que con las anteriores variables, esta depende de InternetService.
Del total de 7043 clientes, 1526 ( 21,66% ) no tienen contratado el servicio de internet, 5517 ( 78,7% de los clientes),tienen contratado internet. De los cuales, 3095 ( 56% ) no tiene contratado protección para dispositivos y 2422. (44%) tiene contratado la protección para dispositivos.
El comportamiento en el abandono de los clientes, es similar al observado en las variables anteriores y confirma lo descrito.
#analizamos DeviceProtection
table(df$DeviceProtection)##
## No No internet service Yes
## 3095 1526 2422df$DeviceProtection <- as.factor(df$DeviceProtection)
levels(df$DeviceProtection)[levels(df$DeviceProtection)=='No']<- 0
levels(df$DeviceProtection)[levels(df$DeviceProtection)=='Yes']<- 1
ggplot(df,aes(DeviceProtection, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "DeviceProtection")
2.2.12 TechSupport:
La variable TechSupport se refiere a si el cliente tiene contratado o no servicio de asistencia técnica. Es de tipo factor con 3 niveles si / no / no internet. Esta variable también depende de InernetService.
Del total de 7043 clientes, 1526 ( 21,66% ) no tienen contratado el servicio de internet. 5517 ( 78,7% de los clientes), tienen contratado internet. De los cuales, 3473 ( 62,95 % ) no tiene contratada la asistencia y 2044 (37,05%) tiene contratada la asistencia.
El comportamiento es el mismo que el observado en el resto de variables dependientes de InternetService.
#analizamos TechSupport
summary(df$TechSupport)## Length Class Mode
## 7043 character characterdf$TechSupport<- as.factor(df$TechSupport)
levels(df$TechSupport)[levels(df$TechSupport)=='No']<- 0
levels(df$TechSupport)[levels(df$TechSupport)=='Yes']<- 1
ggplot(df,aes(TechSupport, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "TechSupport")
2.2.13 StreamingTV:
La variable StreamingTv, hace referencia a si el cliente tiene contratado el servicio de streaming de televisión. Es de tipo factor con 3 niveles si / no / no internet. Depende de InternetService,
Del total de 7043 clientes, 1526 ( 21,66% ) no tienen contratado el servicio de internet.
5517 ( 78,7% de los clientes),tienen contratado internet. De los cuales, 2810 ( 50,93 % ) no tiene contratada el streaming de tv y 2707 (49,06 %) tiene el streaming de tv contratado.
En cuanto al comportamiento de los clientes a la hora de abandonar la compañía, vemos cómo al contrario que sucedía en el resto de variables que dependen de InternetService, la tasa de abandono es prácticamente igual para los clientes que tienen / no tienen contratado el servicio. Los clientes no tienen en cuenta este servicio a la hora de abandonar la compañía.
# analizamos StreamingTV
table(df$StreamingTV)##
## No No internet service Yes
## 2810 1526 2707df$StreamingTV<- as.factor(df$StreamingTV)
levels(df$StreamingTV)[levels(df$StreamingTV)=='No']<- 0
levels(df$StreamingTV)[levels(df$StreamingTV)=='Yes']<- 1
ggplot(df,aes(StreamingTV, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "StreamingTV")
2.2.14 StreamingMovies:
La variable StreamingMovies , hace referencia a si el cliente tiene contratado el servicio de streaming de películas .Es de tipo factor con 3 niveles si / no / no internet.Depende nuevamente de la variable InternetService.
Del total de 7043 clientes, 1526 ( 21,66% ) no tienen contratado el servicio de internet.
5517 ( 78,7% de los clientes), tienen contratado internet. De los cuales, 2785 ( 50,48 % ) no tiene contratada el streaming de películas, y 2732 (49,51 %) tiene el streaming de películas contratado.
En cuanto a la penetración de la Target, se comporta de la misma manera que el otro servicio de streaming que ofrece la compañía. Los clientes no tienen en cuenta este servicio a la hora de decidir si abandonan o no la compañía.
#analizamos StreamingMovies
table(df$StreamingMovies)##
## No No internet service Yes
## 2785 1526 2732df$StreamingMovies<- as.factor(df$StreamingMovies)
levels(df$StreamingMovies)[levels(df$StreamingMovies)=='No']<- 0
levels(df$StreamingMovies)[levels(df$StreamingMovies)=='Yes']<- 1
ggplot(df,aes(StreamingMovies, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "StreamingMovies")
2.2.15 Contract:
La variable Contract, hace referencia a la duración del contrato de cada cliente con la compañía, este puede ser de mes a mes, de 1 año o de 2 años.
De los 7043 clientes, 3875 (55,19%) tienen un contrato que se renueva mes a mes. 1473 (20,91%) tiene un contrato que se renueva cada año, y 1695 ( 24,06%) que se renueva cada 2 años.
Observamos que los clientes que tienen un contrato mensual, son los que más tienden a abandonar la compañía, seguidos por los contratos anuales y bianuales. Este comportamiento tiene sentido, ya que los clientes con un contrato que se renueva mensualmente, tienen un menor compromiso con la empresa y un mayor incentivo a abandonar que los que renuevan su contrato más a largo plazo.
La compañía debería tratar de incentivar los contratos a largo plazo para reducir el abandono.
#analizamos Contract
table(df$Contract)##
## Month-to-month One year Two year
## 3875 1473 1695df$Contract<- as.factor(df$Contract)
ggplot(df,aes(Contract, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "Contract")
2.2.16 PaperlessBilling:
La variable PaperlessBilling, hace referencia a los clientes que han decidido recibir o no los recibos en papel.
2872 (40,77%) de los clientes prefieren recibirlo en papel y 4171 (59,22%) de los clientes prefieren no recibirlo en papel.
Los clientes que prefieren no recibir las facturas físicamente, tienen una tasa de abandono significativamente mayor. Explicar este comportamiento requeriría mayor conocimiento del negocio.
#analizamos PaperlessBilling.
table(df$PaperlessBilling)##
## No Yes
## 2872 4171df$PaperlessBilling<- as.factor(df$PaperlessBilling)
levels(df$PaperlessBilling)[levels(df$PaperlessBilling)=='No']<- 0
levels(df$PaperlessBilling)[levels(df$PaperlessBilling)=='Yes']<- 1
ggplot(df,aes(PaperlessBilling, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "PaperlessBilling.")
2.2.17 PaymentMethod:
#analizamos PaymentMethod
table(df$PaymentMethod)##
## Bank transfer (automatic) Credit card (automatic) Electronic check
## 1544 1522 2365
## Mailed check
## 1612df$PaymentMethod<- as.factor(df$PaymentMethod)
ggplot(df,aes(PaymentMethod, fill=Churn)) +
geom_bar(aes(y = (..count..)/sum(..count..))) +
scale_y_continuous("PaymentMethod",labels=scales::percent) +
labs(title = "PaymentMethod")
La variable PaymentMethod, refleja el método de pago elegido por cada cliente, es de tipo factor con 4 niveles:
Bank transfer (automatic) 1544 ( 21,92%)
Credit card (automatic) 1522 (21,61%)
Electronic check 2365 (33,57%)
Mailed check 1612 (22,88%)
Analizando el comportamiento de los clientes en esta variable, vemos:
Por un lado, la mayoría de los clientes prefieren pagar mediante comprobante electrónico. Este es un pago que al contrario que la transferencia y el pago con tarjeta, no se realiza de manera automática. Es un pago más premeditado, sucede igual con el pago mediante comprobante por correo.
Por otro lado, vemos como el abandono de los clientes que pagan con comprobante electrónico es mucho mayor que el resto de clientes. esto podría explicarse, por no ser un pago automático, requiere que el cliente compruebe la factura de manera inmediata y una vez comprobada, autorice el pago. De esta manera, requiere la implicación del cliente y podría incentivarle a abandonar si observa algo con lo que no está conforme etc.
2.2.18 MonthlyCharges:
La variable MonthlyCharges recoge la información sobre el importe de los recibos mensuales para cada cliente.
Podemos ver que entorno a los valores 18 -25 € es donde más registros se concentran. Probablemente se deba a la contratación más básica de servicios que está ofreciendo la compañía.
Otro aspecto a tener en cuenta, analizando la forma de la distribución, es que puede que en la variable haya un comportamiento bimodal, es decir, puede que existan dos tipos de clientes en función del número de servicios que tiene contratados y en consecuencia al importe de facturación mensual. Un grupo de clientes más básico, con los servicios básicos contratados y por tanto menor importe mensual, comprendido entre 18-70 € y otro grupo de clientes más premium, con un número de servicios contratados mayor y una facturación comprendida entre 70 y 118€.
Este aspecto, no debería preocuparnos, ya que como veremos más adelante, vamos a trabajar con discretizaciones. Esto nos permitirá dividir la variable en tramos buscando una penetración monotónica que facilite la generalización de los resultados de los modelos.
El comportamiento de los clientes a la hora de abandonar, invita a pensar que efectivamente hay un comportamiento bimodal en la variable. Los clientes con mayor importe, tienden a abandonar menos la compañía, esto puede deberse, a que tiene más servicios contratados, resultando más complejo el cambio. Esto aplica a ambos grupos.
#analizamos MonthlyCharges
summary(df$MonthlyCharges)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 18.25 35.50 70.35 64.76 89.85 118.75ggplot(df)+
geom_bar(aes(x=MonthlyCharges), bins =100)+
scale_x_continuous(breaks=seq(10, 120 , 5)) +
xlab('MonthlyCharges')+
ylab('freq') 
ggplot(df,aes(MonthlyCharges, fill=Churn)) + geom_histogram(bins = 50,position = 'fill') + scale_x_continuous(limits = c(18,120))
2.2.19 TotalCharges:
La variable TotalCharges recoge la información sobre el total de los cargos de los clientes, se entiende que es la información recogida por la variable anterior pero de forma agregada para cada cliente según la antigüedad que tengan (tenure), comprobaremos este aspecto más adelante.
Vemos como la distribución de la variable se concentra de una manera bastante parecida a los cargos mensuales. Concentrando la mayoría de registros en los valores más bajos para la variable 0-250 € y decreciendo a medida que los importes aumentan. Se puede ver un pico en el número de registros que llama la atención en torno a 4700-5000€ que coincidiría con el segundo grupo de clientes identificado en la variable MonthlyCharges.
Podemos ver que hay presencia de 11 valores nulos para la variable, puesto que es un número muy pequeño si lo comparamos con los 7041 registros, los analizaremos en detalle más adelante para decidir qué hacer con ellos.
El comportamiento de los clientes a la hora de abandonar la compañía en función de los cargos totales, tiende a ser mayor en los tramos bajos, probablemente debido a una mayor facilidad de cambio al tener menos servicios, y a una menor antigüedad. Por el contrario, a medida que los importes totales aumentan, el abandono va decreciendo, debido probablemente a una mayor dificultad de cambio por tener un mayor número de servicios contratados y una mayor antigüedad.
#analizamos la variable TotalCharges
summary(df$TotalCharges)## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## 18.8 401.4 1397.5 2283.3 3794.7 8684.8 11ggplot(df)+#creamos un gráfico de frecuencias.
geom_freqpoly(aes(x=TotalCharges), bins =100)+
scale_x_continuous(breaks=seq(0, 8700 , 400 )) +
xlab('Totalharges')+
ylab('freq') 
ggplot(df,aes(TotalCharges, fill=Churn)) + geom_histogram(bins = 50,position = 'fill') + scale_x_continuous(limits = c(0,8000))# generamos un gráfico de barras para ver la penetración de la target.
2.2.20 Churn:
La variable Churn, recoge la información sobre el abandono de los clientes. se trata de la variable Target del proyecto.
Entorno al 27% de los clientes de la base de estudio han abandonado la compañía.
#analizamos la variable Churn
df$Churn<-as.factor(df$Churn)
levels(df$Churn)[levels(df$Churn)=='No']<- 0
levels(df$Churn)[levels(df$Churn)=='Yes']<- 1
table(df$Churn)##
## 0 1
## 5174 1869prop.table(table(df$Churn))##
## 0 1
## 0.7346301 0.2653699ggplot(df, aes(x = Churn)) +
geom_bar(width = 0.4, fill='salmon', aes(y = (..count..)/sum(..count..))) +
scale_x_discrete("NO / SI") +
scale_y_continuous("Porcentaje",labels=scales::percent) +
labs(title = "Churn")
2.3 ANÁLISIS DE CEROS Y NULOS.
data.frame(colSums(is.na(df)))| colSums.is.na.df.. | |
|---|---|
| customerID | 0 |
| gender | 0 |
| SeniorCitizen | 0 |
| Partner | 0 |
| Dependents | 0 |
| tenure | 0 |
| PhoneService | 0 |
| MultipleLines | 0 |
| InternetService | 0 |
| OnlineSecurity | 0 |
| OnlineBackup | 0 |
| DeviceProtection | 0 |
| TechSupport | 0 |
| StreamingTV | 0 |
| StreamingMovies | 0 |
| Contract | 0 |
| PaperlessBilling | 0 |
| PaymentMethod | 0 |
| MonthlyCharges | 0 |
| TotalCharges | 11 |
| Churn | 0 |
info_nulos <- subset(df,is.na(df$TotalCharges)) #creamos un df que recoja los registros que tienen valores nulos para poder verlos con mas detalle
info_nulos%>%
select(tenure,MonthlyCharges,Contract,TotalCharges,Churn) #hacemos zoom sobre los registros del resto de variables , Para los clientes que tienen nulos.| tenure | MonthlyCharges | Contract | TotalCharges | Churn | |
|---|---|---|---|---|---|
| 489 | 0 | 52.55 | Two year | NA | 0 |
| 754 | 0 | 20.25 | Two year | NA | 0 |
| 937 | 0 | 80.85 | Two year | NA | 0 |
| 1083 | 0 | 25.75 | Two year | NA | 0 |
| 1341 | 0 | 56.05 | Two year | NA | 0 |
| 3332 | 0 | 19.85 | Two year | NA | 0 |
| 3827 | 0 | 25.35 | Two year | NA | 0 |
| 4381 | 0 | 20.00 | Two year | NA | 0 |
| 5219 | 0 | 19.70 | One year | NA | 0 |
| 6671 | 0 | 73.35 | Two year | NA | 0 |
| 6755 | 0 | 61.90 | Two year | NA | 0 |
df<-na.omit(df)# eliminamos todos los registros que tengan algún nulo en al menos 1 variable.Como ya identificamos en el apartado anterior, la variable totalcharges tenía 11 registros nulos
Podemos observar a qué se debe la presencia de valores nulos en la variable totalcharges. Para los clientes que tienen una antigüedad de 0 meses, que, además, no tienen un contrato de facturación mensual; el valor de cargos totales es =Na. Ya que aún no se ha registrado nada en esta variable.
Puesto que es un número de registros muy bajo y además, ninguno ha abandonado la empresa (Churn=0), que es el evento que queremos predecir. Procederemos a eliminar estos registros de nuestro data frame.
Por otro lado, no tiene sentido realizar un análisis de 0’s puesto que las dos únicas variables continuas, presentan valores mínimos >0.
2.4 ANÁLISIS DE VALORES ATÍPICOS.
#Comenzamos con las variables de tipo continuo desde el punto de vista tradicional.
#MonthlyCharges:
atipicos_MonthlyCharges <- df %>%
filter(MonthlyCharges >= 3*sd(df$MonthlyCharges))# filtramos por aquellos valores que están > 3x dt.
dim(atipicos_MonthlyCharges)## [1] 1702 21boxplot(df$MonthlyCharges,
xlab= 'MonthlyCharges') #hacemos un gráfico boxplot para ver los valores que salen de la amplitud intercuartílica y se considerarían atípicos. 
#TotalCharges:
atipicos_TotalCharges <- df %>%
filter(TotalCharges >= 3*sd(df$TotalCharges))# filtramos por aquellos valores que están > 3x dt.
dim(atipicos_TotalCharges)## [1] 395 21 boxplot(df$TotalCharges,
xlab='TotalCharges') #hacemos un gráfico boxplot para ver los valores que salen de la amplitud intercuartílica y se considerarían atípicos. 
Comenzamos por las variables de tipo continuo, como son: MonthlyCharges y TotalCharges
MonthlyCharges, partiendo de la metodología clásica, consideraremos como atípico todo valor situado por encima de dos veces la desviación típica. De esta manera, estaríamos considerando como atípicos a todos aquellos valores de la variable > 90.25, o lo que es lo mismo, consideraría como atípicos a 1702 registros (25%) de la variable. Esto es claramente demasiados registros y carece de sentido desde el punto de vista de negocio.
Con el Gráfico de bigotes o boxplot, podemos ver la amplitud intercuartílica de la variable e identificar aquellos valores situados fuera de esta amplitud, considerando a estos como atípicos. Tanto para la variable MonthlyCharges como para TotalCharges, no hay atípicos.
#analizamos los valores atípicos por el degradado de los valores de las variables.
out <- function(variable) {
t(t(head(sort(variable,decreasing = TRUE),100)))
}
lapply(df,function(x){
if(is.double(x)) out(x)})## $customerID
## NULL
##
## $gender
## NULL
##
## $SeniorCitizen
## NULL
##
## $Partner
## NULL
##
## $Dependents
## NULL
##
## $tenure
## NULL
##
## $PhoneService
## NULL
##
## $MultipleLines
## NULL
##
## $InternetService
## NULL
##
## $OnlineSecurity
## NULL
##
## $OnlineBackup
## NULL
##
## $DeviceProtection
## NULL
##
## $TechSupport
## NULL
##
## $StreamingTV
## NULL
##
## $StreamingMovies
## NULL
##
## $Contract
## NULL
##
## $PaperlessBilling
## NULL
##
## $PaymentMethod
## NULL
##
## $MonthlyCharges
## [,1]
## [1,] 118.75
## [2,] 118.65
## [3,] 118.60
## [4,] 118.60
## [5,] 118.35
## [6,] 118.20
## [7,] 117.80
## [8,] 117.60
## [9,] 117.50
## [10,] 117.45
## [11,] 117.35
## [12,] 117.20
## [13,] 117.15
## [14,] 116.95
## [15,] 116.85
## [16,] 116.80
## [17,] 116.75
## [18,] 116.60
## [19,] 116.60
## [20,] 116.55
## [21,] 116.50
## [22,] 116.45
## [23,] 116.40
## [24,] 116.30
## [25,] 116.25
## [26,] 116.25
## [27,] 116.25
## [28,] 116.20
## [29,] 116.15
## [30,] 116.10
## [31,] 116.10
## [32,] 116.05
## [33,] 116.05
## [34,] 116.05
## [35,] 116.00
## [36,] 115.85
## [37,] 115.80
## [38,] 115.80
## [39,] 115.80
## [40,] 115.80
## [41,] 115.75
## [42,] 115.75
## [43,] 115.65
## [44,] 115.65
## [45,] 115.60
## [46,] 115.60
## [47,] 115.55
## [48,] 115.55
## [49,] 115.55
## [50,] 115.55
## [51,] 115.50
## [52,] 115.50
## [53,] 115.25
## [54,] 115.15
## [55,] 115.15
## [56,] 115.15
## [57,] 115.15
## [58,] 115.10
## [59,] 115.10
## [60,] 115.10
## [61,] 115.05
## [62,] 115.05
## [63,] 115.05
## [64,] 115.05
## [65,] 115.00
## [66,] 114.95
## [67,] 114.95
## [68,] 114.90
## [69,] 114.90
## [70,] 114.85
## [71,] 114.75
## [72,] 114.70
## [73,] 114.65
## [74,] 114.65
## [75,] 114.60
## [76,] 114.60
## [77,] 114.55
## [78,] 114.50
## [79,] 114.50
## [80,] 114.45
## [81,] 114.45
## [82,] 114.35
## [83,] 114.35
## [84,] 114.30
## [85,] 114.30
## [86,] 114.30
## [87,] 114.20
## [88,] 114.10
## [89,] 114.10
## [90,] 114.05
## [91,] 114.05
## [92,] 114.00
## [93,] 114.00
## [94,] 113.95
## [95,] 113.80
## [96,] 113.75
## [97,] 113.65
## [98,] 113.65
## [99,] 113.65
## [100,] 113.65
##
## $TotalCharges
## [,1]
## [1,] 8684.80
## [2,] 8672.45
## [3,] 8670.10
## [4,] 8594.40
## [5,] 8564.75
## [6,] 8547.15
## [7,] 8543.25
## [8,] 8529.50
## [9,] 8496.70
## [10,] 8477.70
## [11,] 8477.60
## [12,] 8476.50
## [13,] 8468.20
## [14,] 8456.75
## [15,] 8443.70
## [16,] 8436.25
## [17,] 8425.30
## [18,] 8425.15
## [19,] 8424.90
## [20,] 8405.00
## [21,] 8404.90
## [22,] 8399.15
## [23,] 8375.05
## [24,] 8349.70
## [25,] 8349.45
## [26,] 8337.45
## [27,] 8333.95
## [28,] 8332.15
## [29,] 8331.95
## [30,] 8317.95
## [31,] 8312.75
## [32,] 8312.40
## [33,] 8310.55
## [34,] 8309.55
## [35,] 8308.90
## [36,] 8306.05
## [37,] 8297.50
## [38,] 8289.20
## [39,] 8277.05
## [40,] 8250.00
## [41,] 8248.50
## [42,] 8244.30
## [43,] 8240.85
## [44,] 8220.40
## [45,] 8196.40
## [46,] 8192.60
## [47,] 8182.85
## [48,] 8182.75
## [49,] 8175.90
## [50,] 8166.80
## [51,] 8165.10
## [52,] 8164.10
## [53,] 8152.30
## [54,] 8129.30
## [55,] 8127.60
## [56,] 8126.65
## [57,] 8124.20
## [58,] 8109.80
## [59,] 8100.55
## [60,] 8100.25
## [61,] 8093.15
## [62,] 8086.40
## [63,] 8078.10
## [64,] 8075.35
## [65,] 8071.05
## [66,] 8065.65
## [67,] 8061.50
## [68,] 8058.85
## [69,] 8058.55
## [70,] 8046.85
## [71,] 8041.65
## [72,] 8035.95
## [73,] 8033.10
## [74,] 8022.85
## [75,] 8016.60
## [76,] 8013.55
## [77,] 8012.75
## [78,] 8003.80
## [79,] 7998.80
## [80,] 7993.30
## [81,] 7990.05
## [82,] 7987.60
## [83,] 7985.90
## [84,] 7984.15
## [85,] 7982.50
## [86,] 7968.85
## [87,] 7966.90
## [88,] 7965.95
## [89,] 7962.20
## [90,] 7953.25
## [91,] 7943.45
## [92,] 7942.15
## [93,] 7939.25
## [94,] 7932.50
## [95,] 7930.55
## [96,] 7922.75
## [97,] 7920.70
## [98,] 7919.80
## [99,] 7904.25
## [100,] 7898.45
##
## $Churn
## NULL#concluimos que no hay grandes saltos en los valores de las variables, no hay valores atípicos.Con un análisis de valores atípicos centrado en un punto de vista más de negocio que estadístico. Observamos los 100 valores más altos de la variable, para ver cómo se comporta el degradado de la esta y poder encontrar algún salto significativo, que pudiéramos fijar como el punto a partir del que consideraremos atípicos, desde el punto de vista de negocio.
Observando el degradado de la variable, concluimos que MonthlyCharges no presenta valores atípicos. En cuanto a TotalCharges, sucede lo mismo que con MonthlyCharges y no presenta valores atípicos.
Concluimos que no hay valores atípicos.
2.5 ANÁLISIS DE COHERENCIA.
En este punto, realizaremos un análisis de coherencia entre las variables para comprobar que las variables que dependen unas de otras, tienen información coherente entre sí.
Como hemos identificado anteriormente, podemos ver dos variables que condicionan el resto de variables: PhoneService e InternetService.
De phone service depende multiple lines. De internet service depende; OnlineSecurity,Onlinebuckup,DeviceProtection,TechSupport,StreamingTv y StreamingVideo. Analizaremos estas variables por un lado.
Por otro lado, analizaremos la cherencia las varibles MonthlyCharges y TotalCharges, en función de la variable Tenure.
Primero, observamos las diferentes categorías que en las que están divididas las variables y realizamos un conteo de los registros de cada una.
#análisis por conteo de las variables dependientes de InternetService y PhoneService.
# Realizamos un table a todas las funciones de tipo factor para ver las categorías posibles y de que depende cada condición.
lapply(df, function(x){
if(is.factor(x)) table(x)})## $customerID
## NULL
##
## $gender
## x
## Female Male
## 3483 3549
##
## $SeniorCitizen
## x
## 0 1
## 5890 1142
##
## $Partner
## x
## 0 1
## 3639 3393
##
## $Dependents
## x
## 0 1
## 4933 2099
##
## $tenure
## NULL
##
## $PhoneService
## x
## 0 1
## 680 6352
##
## $MultipleLines
## x
## 0 No phone service 1
## 3385 680 2967
##
## $InternetService
## x
## DSL Fiber optic No
## 2416 3096 1520
##
## $OnlineSecurity
## x
## 0 No internet service 1
## 3497 1520 2015
##
## $OnlineBackup
## x
## 0 No internet service 1
## 3087 1520 2425
##
## $DeviceProtection
## x
## 0 No internet service 1
## 3094 1520 2418
##
## $TechSupport
## x
## 0 No internet service 1
## 3472 1520 2040
##
## $StreamingTV
## x
## 0 No internet service 1
## 2809 1520 2703
##
## $StreamingMovies
## x
## 0 No internet service 1
## 2781 1520 2731
##
## $Contract
## x
## Month-to-month One year Two year
## 3875 1472 1685
##
## $PaperlessBilling
## x
## 0 1
## 2864 4168
##
## $PaymentMethod
## x
## Bank transfer (automatic) Credit card (automatic) Electronic check
## 1542 1521 2365
## Mailed check
## 1604
##
## $MonthlyCharges
## NULL
##
## $TotalCharges
## NULL
##
## $Churn
## x
## 0 1
## 5163 1869Empezando por Phoneservice, vemos que tiene 680 registros =0 y 6352 =1 hacen un total de 7032. Lo cual es correcto.
Siguiendo con MultipleLines, vemos que tiene No Phone Service = 680, lo cual coincide con la info de la variable principal. Y continua con 0 = 3385 y 1 = 2967. Que hace un total de 6352 lo que coincide con la info de PhoneService =1 de la variable principal.
En cuanto a InternetService, encontramos NO=1520 , DSL=2416 y FIBER= 3096. Lo que hace un total de 7032. Lo cual es correcto. Sumamos las categorías de dsl y fiber para poder analizar las siguientes variables. Hacen un total de 5512.
Continuamos con OnlineSecurity, registre No Internet Service = 1520, lo que coincide con la variable principal. NO= 3497 y Si = 2015 que suman un total de 5512. Que coincide con la info del total de clientes que tienen contratado internet. Es correcto.
OnlineBuckup tiene No Internet Service = 1520, No =3087 y Si = 2425, al igual que con la variable anterior los conteos coinciden con la info de la variable principal.
Para todo el resto de variables que dependen de InternetService, los conteos de los registros coinciden con la info proporcionada por la variable principal.
A continuación, para continuar con el análisis de la coherencia de las variables, crearemos una serie de condiciones de búsqueda, incongruentes desde el punto de vista de negocio, para comprobar si existiera algún registro no coherente.
PhoneService y variables dependientes:
#análisis por cumplimiento de condiciones.
df_coherencia_phone <- select(df,PhoneService, MultipleLines) # creamos un data frame más reducido solo con la variable principal phoneservice y sus variables dependientes de esta.
table(df_coherencia_phone[df_coherencia_phone$PhoneService == 0 & df_coherencia_phone !='No phone service']) # aplicamos un conteo de los registros que cumplan la condición de, no teniendo contratado servicio de teléfono ( = 0 ), tienen un valor para la variable derivada distinto del que se esperaría ( No Phone service). ##
## 0
## 680Aplicamos un conteo de los registros que cumplan la condición de, no teniendo contratado servicio de teléfono ( = 0 ), tienen un valor para la variable dependiente distinto del que se esperaría ( != No Phone service). El resultado es que 0 registros de los 680 que no tienen contratado teléfono, ninguno tiene contratado MultipleLines. El resultado es el esperado y las variables guardan coherencia entre si.
InternetService y variables dependientes:
df_coherencia_internet <- select(df,InternetService,OnlineSecurity,OnlineBackup,DeviceProtection,TechSupport,StreamingTV,StreamingMovies)
df_coherencia_internet <- filter(df_coherencia_internet,InternetService =='No') #filtramos para quedarnos solo con los clientes que no tienen servicio de internet contratado y buscar incongruencias en el resto de variables a partir de estos.
table(df_coherencia_internet$OnlineSecurity != 'No internet service'| df_coherencia_internet$OnlineBackup != 'No internet service' | df_coherencia_internet$DeviceProtection != 'No internet service'| df_coherencia_internet$TechSupport != 'No internet service'| df_coherencia_internet$StreamingTV != 'No internet service'| df_coherencia_internet$StreamingMovies != 'No internet service')##
## FALSE
## 1520# realizamos un table para las variables, haciendo un conteo de los registros para las variables, que fueran diferentes de 'no internet service'. vemos que no hay ningún registro que sea diferente y todas las variables tienen coherencia entre si.En primer lugar hemos creado un data set, con la variable internet service y sus variables dependientes. A este data set, le aplicamos un filtro para quedarnos solo con los registros que tengan un valor No en la variable internet service y a partir de estos, realizamos un conteo de los valores que sean diferentes de ’ No internet service’ , para las diferentes variables dependientes de Internet service. Un registro coherente para estas variables sería ‘No internet service’ y todo resultado distinto sería un error de coherencia.
El resultado es que de los 1520 registros de clientes que no tienen contratado internet, ninguno tiene un valor no esperado para el resto de variables, es decir, no teniendo contratado InternetService, tengan contratado algún servicio que dependa de este. (FALSE=1520) por lo que hay coherencia entre las variables.
MonthlyCharges y ToatalCharges en función de Tenure:
Por último, analizamos la coherencia entre las variables MonthlyCharges, TotalCharges y Tenure. Variables que se entiende que deberían ser variables con una fuerte correlación positiva y mostrando TotalCharges prácticamente una versión acumulada de la información de MonthlyCharges a lo largo del tiempo (Tenure).
Para analizar la coherencia de estas variables, por un lado estudiaremos la correlación entre las variables Y por otro, sus estadísticos principales.
# analizamos la correlación lineal y no lineal entre las variables.
correlacion <- cor(subset(df,select = c(6,19,20)), method ='spearman')# creamos la matriz de correlaciones no lineales (spearman). para las variables MonthlyCharges,TotalCharges y Tenure
correlacion## tenure MonthlyCharges TotalCharges
## tenure 1.0000000 0.2753387 0.8891771
## MonthlyCharges 0.2753387 1.0000000 0.6380322
## TotalCharges 0.8891771 0.6380322 1.0000000correlacion_lineal <- cor(subset(df,select = c(6,19,20)))#matriz de correlación lineal, (pearson)
correlacion_lineal## tenure MonthlyCharges TotalCharges
## tenure 1.0000000 0.2468618 0.8258805
## MonthlyCharges 0.2468618 1.0000000 0.6510648
## TotalCharges 0.8258805 0.6510648 1.0000000corrplot(correlacion,type = 'upper',order = 'hclust',tl.col = 'black', tl.srt = 45)
Vemos que el valor es muy similar para pearson y spearman por lo que podemos determinar que la relación es en su mayoría de tipo lineal, la correlación entre las variables es positiva. siendo muy fuerte entre Tenure-TotalCharges(0.8891771), esta correlación tan fuerte es lo que cabría esperar, siendo TotalCharges una variable que recoge la información acumulada en el tiempo (Tenure) de la variable MonthlyCharges.
La correlación entre MonthlyCharges y TotalCharges es moderadamente fuerte y positiva (0.6380322). La correlación entre MonthlyCharges y Tenure es baja (0.2468618), lo que es un comportamiento que cabría esperar.
#Analisis gráfico de la correlación entre MonthlyCharges y TotalCharges:
ggplot(data=df,aes(x=df$MonthlyCharges,y=df$TotalCharges))+geom_point()
Gráficamente, vemos en primer lugar, que las variables tienen una correlación lineal positiva, debido a la forma que tiene la pendiente, siendo esta una línea diagonal creciente.
Por otro lado, se puede ver como los registros de MonthlyCharges, se concentran en los mismos valores, formando agrupaciones en forma de columna alrededor de los valores. Esto es lo que cabría esperar al tratarse TotalCharges, de una variable que parte de la acumulación de los valores de MonthlyCharges a lo largo de los meses. Vemos cómo este efecto es más pronunciado en la parte izquierda de la gráfica, donde están los importes más bajos y son más frecuentes entre los clientes.
A continuación, analizaremos la coherencia entre estas variables a través de sus estadísticos principales.
df %>%
select(MonthlyCharges,tenure,TotalCharges) %>%
summary()## MonthlyCharges tenure TotalCharges
## Min. : 18.25 Min. : 1.00 Min. : 18.8
## 1st Qu.: 35.59 1st Qu.: 9.00 1st Qu.: 401.4
## Median : 70.35 Median :29.00 Median :1397.5
## Mean : 64.80 Mean :32.42 Mean :2283.3
## 3rd Qu.: 89.86 3rd Qu.:55.00 3rd Qu.:3794.7
## Max. :118.75 Max. :72.00 Max. :8684.8Multiplicamos los valores de la media de MonthlyCharges por la media de Tenure, para ver si los valores obtenidos coinciden de manera aproximada con la media de TotalCharge.
64.7982082 x 32.4217861 = 2100.873647
vemos como el valor que devuelve la operación es de 2100.873647 , y el valor de la media de TotalCharges es de 2283.3004408.
Para comprobar si esta difrencia es aceptable, analizamos la desviación tipica de la variable TotalCharges. 2266.7713619 si la comparamos con la diferencia entre el calculo de la aproximación y el valor de la media, 182.4267939, vemos como la diferencia no es muy grande y esta dentro de los valores aceptables, teniendo en cuenta la desviación típica de la varible.
Realizamos más operaciones del mismo estilo para comprobar el resto de estadísticos.
max(df$MonthlyCharges)*max(df$tenure)## [1] 8550max(df$TotalCharges)-(max(df$MonthlyCharges)*max(df$tenure))## [1] 134.8min(df$MonthlyCharges)*min(df$tenure)## [1] 18.25min(df$TotalCharges)-(min(df$MonthlyCharges)*min(df$tenure))## [1] 0.55Vemos que los valores son muy similares a los valores reales de la variable, y podemos determinar que ambas variables guardan coherencia entre sí.
3 TRANSFORMACIÓN DE DATOS:
3.1 TRANSFORMACIÓN VARIABLES.
Transformación de la variable MultipleLines:
levels(df$MultipleLines)[levels(df$MultipleLines)=='No phone service']<- 0Transformamos los registros ‘No phone service’ de la variable, convirtiendo estos registros a 0 (No MultipleLines) porque es una información redundante que ya aporta la variable PhoneService y generaría problemas de correlación entre las variables en la fase de modelización (especialmente con algoritmo de Regresión logística).
Transformación variables dependientes de InternetService( OnlineSecurity, OnlineBackup, DeviceProtection, TechSupport, StreamingTV, StreamingMovies):
Igual que con la variable anterior, transformamos los registros de las variables para evitar información redundante y problemas de correlación.
levels(df$OnlineSecurity)[levels(df$OnlineSecurity)=='No internet service']<- 0
levels(df$OnlineBackup)[levels(df$OnlineBackup)=='No internet service']<- 0
levels(df$DeviceProtection)[levels(df$DeviceProtection)=='No internet service']<- 0
levels(df$TechSupport)[levels(df$TechSupport)=='No internet service']<- 0
levels(df$StreamingTV)[levels(df$StreamingTV)=='No internet service']<- 0
levels(df$StreamingMovies)[levels(df$StreamingMovies)=='No internet service']<-03.2 DEFINICIÓN DE LA VARIABLE TARGET.
En este proyecto, nuestro objetivo es crear un modelo de prevención de abandono. Por lo tanto, el objetivo será predecir que cliente tiene más probabilidad de abandonar la compañía en función de la información de las variables independientes.
Nuestra variable objetivo o variable dependiente, será la variable Churn. Concretamente , queremos predecir el evento de churn = 1 , el cliente ha abandonado la compañía. Definimos la target a partir de ese evento.
df<- mutate(df,Target= df$Churn)
df<- df %>%
select(-Churn)3.3 PRESELECCIÓN DE VARIABLES INDEPENDIENTES.
Debido al reducido número de variables del dataset, podríamos introducirlas todas en el modelo, aplicaremos RF e INFORMATION VALUE de manera combinada, para tratar de profundizar en las técnicas de preselección de variables.
Definimos en primer lugar, las variables que usaremos para predecir la target.
independientes_larga <- names(df) #creamos una variable que recoja todas las variables del data set.
Target <- df$Target
no_usar <- c('customerID','Target') #creamos un vector con las únicas dos variables que no vamos a usar para predecir.
independientes_larga <- setdiff(independientes_larga,no_usar) # aplicamos lógica de conjuntos para quedarnos con las variables independientes y descartar, la target y el código de cliente que no aportan información.3.3.1 PRESELECCIÓN CON RANDOM FOREST:
El algoritmo de random forest tiene una característica que permite identificar la capacidad predictora de las variables para predecir una variable target.
pre_RF <- randomForest(formula = reformulate(independientes_larga,'Target'), data= df,mtry=2,ntree=50, importance= T) # ejecutamos el algoritmo de RF para que calcule la importancia de las variables para predecir la target.
importancia_RF <- importance(pre_RF)[,4]# nos quedamos con la columna que recoge la info de la importancia de las varibales para predecir la target.
importancia_RF <- data.frame(VARIABLES = names(importancia_RF), IMPORTANCIA_RF = importancia_RF) #lo visualizamos en formato de DF.
importancia_RF <-importancia_RF%>%
arrange(desc(IMPORTANCIA_RF)) %>%
mutate(RANKING_RF = 1:nrow(importancia_RF))
importancia_RF # Lo ordenamos de mayor puntuación a menor, y cremaos un índice Ranking para poder visualizarlo mas fácilmente.| VARIABLES | IMPORTANCIA_RF | RANKING_RF |
|---|---|---|
| tenure | 288.17162 | 1 |
| MonthlyCharges | 222.57338 | 2 |
| TotalCharges | 220.91409 | 3 |
| Contract | 139.71302 | 4 |
| PaymentMethod | 119.91563 | 5 |
| InternetService | 116.58359 | 6 |
| PaperlessBilling | 45.76678 | 7 |
| OnlineSecurity | 45.33127 | 8 |
| TechSupport | 38.03508 | 9 |
| OnlineBackup | 30.35776 | 10 |
| SeniorCitizen | 30.27954 | 11 |
| Partner | 29.00963 | 12 |
| StreamingTV | 27.94084 | 13 |
| Dependents | 27.68999 | 14 |
| DeviceProtection | 27.05474 | 15 |
| gender | 26.76047 | 16 |
| StreamingMovies | 25.98763 | 17 |
| MultipleLines | 25.71354 | 18 |
| PhoneService | 12.78805 | 19 |
3.3.2 PRESELECCIÓN CON CRITERIO WOE E INFORMATION VALUE:
Aplicamos también la técnica de preselección de variables, basada en el information value y el wage of evidence. Que nos permite obtener una medida sobre la capacidad predictora de las variables para predecir la target.
El wage of evidence, es una técnica que busca discretizar una variable, generando cortes que maximicen la diferencia entre la distribución de los que abandonan y los que no abandonan. Se calcula a partir de:
ln(distribución abandonan/ distribución no abandonan)
Por otro lado, el Information value (IV), es una métrica que permite estandarizar el WOE y darnos criterios para analizar la capacidad predictora de la variable.
Pondera la diferencia entre estas dos distribuciones por el valor del WOE, calculado a partir de:
(distribución abandonan-distribución no abandonan)*woe.
Siendo :
IV Menor 0,02<- Predictor inútil
IV Entre 0,02 y 0,1 <- Predictor débil
IV Entre 0,1 y 0,3 <- Predictor medio
IV Entre 0,3 y 0,5 <- Predictor fuerte
IV Mayor 0,5<- Predictor muy fuerte
Nos centraremos en el valor del IV para realizar la preselección de las variables.
df2<-df
df2<- mutate(df,Target=as.numeric(as.character(Target)))# creamos otro data frame en el cual lo único que cambiamos es el formato de la target a numérico, que es el tipo de formato que necesita el woe e iv para trabajar.
importancia_IV <- smbinning.sumiv(df2[c(independientes_larga,'Target')],y= 'Target')# ejecutamos el algoritmo para que identifique las variables más predictoras de la target.##
##
|
| | 0%
|
|-- | 5%
|
|----- | 10%
|
|-------- | 15%
|
|---------- | 20%
|
|------------ | 25%
|
|--------------- | 30%
|
|------------------ | 35%
|
|-------------------- | 40%
|
|---------------------- | 45%
|
|------------------------- | 50%
|
|---------------------------- | 55%
|
|------------------------------ | 60%
|
|-------------------------------- | 65%
|
|----------------------------------- | 70%
|
|-------------------------------------- | 75%
|
|---------------------------------------- | 80%
|
|------------------------------------------ | 85%
|
|--------------------------------------------- | 90%
|
|------------------------------------------------ | 95%
|
|--------------------------------------------------| 100%
## importancia_IV | Char | IV | Process | |
|---|---|---|---|
| 15 | Contract | 1.2332 | Factor binning OK |
| 5 | tenure | 0.8773 | Numeric binning OK |
| 8 | InternetService | 0.6152 | Factor binning OK |
| 18 | MonthlyCharges | 0.4824 | Numeric binning OK |
| 17 | PaymentMethod | 0.4557 | Factor binning OK |
| 19 | TotalCharges | 0.3202 | Numeric binning OK |
| 16 | PaperlessBilling | 0.2020 | Factor binning OK |
| 9 | OnlineSecurity | 0.1719 | Factor binning OK |
| 12 | TechSupport | 0.1574 | Factor binning OK |
| 4 | Dependents | 0.1532 | Factor binning OK |
| 3 | Partner | 0.1179 | Factor binning OK |
| 2 | SeniorCitizen | 0.1051 | Factor binning OK |
| 10 | OnlineBackup | 0.0360 | Factor binning OK |
| 11 | DeviceProtection | 0.0230 | Factor binning OK |
| 13 | StreamingTV | 0.0202 | Factor binning OK |
| 14 | StreamingMovies | 0.0188 | Factor binning OK |
| 7 | MultipleLines | 0.0081 | Factor binning OK |
| 6 | PhoneService | 0.0007 | Factor binning OK |
| 1 | gender | 0.0004 | Factor binning OK |
importancia_IV <- importancia_IV%>%
mutate(RANKING_IV = 1:nrow(importancia_IV)) %>% # creamos un indice para ver el orden más claramente y poder compararlo.
select(-Process)# nos deshacemos de la columna process, que no aporta info más allá de ver que se ha realizado el proceso correctamente.
names(importancia_IV)<- c('VARIABLES','IMPORTANCIA_IV','RANKING_IV') # nombramos las columnas del df, creando un vector de caracteres.
importancia_IV| VARIABLES | IMPORTANCIA_IV | RANKING_IV |
|---|---|---|
| Contract | 1.2332 | 1 |
| tenure | 0.8773 | 2 |
| InternetService | 0.6152 | 3 |
| MonthlyCharges | 0.4824 | 4 |
| PaymentMethod | 0.4557 | 5 |
| TotalCharges | 0.3202 | 6 |
| PaperlessBilling | 0.2020 | 7 |
| OnlineSecurity | 0.1719 | 8 |
| TechSupport | 0.1574 | 9 |
| Dependents | 0.1532 | 10 |
| Partner | 0.1179 | 11 |
| SeniorCitizen | 0.1051 | 12 |
| OnlineBackup | 0.0360 | 13 |
| DeviceProtection | 0.0230 | 14 |
| StreamingTV | 0.0202 | 15 |
| StreamingMovies | 0.0188 | 16 |
| MultipleLines | 0.0081 | 17 |
| PhoneService | 0.0007 | 18 |
| gender | 0.0004 | 19 |
3.3.3 PRESELECCIÓN FINAL:
Combinamos ambas métricas para tener un criterio de selección más robusto y estar seguros de que las variables elegidas tienen realmente una buena capacidad predictora para el evento que estamos estudiando.
IMPORTANCIA_FINAL <- inner_join(importancia_RF,importancia_IV, by = 'VARIABLES')%>% #combinamos las tablas de ambas métricas a partir de la columna variables
mutate(RANKING_TOTAL = RANKING_RF+RANKING_IV)%>% #creamos un ranking total que sea la suma de ambos rankings para poder ver cual es la variable mas predictora a partir de ambos criterios.
arrange(RANKING_TOTAL) #ordenamos por ranking total
IMPORTANCIA_FINAL<- select(IMPORTANCIA_FINAL,RANKING_RF,RANKING_IV,IMPORTANCIA_RF,IMPORTANCIA_IV,VARIABLES,RANKING_TOTAL)# ordenamos para una visualización más clara.
IMPORTANCIA_FINAL| RANKING_RF | RANKING_IV | IMPORTANCIA_RF | IMPORTANCIA_IV | VARIABLES | RANKING_TOTAL |
|---|---|---|---|---|---|
| 1 | 2 | 288.17162 | 0.8773 | tenure | 3 |
| 4 | 1 | 139.71302 | 1.2332 | Contract | 5 |
| 2 | 4 | 222.57338 | 0.4824 | MonthlyCharges | 6 |
| 3 | 6 | 220.91409 | 0.3202 | TotalCharges | 9 |
| 6 | 3 | 116.58359 | 0.6152 | InternetService | 9 |
| 5 | 5 | 119.91563 | 0.4557 | PaymentMethod | 10 |
| 7 | 7 | 45.76678 | 0.2020 | PaperlessBilling | 14 |
| 8 | 8 | 45.33127 | 0.1719 | OnlineSecurity | 16 |
| 9 | 9 | 38.03508 | 0.1574 | TechSupport | 18 |
| 10 | 13 | 30.35776 | 0.0360 | OnlineBackup | 23 |
| 11 | 12 | 30.27954 | 0.1051 | SeniorCitizen | 23 |
| 12 | 11 | 29.00963 | 0.1179 | Partner | 23 |
| 14 | 10 | 27.68999 | 0.1532 | Dependents | 24 |
| 13 | 15 | 27.94084 | 0.0202 | StreamingTV | 28 |
| 15 | 14 | 27.05474 | 0.0230 | DeviceProtection | 29 |
| 17 | 16 | 25.98763 | 0.0188 | StreamingMovies | 33 |
| 16 | 19 | 26.76047 | 0.0004 | gender | 35 |
| 18 | 17 | 25.71354 | 0.0081 | MultipleLines | 35 |
| 19 | 18 | 12.78805 | 0.0007 | PhoneService | 37 |
cor(importancia_IV$IMPORTANCIA_IV,importancia_RF$IMPORTANCIA_RF) # comprobamos si ambas métricas tienen una correlación lineal fuerte para asegurarnos de que ambos criterios de selección de variables tienen sentido.## [1] 0.9736797# en este caso, debido al reducido número de variables, nos vamos a quedar con todas ellas para pasarlas a la siguiente fase e introducirlas en el modelo.En nuestro caso de negocio, debido al reducido número de variables que tenemos, mantenemos todas para pasarlas a la fase de modelización.
4 DISCRETIZACIÓN.
A continuación, discretizaremos las variables que no son categóricas, con el objetivo de aumentar la capacidad explicativa desde el punto de vista de negocio y evitar posibles problemas con los valores atípicos al contenerse dentro del tramo más alto de la variable.
4.1 DISCRETIZACIÓN DE LAS VARIABLES CONTINUAS (MonthlyCharges y TotalCharges):
Para discretizar las variables continuas, lo haremos a partir de los percentiles 20 de la variable. El motivo de hacer las discretizaciones a partir de estos valores, es el de buscar que la penetración de la variable target, sea monotónica.
#Discretización manual Monthly Charges
as.data.frame(quantile(df_original$MonthlyCharges,prob =seq(0,1,length= 6)))#calculamos los valores situados en los percentiles 20.| quantile(df_original$MonthlyCharges, prob = seq(0, 1, length = 6)) | |
|---|---|
| 0% | 18.25 |
| 20% | 25.05 |
| 40% | 58.92 |
| 60% | 79.15 |
| 80% | 94.30 |
| 100% | 118.75 |
df<- df%>% mutate(MonthlyCharges_DISC = as.factor(case_when(
MonthlyCharges >= 18 & MonthlyCharges <= 25 ~ 'MonthlyCharges_DISC1',
MonthlyCharges > 25 & MonthlyCharges <= 59 ~ 'MonthlyCharges_DISC2',
MonthlyCharges > 59 & MonthlyCharges <= 79 ~ 'MonthlyCharges_DISC3',
MonthlyCharges > 79 & MonthlyCharges <= 94 ~ 'MonthlyCharges_DISC4',
MonthlyCharges > 94 ~ 'MonthlyCharges_DISC5'))
) # cremaos los cortes de la variable a partir de los percentiles 20
ggplot(df,aes(MonthlyCharges_DISC,fill=Target))+
geom_bar(position = 'fill') #sacamos la gráfica para ver la penetración de la target.
df<-df %>%
select(-MonthlyCharges)# eliminamos la variable original y nos quedamos con la discretizada.#discretización TotalCharges.
as.data.frame(quantile(df_original$TotalCharges,prob =seq(0,1,length= 6)))| quantile(df_original$TotalCharges, prob = seq(0, 1, length = 6)) | |
|---|---|
| 0% | 18.80 |
| 20% | 267.07 |
| 40% | 944.17 |
| 60% | 2048.95 |
| 80% | 4475.41 |
| 100% | 8684.80 |
df<-df%>% mutate(TotalCharges_DISC=as.factor(case_when(
TotalCharges >= 0 & TotalCharges <= 267 ~ 'MonthlyCharges_DISC1',
TotalCharges > 267 & TotalCharges<= 944 ~ 'MonthlyCharges_DISC2',
TotalCharges > 944 & TotalCharges<= 2050 ~ 'MonthlyCharges_DISC3',
TotalCharges > 2050 & TotalCharges<= 4480 ~ 'MonthlyCharges_DISC4',
TotalCharges > 4480 ~ 'MonthlyCharges_DISC5',
TRUE ~ 'ERROR'))
)
ggplot(df,aes(TotalCharges_DISC,fill=Target))+
geom_bar(position = 'fill') 
df<- select(df,-TotalCharges)4.2 DISCRETIZACIÓN VARIABLE ENTERA TENURE.
Discretizamos la variable de manera automática con Smbinning, el cual encuentra los puntos de corte óptimos de la variable para predecir la target a partir del criterio de Information Value.
# creamos la función discretizar para dsicretizar automaticamente la variable Tenure en función de los puntos óptimos para predecir la target, calculados a partir del criterio de informatión value.
DISCRETIZAR <- function(vi,target) {
temp_df <- data.frame(vi = vi,target = target) # creamos un dataframe temporal con las variables vi ( variable predictora) y target( variable objetivo)
temp_df$target <- as.numeric(as.character(temp_df$target))# tenemos que cambiar la target del df temporal interno de factor a numérico que es como trabaja smbining. as numeric as character para que sea numnérico con 0 y 1 en lugar de 1 y 2.
disc <- smbinning(temp_df, y = 'target', x = 'vi') #llamamos a la función smbining para discretizar el df temporal con los parámetros de target y varibales independientes.
return(disc)
}
disc_temp_tenure <- DISCRETIZAR(df$tenure,df$Target)
disc_temp_tenure$ivtable[1]| Cutpoint |
|---|
| <= 1 |
| <= 5 |
| <= 16 |
| <= 22 |
| <= 49 |
| <= 59 |
| <= 70 |
| > 70 |
| Missing |
| Total |
df_temp <- select(df,tenure,Target)
df_temp <- smbinning.gen(df_temp,disc_temp_tenure,chrname = 'Tenure_DISC')
df<- cbind(df,df_temp[3])%>%select(-tenure)
ggplot(df,aes(Tenure_DISC,fill=Target))+
geom_bar(position = 'fill') 
4.3 ANALISIS GRÁFICO DE LAS DISCRETIZACIONES:
4.3.1 Monthlycharges:
# análisis gráfico MonthlyCharges:
ggplot(df_original,aes(MonthlyCharges, fill=Target)) + geom_histogram(bins = 50,position = 'fill') + scale_x_continuous(limits = c(0,120))#vemos como se distribuye la penetración de la target en la variable original, para comprobar si la penetración puede ser monotónica. ## Warning: Removed 16 rows containing missing values (geom_bar).
ggplot(df,aes(MonthlyCharges_DISC,fill=Target))+
geom_bar(position = 'fill')
Podemos observar que la penetración de la target en la variable MonthlyCharges, no es completamente monotónica, pero se aproxima mucho a serlo. Esto podría estar causado por una distribución bimodal de la variable que requeriría analizar en profundidad con más conocimiento desde el negocio del que tenemos.
Analizando la penetración de la Target en la variable, vemos como la incidencia en el abandono de la compañía aumenta a medida que la factura mensual aumenta. Este comportamiento tiene sentido, ya que, a mayor coste mensual del servicio, mayor iniciativa para cambiar de compañía buscando un menor coste.
Pasaremos la variable a la fase de modelización como una variable discretizada de tipo factor para que el algoritmo considere cada corte de la discretización como una variable independiente.
4.3.2 TotalCharges:
#análisis gráfico TotalCharges:
ggplot(df_original,aes(TotalCharges, fill=Target)) + geom_histogram(bins = 50,position = 'fill') + scale_x_continuous(limits = c(0,8000)) #vemos como se distribuye la penetración de la target en la variable original, para comprobar si la penetración puede ser monotónica. ## Warning: Removed 78 rows containing non-finite values (stat_bin).## Warning: Removed 4 rows containing missing values (geom_bar).
ggplot(df,aes(TotalCharges_DISC,fill=Target))+
geom_bar(position = 'fill')
Para la variable TotalCharges, analizando la penetración de la target en la variable original vemos como se asemeja más a una penetración monotónica, la cual desciende a medida que aumenta el valor de la variable. Esta penetración monotónica se mantiene en la variable discretizada con los puntos de corte en los percentiles 20.
Analizando esta penetración, podemos determinar que, a medida que el importe de la facturación total del cliente aumenta, la probabilidad de que este abandone la compañía disminuye. La iniciativa de abandonar la compañía disminuye en función de los cargos totales.
A esto hay que añadir, que debido a la correlación positiva entre TotalCharges-Tenure, se entiende que, a mayor importe en los cargos totales, también se tiene una mayor antigüedad en la compañía, que hace que la probabilidad de que los clientes abandonen la compañía disminuya.
4.3.3 Tenure:
# análisis gáfico Tenure:
ggplot(df_original,aes(tenure, fill=Target)) + geom_histogram(bins = 50,position = 'fill') 
# vemos como la penetración de la target en la variable original es monotónica
ggplot(df,aes(Tenure_DISC,fill=Target))+
geom_bar(position = 'fill')
Vemos como la penetración de la target en la variable original es monotónica y desciende a medida que el valor de la variable aumenta.
Analizando la penetración de la target para esta variable discretizada, vemos que sigue siendo monotónica y disminuye a medida que el valor de la variable aumenta. De este comportamiento, podemos determinar, que los clientes tienen menor probabilidad de abandonar la compañía cuanto mayor es el tiempo que llevan en esta. La compañía mantiene a los clientes a largo plazo, esta es una buena señal.
Este comportamiento coincide con lo determinado para la Variable TotalCharges, debido a su correlación positiva, a mayor Tenure, también mayor importe de TotalCharges y por tanto menor probabilidad de abandonar la compañía.
5 MODELIZACIÓN.
En esta parte del proyecto, comenzamos a crear el modelo predictivo para el caso de negocio.
Partiremos de la misma formulación de las variables dependientes/independientes y aplicaremos tres algoritmos diferentes, REGRESIÓN LOGÍSTICA, ÁRBOL DE DECISION Y RANDOM FOREST.
La formulación de las variables del modelo es la siguiente:
Target ~ gender + SeniorCitizen + Partner + Dependents + PhoneService +
MultipleLines + InternetService + OnlineSecurity + OnlineBackup +
DeviceProtection + TechSupport + StreamingTV + StreamingMovies +
Contract + PaperlessBilling + PaymentMethod + MonthlyCharges_DISC +
TotalCharges_DISC + Tenure_DISC
set.seed(1234) #creamos una semilla para que lo que hagamos a partir de aquí sea replicable.
Independientes <- setdiff(names(df),c('customerID','Target')) # creamos una variable que recoja las variables independientes.
Target <- 'Target'
formula <- reformulate(Independientes,Target) # definimos la formula del modelo como Target (variable indp) dependiente de Independientes (var independientes)Obviamos la variable de código de cliente, porque es un secuencial que nos sirve para identificar a cada cliente pero que no aporta ningún tipo de información.
5.0.1 MÉTRICAS DE EVALUACIÓN
Crearemos en primer lugar, las métricas que emplearemos para valorar los modelos.
#creamos la función para calcular las métricas de evaluación ( PRECISIÓN COBERTURA ACIERTO F1 ) Y LA MATRIZ DE CONFUSIÓN.
metricas<-function(matriz_conf){
acierto <- (matriz_conf[1,1] + matriz_conf[2,2]) / sum(matriz_conf) *100
precision <- matriz_conf[2,2] / (matriz_conf[2,2] + matriz_conf[1,2]) *100
cobertura <- matriz_conf[2,2] / (matriz_conf[2,2] + matriz_conf[2,1]) *100
F1 <- 2*precision*cobertura/(precision+cobertura)
salida<-c(acierto,precision,cobertura,F1)
return(salida)
}
#creamos la función para hacer la matriz de confusión.
confusion<-function(real,scoring,umbral){
conf<-table(real,scoring>=umbral)
if(ncol(conf)==2) return(conf) else return(NULL)
}#creamos una funció para probar distintos umbrales y ver el efecto sobre precisión y cobertura
umbrales<-function(real,scoring){
umbrales<-data.frame(umbral=rep(0,times=19),acierto=rep(0,times=19),precision=rep(0,times=19),cobertura=rep(0,times=19),F1=rep(0,times=19))
cont <- 1
for (cada in seq(0.05,0.95,by = 0.05)){
datos<-metricas(confusion(real,scoring,cada))
registro<-c(cada,datos)
umbrales[cont,]<-registro
cont <- cont + 1
}
return(umbrales)
}# métricas AUC Y ROC .
roc<-function(prediction){
r<-performance(prediction,'tpr','fpr')
plot(r)
}
auc<-function(prediction){
a<-performance(prediction,'auc')
return(a@y.values[[1]])
}Sepearamos los datos en dos conjuntos Train y Test, repartidos en una proporción de 70-30. De este modo, emplearemos los datos del conjunto de train para entrenar los modelos y los datos de Test, para validar los resultados que proporcionen. De esta forma, el modelo aprende de los datos de Train y valida este aprendizaje sobre los datos de Test, los cuales no conoce previamente, evitando a su vez, el sobreajuste del modelo a los datos.
df$random <- sample(0:1,size = nrow(df), replace = T, prob= c(0.7,0.3)) # creamos una variable aleatoria que tome valores 0 1 de manera aleatoria con una probabilidad 60/40. con un numero de registros = al número de registros del df.
train <- filter(df,random==0) # filtramos los registros en los que tienen un valor de la variable random=0, que hemos creado previamente y es igual al 70% de los registros.
test <- filter(df,random==1) # filtramos el 30% de los registros.
# Eliminamos la variable Random que nos ha servido de filtro y ya no nos sirve.
df<-df%>%
select(-random)
train <- train %>%
select(-random)
test<-test%>%
select(-random)5.1 MODELIZACIÓN CON REGRESIÓN LOGÍSTICA.
Comenzamos modelizando con el algoritmo de regresión logística, el cual, debido a sus características, funciona bien con variables no continuas y dicotómicas, como es el caso de nuestra target a predecir, si el cliente abandona(1) o no (0), en función de la información que tenemos del resto de variables que hemos identificado como predictoras en los pasos anteriores.
También resulta especialmente conveniente, debido a la capacidad de interpretación que ofrece sobre los resultados.
formula_rl_larga<- formula # creamos un nuevo objeto con la formulación de las variables para la RL.
rl_larga<- glm(formula_rl_larga,train, family = binomial(link = 'logit'))# ejecutamos la regresión logística sobre el conjunto de datos de entrenamiento ( train ).
summary(rl_larga) # hacemos un resumen de los valores arrojados por la regresión.##
## Call:
## glm(formula = formula_rl_larga, family = binomial(link = "logit"),
## data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.2247 -0.6561 -0.2741 0.5529 3.1796
##
## Coefficients:
## Estimate Std. Error z value
## (Intercept) 0.57973 0.35876 1.616
## genderMale -0.01987 0.07910 -0.251
## SeniorCitizen1 0.14858 0.10284 1.445
## Partner1 0.02720 0.09428 0.288
## Dependents1 -0.11495 0.10930 -1.052
## PhoneService1 -0.48433 0.18982 -2.552
## MultipleLines1 0.50688 0.10452 4.849
## InternetServiceFiber optic 1.10033 0.23194 4.744
## InternetServiceNo -0.86591 0.35874 -2.414
## OnlineSecurity1 -0.32968 0.10760 -3.064
## OnlineBackup1 -0.10687 0.09929 -1.076
## DeviceProtection1 0.02466 0.09974 0.247
## TechSupport1 -0.30301 0.10907 -2.778
## StreamingTV1 0.39317 0.12233 3.214
## StreamingMovies1 0.28033 0.12223 2.294
## ContractOne year -0.62242 0.13100 -4.751
## ContractTwo year -1.20321 0.21564 -5.580
## PaperlessBilling1 0.35937 0.09152 3.927
## PaymentMethodCredit card (automatic) -0.09064 0.13723 -0.660
## PaymentMethodElectronic check 0.28558 0.11467 2.491
## PaymentMethodMailed check -0.11506 0.14171 -0.812
## MonthlyCharges_DISCMonthlyCharges_DISC2 0.07148 0.34033 0.210
## MonthlyCharges_DISCMonthlyCharges_DISC3 -0.34727 0.43600 -0.796
## MonthlyCharges_DISCMonthlyCharges_DISC4 -0.35408 0.50534 -0.701
## MonthlyCharges_DISCMonthlyCharges_DISC5 -0.29680 0.58596 -0.507
## TotalCharges_DISCMonthlyCharges_DISC2 0.07615 0.19598 0.389
## TotalCharges_DISCMonthlyCharges_DISC3 0.13636 0.26864 0.508
## TotalCharges_DISCMonthlyCharges_DISC4 0.38954 0.35550 1.096
## TotalCharges_DISCMonthlyCharges_DISC5 0.37272 0.42925 0.868
## Tenure_DISC02 <= 5 -0.94407 0.15614 -6.046
## Tenure_DISC03 <= 16 -1.51669 0.21979 -6.900
## Tenure_DISC04 <= 22 -1.95799 0.28476 -6.876
## Tenure_DISC05 <= 49 -2.70260 0.32218 -8.389
## Tenure_DISC06 <= 59 -3.07633 0.39037 -7.881
## Tenure_DISC07 <= 70 -3.20292 0.40708 -7.868
## Tenure_DISC08 > 70 -4.24415 0.53345 -7.956
## Pr(>|z|)
## (Intercept) 0.10611
## genderMale 0.80164
## SeniorCitizen1 0.14852
## Partner1 0.77300
## Dependents1 0.29294
## PhoneService1 0.01073 *
## MultipleLines1 0.00000123875244180 ***
## InternetServiceFiber optic 0.00000209510772241 ***
## InternetServiceNo 0.01579 *
## OnlineSecurity1 0.00219 **
## OnlineBackup1 0.28179
## DeviceProtection1 0.80472
## TechSupport1 0.00547 **
## StreamingTV1 0.00131 **
## StreamingMovies1 0.02182 *
## ContractOne year 0.00000202292004272 ***
## ContractTwo year 0.00000002409700315 ***
## PaperlessBilling1 0.00008611175591357 ***
## PaymentMethodCredit card (automatic) 0.50896
## PaymentMethodElectronic check 0.01276 *
## PaymentMethodMailed check 0.41682
## MonthlyCharges_DISCMonthlyCharges_DISC2 0.83365
## MonthlyCharges_DISCMonthlyCharges_DISC3 0.42575
## MonthlyCharges_DISCMonthlyCharges_DISC4 0.48351
## MonthlyCharges_DISCMonthlyCharges_DISC5 0.61250
## TotalCharges_DISCMonthlyCharges_DISC2 0.69760
## TotalCharges_DISCMonthlyCharges_DISC3 0.61172
## TotalCharges_DISCMonthlyCharges_DISC4 0.27318
## TotalCharges_DISCMonthlyCharges_DISC5 0.38522
## Tenure_DISC02 <= 5 0.00000000148142201 ***
## Tenure_DISC03 <= 16 0.00000000000518200 ***
## Tenure_DISC04 <= 22 0.00000000000615594 ***
## Tenure_DISC05 <= 49 < 0.0000000000000002 ***
## Tenure_DISC06 <= 59 0.00000000000000326 ***
## Tenure_DISC07 <= 70 0.00000000000000360 ***
## Tenure_DISC08 > 70 0.00000000000000178 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5698.6 on 4953 degrees of freedom
## Residual deviance: 3976.8 on 4918 degrees of freedom
## AIC: 4048.8
##
## Number of Fisher Scoring iterations: 6Calculamos la métrica del PseudoR2, para hacer una primera valoración del modelo.Se trata de una adaptación del coeficiente de determinación para una RL. Este indica la cantidad de información que es capaz de explicar el modelo sobre la Target a partir de la información que aportan las variables independientes.
#Calculamos la métrica de PseudoR2, para hacer una primera valoración del modelo.
pr2_rl<- 1 -(rl_larga$deviance / rl_larga$null.deviance)
pr2_rl## [1] 0.3021349Se entiende por buen modelo a partir de 30-40%. Nuestro modelo tiene un PseudoR2 = 0.3021349 lo damos por bueno.
Por otro lado, Seleccionamos las variables que han resultado predictoras de la target con al menos un 90 % de confianza en alguno de sus tramos, para volver a ejecutar la regresión logística sobre estas variables.
a_mantener_rl <- c('PhoneService','MultipleLines','InternetService','OnlineSecurity','OnlineBackup','TechSupport','StreamingTV','StreamingMovies','Contract','PaperlessBilling','PaymentMethod','Tenure_DISC')
formula_rl_corta<- reformulate(a_mantener_rl,Target) # volvemos a formular el modelo con las variables que han resultado predictoras.
rl_corta<- glm(formula_rl_corta,train, family = binomial(link = 'logit')) # ejecutamos de nuevo la regresión logística solo con las variables que el algoritmo a identificado como predictoras.
summary(rl_corta) # analizamos el resultado de aplicar la regresión logística.##
## Call:
## glm(formula = formula_rl_corta, family = binomial(link = "logit"),
## data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.2867 -0.6480 -0.2841 0.5379 3.1490
##
## Coefficients:
## Estimate Std. Error z value
## (Intercept) 0.64352 0.20497 3.140
## PhoneService1 -0.62336 0.15603 -3.995
## MultipleLines1 0.51744 0.09655 5.359
## InternetServiceFiber optic 0.94050 0.11359 8.280
## InternetServiceNo -0.84047 0.16686 -5.037
## OnlineSecurity1 -0.34466 0.10271 -3.356
## OnlineBackup1 -0.10217 0.09217 -1.109
## TechSupport1 -0.33638 0.10284 -3.271
## StreamingTV1 0.40132 0.09661 4.154
## StreamingMovies1 0.28721 0.09588 2.995
## ContractOne year -0.65709 0.12896 -5.095
## ContractTwo year -1.28008 0.21313 -6.006
## PaperlessBilling1 0.36418 0.09114 3.996
## PaymentMethodCredit card (automatic) -0.08781 0.13668 -0.642
## PaymentMethodElectronic check 0.29486 0.11401 2.586
## PaymentMethodMailed check -0.10507 0.14032 -0.749
## Tenure_DISC02 <= 5 -0.96554 0.15204 -6.350
## Tenure_DISC03 <= 16 -1.49164 0.14820 -10.065
## Tenure_DISC04 <= 22 -1.89044 0.18656 -10.133
## Tenure_DISC05 <= 49 -2.42554 0.16379 -14.809
## Tenure_DISC06 <= 59 -2.74562 0.21890 -12.543
## Tenure_DISC07 <= 70 -2.85753 0.23535 -12.142
## Tenure_DISC08 > 70 -3.88837 0.41831 -9.296
## Pr(>|z|)
## (Intercept) 0.001692 **
## PhoneService1 0.000064685373 ***
## MultipleLines1 0.000000083604 ***
## InternetServiceFiber optic < 0.0000000000000002 ***
## InternetServiceNo 0.000000473083 ***
## OnlineSecurity1 0.000792 ***
## OnlineBackup1 0.267634
## TechSupport1 0.001072 **
## StreamingTV1 0.000032693057 ***
## StreamingMovies1 0.002741 **
## ContractOne year 0.000000348058 ***
## ContractTwo year 0.000000001899 ***
## PaperlessBilling1 0.000064412016 ***
## PaymentMethodCredit card (automatic) 0.520553
## PaymentMethodElectronic check 0.009703 **
## PaymentMethodMailed check 0.453984
## Tenure_DISC02 <= 5 0.000000000215 ***
## Tenure_DISC03 <= 16 < 0.0000000000000002 ***
## Tenure_DISC04 <= 22 < 0.0000000000000002 ***
## Tenure_DISC05 <= 49 < 0.0000000000000002 ***
## Tenure_DISC06 <= 59 < 0.0000000000000002 ***
## Tenure_DISC07 <= 70 < 0.0000000000000002 ***
## Tenure_DISC08 > 70 < 0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5698.6 on 4953 degrees of freedom
## Residual deviance: 3988.1 on 4931 degrees of freedom
## AIC: 4034.1
##
## Number of Fisher Scoring iterations: 6#Calculamos el la métrica PseudoR2.
pr2_rl_corta <- 1 -(rl_corta$deviance / rl_corta$null.deviance)
pr2_rl_corta## [1] 0.3001582Comparando los dos modelos según el criterio de akaike y PseudoR2 vemos como el segundo modelo formulado sólo con las variables predictoras, tiene un valor menor para el AIC. Lo que significa que es un modelo mejor y más sencillo. En cuanto al PseudoR2, también vemos como el segundo modelo tiene una capacidad de explicar la Target a partir de las variables independientes del modelo, mayor que en el primer modelo. Aunque esta diferencia es mínima.
Interpretamos los coeficientes que resultan de aplicar la regresión logística sobre las variables que han resultado predictoras.
Comenzamos en primer lugar por los coeficientes positivos ordenados de mayor a menor influencia:
La variable InternetService Fiber optic, con un coeficiente de 0.93214 con signo positivo. La variable, ejerce un efecto positivo a la hora de abandonar la compañía. Es decir, si el cliente tiene contratado el servicio de internet con fibra, tiene mayor probabilidad de abandonar la compañía. De esto, se puede entender que existe un problema con el servicio de fibra.
La variable MultipleLines con un coeficiente de 0.47297 positivo, influye positivamente a la hora de que el cliente decida abandonar la compañía. El cliente puede que no este satisfecho con este servicio.
La variable PaperlessBilling con un coeficiente de 0.36609 de signo pistivo, también ejerce un efecto positivo a la hora de abandonar la compañía.
Las variables StreamingTV y StreamingMovies, con un coeficiente de 0.32780 y 0.30586 respectivamente, de signo positivo. Ejercen efecto positivo a la hora de dicidir abandonar la compañía. Al ser variables que dependen del servicio de Internet, refuerzan la sospecha de que hay un problema con el servicio de interenet que afecta al resto de variables que dependen de esta y hacen que el cliente no este satisfecho.
PaymentMethodElectronic check con un coeficiente positivo de 0.21960, también ejerce un efecto positivo a la hora de abandonar, como describimos en las fases anteriores, esto puede deberse a que este tipo de pago no se realiza automaticamente y requiere que el cliente iteractue, revisando la factura antes de pagar. Esto puede hacer que el cliente detecte algo en la factura o simplemente no este de acuerdo con el importe y haga que auemnte la probabilidad de que abandone la compañía.
En cuanto a los coeficientes con signo negativo, encontramos :
Tenure en esta variable encontramos un coeficiente negativo muy alto, a medida que la antigüedad aumenta, el coeficiente va siendo cada vez mayor. Esto significa que la antigüedad ejerce un efecto negativo a la hora de abandonar. La compañía es capaz de retener a los clientes a largo plazo.
Contract es una variable con coeficiente negativo, que aumenta a medida que aumenta el tiempo del contrato. Clientes con un contrato de 1 o 2 años, tendrán menos probabilidad de cambiar de compañía, que clientes con un contrato mensual.
InternetService No no tener contratado el servicio de internet, ejerce un efecto negativo en el abandono, es decir, los clientes que no tienen contratado Internet, tendrán menos probabilidad de abandono, que los clientes que si que tienen contratado internet. Esto, recalca el problema existente con el servicio de internet. La compañía debería tratar de solucionarlo.
OnlineSecurity y OnlineBackup tiene un coeficiente con signo negativo. Los clientes que tienen contratados estos servicios, tiene menor probabilidad de abandonar la compañía. Probablemente, el hecho de tener contratados varios servicios, hace que se tenga menos flexibilidad a la hora de cambiar de compañía y que el cliente se piense dos veces el abandonar.
PhoneService, tiene un coeficiente con signo negativo, los clientes que tienen contratado el servicio de telefonía, tienen menos probabilidad de abandonar. La compañía está ofreciendo un buen servicio.
Predict_rl <- predict(rl_corta,test,type = 'response') # predecimos los valores para la Targert.
plot(Predict_rl~test$Target) # Hacemos una gráfica para ver que aspecto tienen las predicciones.
Realizamos una predicción de la Target sobre el conjunto de datos de entrenamiento, a partir de las variables que hemos identificado como variables más significativas.
Hacemos un gráfico de los resultados de la predicción, frente a los resultados reales, para ver que aspecto tienen las predicciones. Podemos ver, que para los clientes que no abandonan, el algoritmo asigna las predicciones están concentradas entre 0-30% de probabilidad, con una mediana que situada en torno a un 10%.
Para los clientes que han abandonado la compañía, el algoritmo le asigna una probabilidad concentrada entre un 35-70%, con una mediana entorno a un 50%. Los valores de la predicción parecen aceptables a priori.
Para continuar evaluando el modelo, debemos definir un umbral de decisión a partir del cual la probabilidad que el algoritmo predice, sea considerada como un sí ( el cliente abandona) o un no ( el cliente no abandona ). Para establecer este punto de corte, debemos decidir si queremos maximizar la precisión (los clientes que predecimos como sí realmente son sí) o maximizar la cobertura ( De todos los clientes que realmente van a abandonar, cuantos hemos sido capaces de identificar como sí).
Otra opción, alejada de la decisión desde el punto de vista de negocio es el criterio de la F1, la cual es una métrica que establece el punto óptimo entre Precisión/cobertura.
A priori, Teniendo en cuenta el caso de negocio, interesaria fijar un Umbral de decisión, que priorizara cobertura frente a precisión. Interesa mantener a un cliente el máximo tiempo en la compañía. Además, contactar a un cliente que no estaba planteándose abandonar la compañía, no tendría grandes implicaciones. No obstante, con la información de negocio que tenemos, vamos a optar por fijar el umbral que maximiza la F1 para nuestro proyecto y poder comparar de manera consistente los resultados de los diferentes modelos.
umb_rl<-umbrales(test$Target,Predict_rl)#generamos los diferentes umbrales.
umb_rl| umbral | acierto | precision | cobertura | F1 |
|---|---|---|---|---|
| 0.05 | 53.36862 | 36.82119 | 97.373030 | 53.435848 |
| 0.10 | 62.22329 | 41.67963 | 93.870403 | 57.727517 |
| 0.15 | 68.86429 | 46.55172 | 89.842382 | 61.326958 |
| 0.20 | 73.14726 | 50.66804 | 86.339755 | 63.860104 |
| 0.25 | 74.78345 | 52.68571 | 80.735552 | 63.762102 |
| 0.30 | 76.99711 | 56.06258 | 75.306480 | 64.275037 |
| 0.35 | 78.34456 | 59.18058 | 68.301226 | 63.414634 |
| 0.40 | 79.59577 | 62.69430 | 63.572679 | 63.130435 |
| 0.45 | 79.35515 | 64.43089 | 55.516638 | 59.642521 |
| 0.50 | 79.69201 | 67.61229 | 50.087566 | 57.545272 |
| 0.55 | 79.49952 | 70.08310 | 44.308231 | 54.291846 |
| 0.60 | 78.58518 | 73.33333 | 34.676007 | 47.086801 |
| 0.65 | 77.95958 | 75.33632 | 29.422066 | 42.317380 |
| 0.70 | 77.47834 | 81.98758 | 23.117338 | 36.065574 |
| 0.75 | 76.37151 | 86.36364 | 16.637478 | 27.900147 |
| 0.80 | 75.36092 | 91.54930 | 11.383538 | 20.249221 |
| 0.85 | 73.86910 | 93.75000 | 5.253940 | 9.950249 |
| 0.90 | 72.90664 | 100.00000 | 1.401051 | 2.763385 |
| 0.95 | 0.95000 | 0.95000 | 0.950000 | 0.950000 |
#analizamos gráficamente precisión vs cobertura.
umb_rl %>%
ggplot(aes(umbral))+
geom_line(aes(y=precision,color='precision'))+
geom_line(aes(y=cobertura,color='Cobertura'))+
scale_color_discrete(name ='Métrica',labels=c('Cobertura','Max F1','Precisión'))+
scale_x_continuous(breaks=seq(0,1,0.05))+
scale_y_continuous(breaks=seq(0,100,10))+
geom_vline(aes(xintercept = umb_rl[which.max(umb_rl$F1),1] , color = 'Max F1' ))## Warning: Use of `umb_rl$F1` is discouraged. Use `F1` instead.
umb_final_RL <- umb_rl[which.max(umb_rl$F1),1]# seleccionamos el umbral que maximiza la F1
umb_final_RL## [1] 0.3Toda predicción que tenga una probabilidad mayor o igual a 0.3, será considerada como un SÍ, el cliente abandonará la compañía.
Con este umbral definido, evaluamos el modelo a partir de la matriz de confusión y la curva ROC y el AUC.
M_confusion_RL<-confusion(test$Target,Predict_rl,umb_final_RL)# creamos la matriz de confusión con los valores de tp tn fp y fn
M_confusion_RL##
## real FALSE TRUE
## 0 1170 337
## 1 141 430metricas_rl <- t(filter(umb_rl,umbral==umb_final_RL)) # filtramos por el valor del umbral que hemos establecido previamente ( max F1)
metricas_rl## [,1]
## umbral 0.30000
## acierto 76.99711
## precision 56.06258
## cobertura 75.30648
## F1 64.27504Analizando la matriz de confusión para el umbral fijado en P=0.3,vemos como, el modelo de RL ha identificado como VERDADEROS POSITIVOS, determinado como clientes que iban a abandonar la compañía y que realmente iban a hacerlo, a 430
FALSOS POSITIVOS, determinado cómo clientes que el modelo predice que van a abandonar la compañía pero no realmente no la han abandonado a 337
VERDADERO NEGATIVO, determinado cómo clientes que el modelo predice que va a abandonar la compañía y realmente la abandonan. 1170
FALSO NEGATIVO, determinado cómo clientes que el modelo predice que va a abandonar la compañía y realmente no la abandonan. 141
Con este umbral (0.3), obtenemos unos valores para las métricas de precisión 56.0625815y cobertura de 75.3064799
A continuación, evaluamos el modelo a partir de la curva ROC y El area bajo la curva ROC ( AUC ).
La curva ROC, es la representación de la razón o proporción de verdaderos positivos (VPR = Razón de Verdaderos Positivos) frente a la proporción de falsos positivos (FPR = Razón de Falsos Positivos),según se varía el umbral de discriminación (valor a partir del cual decidimos que un caso es un positivo.
El AUC o Area Under the Curve, es la traducción de la información que proporciona la curva ROC, a una métrica que hace referencia al área situada entre la diagonal principal ( equivalente a un modelo de selección aleatoria o a la ausencia de un modelo) y la curva ROC del modelo. Esta métrica sirve también para poder comparar el modelo.
# curva ROC:
RL_prediction<- prediction(Predict_rl,test$Target)
roc(RL_prediction)
# Métrica AUC:
auc_RL<- performance(RL_prediction,'auc')@y.values[[1]]
auc_RL## [1] 0.8484527metricas_rl<- rbind(metricas_rl,auc_RL) # Añadimos esta métrica al resto, para poder compararlas con el resto de modelos posteriormente.
colnames(metricas_rl)<- 'MODELO RL'
metricas_rl## MODELO RL
## umbral 0.3000000
## acierto 76.9971126
## precision 56.0625815
## cobertura 75.3064799
## F1 64.2750374
## auc_RL 0.8484527En la gráfica, vemos la curva de desempeño del modelo, cuanto mayor diferencia haya entre la diagonal principal( equivalente a un modelo aleatorio o a la ausencia de modelo alguno) y la curva de desempeño, mejor modelo. Esta diferencia se puede medir con el AUC (area under the curve)= 0.8484527. A partir de un AUC > 0,8 lo consideramos como un buen modelo.
5.2 MODELIZACIÓN CON ÁRBOLES DE DECISIÓN:
El siguiente algoritmo que vamos a usar para modelizar es el de árboles de decisión, el cual es especialmente interesante debido a su capacidad explicativa, pudiendo interpretar muy fácilmente cada nodo del árbol.
Formulamos el modelo y creamos la primera versión del árbol, con un parámetro de complejidad muy bajo, para que ramifique el árbol al máximo. ajustándolo posteriormente para evitar el sobreajuste.
formula_ar<- formula# formulamos el modelo con todas las variables independientes.
AR<-rpart(formula_ar,train,method= 'class',parms=list(split='information'),control=rpart.control(cp=0.00000001))Analizamos numéricamente y visualmente los parámetros del árbol.
printcp(AR)##
## Classification tree:
## rpart(formula = formula_ar, data = train, method = "class", parms = list(split = "information"),
## control = rpart.control(cp = 0.00000001))
##
## Variables actually used in tree construction:
## [1] Contract Dependents DeviceProtection
## [4] gender InternetService MonthlyCharges_DISC
## [7] MultipleLines OnlineBackup OnlineSecurity
## [10] PaperlessBilling Partner PaymentMethod
## [13] PhoneService SeniorCitizen StreamingMovies
## [16] StreamingTV TechSupport Tenure_DISC
## [19] TotalCharges_DISC
##
## Root node error: 1298/4954 = 0.26201
##
## n= 4954
##
## CP nsplit rel error xerror xstd
## 1 0.06908064 0 1.00000 1.00000 0.023844
## 2 0.00564972 3 0.79276 0.80046 0.022076
## 3 0.00539291 7 0.76656 0.80971 0.022169
## 4 0.00385208 11 0.74499 0.78659 0.021934
## 5 0.00308166 17 0.71341 0.78043 0.021870
## 6 0.00269646 21 0.69954 0.77812 0.021846
## 7 0.00231125 23 0.69414 0.77658 0.021830
## 8 0.00179764 29 0.68028 0.77504 0.021814
## 9 0.00154083 32 0.67488 0.77581 0.021822
## 10 0.00128403 40 0.66179 0.77658 0.021830
## 11 0.00115562 43 0.65794 0.78428 0.021910
## 12 0.00102722 50 0.64946 0.78891 0.021958
## 13 0.00077042 56 0.64330 0.79507 0.022021
## 14 0.00061633 84 0.62173 0.81433 0.022215
## 15 0.00051361 89 0.61864 0.82589 0.022329
## 16 0.00038521 104 0.61094 0.83590 0.022427
## 17 0.00030817 114 0.60709 0.84361 0.022500
## 18 0.00025681 119 0.60555 0.85439 0.022603
## 19 0.00019260 122 0.60478 0.85593 0.022617
## 20 0.00000001 126 0.60401 0.86287 0.022682plotcp(AR)
Buscamos el punto para el criterio de complejidad (CP) a partir del cual el error de validación cruzada, deja de descender y comienza a ascender ( punto de sobreajuste ). Vemos que este punto, está entorno a cp=0,0017.
Creamos una segunda versión del árbol, modificando el parámetro de complejidad y fijándolo en el valor cp=0,0017 para regular la poda del árbol y evitar el sobreajuste.
AR<- AR<-rpart(formula_ar,train,method= 'class',parms=list(split='information'),control=rpart.control(cp=0.0017))
#analizamos numéricamente y visualmente los parámetros del árbol.
printcp(AR)##
## Classification tree:
## rpart(formula = formula_ar, data = train, method = "class", parms = list(split = "information"),
## control = rpart.control(cp = 0.0017))
##
## Variables actually used in tree construction:
## [1] Contract gender InternetService
## [4] MonthlyCharges_DISC MultipleLines OnlineBackup
## [7] OnlineSecurity PaperlessBilling PaymentMethod
## [10] SeniorCitizen StreamingMovies StreamingTV
## [13] TechSupport Tenure_DISC
##
## Root node error: 1298/4954 = 0.26201
##
## n= 4954
##
## CP nsplit rel error xerror xstd
## 1 0.0690806 0 1.00000 1.00000 0.023844
## 2 0.0056497 3 0.79276 0.79969 0.022068
## 3 0.0053929 7 0.76656 0.81279 0.022200
## 4 0.0038521 11 0.74499 0.79584 0.022029
## 5 0.0030817 17 0.71341 0.79045 0.021974
## 6 0.0026965 21 0.69954 0.77581 0.021822
## 7 0.0023112 23 0.69414 0.77427 0.021806
## 8 0.0017976 29 0.68028 0.78120 0.021878
## 9 0.0017000 32 0.67488 0.78351 0.021902plotcp(AR)
Aplicados los criterios de poda par un CP=0.0017. Nos quedamos con este árbol y sacamos tanto la representación gráfica del árbol como sus reglas de decisión.
#Visualizamos gráficamente el árbol.
rpart.plot(AR,type=2,extra = 7, under = TRUE,under.cex = 0.7,fallen.leaves=F,gap = 0,cex=0.2,yesno = 2,box.palette = "GnYlRd",branch.lty = 3)
#sacamos las reglas de discriminación del árbol.
reglas_AR <- rpart.rules(AR,style = 'tall',cover=T)Una vez decidido el modelo de árbol que vamos a usar, lo ejecutamos sobre el conjunto de Test y valoramos gráficamente las predicciones.
AR_predict <- predict(AR,test,type = 'prob')[,2]
plot(AR_predict~test$Target)
Calculamos a continuación las métricas de Precisión, cobertura y F1 para cada umbral de decisión.
#calculamos las métricas de Precisión, cobertura y F1 para cada umbral de decisión.
umb_AR<-umbrales(test$Target,AR_predict)
umb_AR| umbral | acierto | precision | cobertura | F1 |
|---|---|---|---|---|
| 0.05 | 0.05000 | 0.05000 | 0.05000 | 0.05000 |
| 0.10 | 65.92878 | 44.07952 | 89.31699 | 59.02778 |
| 0.15 | 66.45813 | 44.29348 | 85.63923 | 58.38806 |
| 0.20 | 75.79403 | 54.26065 | 75.83187 | 63.25785 |
| 0.25 | 75.89028 | 54.44162 | 75.13135 | 63.13466 |
| 0.30 | 78.24832 | 59.58132 | 64.79860 | 62.08054 |
| 0.35 | 78.53705 | 61.14082 | 60.07005 | 60.60071 |
| 0.40 | 78.92204 | 62.42991 | 58.49387 | 60.39783 |
| 0.45 | 78.82579 | 64.08602 | 52.18914 | 57.52896 |
| 0.50 | 78.82579 | 64.08602 | 52.18914 | 57.52896 |
| 0.55 | 78.82579 | 64.08602 | 52.18914 | 57.52896 |
| 0.60 | 78.82579 | 64.08602 | 52.18914 | 57.52896 |
| 0.65 | 78.34456 | 68.84735 | 38.70403 | 49.55157 |
| 0.70 | 76.99711 | 71.83099 | 26.79510 | 39.03061 |
| 0.75 | 75.21655 | 88.88889 | 11.20841 | 19.90669 |
| 0.80 | 75.21655 | 88.88889 | 11.20841 | 19.90669 |
| 0.85 | 75.21655 | 88.88889 | 11.20841 | 19.90669 |
| 0.90 | 0.90000 | 0.90000 | 0.90000 | 0.90000 |
| 0.95 | 0.95000 | 0.95000 | 0.95000 | 0.95000 |
Con el mismo criterio que el que hemos establecido para la regresión logística. Elegimos el umbral de decisión a partir del umbral que maximiza la métrica de la F1.
# identificamos el punto que maximiza la F1
umb_final_AR <- umb_AR[which.max(umb_AR$F1),1]
umb_final_AR## [1] 0.2El umbral de decisión elegido es de 0.2, toda predicción que sea mayor o igual que este valor, será determinado como un sí, el cliente va a abandonar la compañía.
#analizamos graficamente PRECISIÓn VS COBERTURA.
umb_AR %>%
ggplot(aes(umbral))+
geom_line(aes(y=precision,color='precision'))+
geom_line(aes(y=cobertura,color='Cobertura'))+
scale_color_discrete(name ='Métrica',labels=c('Cobertura','Max F1','Precisión'))+
scale_x_continuous(breaks=seq(0,1,0.05))+
scale_y_continuous(breaks=seq(0,100,10))+
geom_vline(aes(xintercept = umb_AR[which.max(umb_AR$F1),1] , color = 'Max F1' ))## Warning: Use of `umb_AR$F1` is discouraged. Use `F1` instead.
Creamos la matriz de confusión a partir del umbral establecido 0.2 y las métricas de precisión y cobertura.
mat_conf_AR<- confusion(test$Target,AR_predict,umb_final_AR)
mat_conf_AR##
## real FALSE TRUE
## 0 1142 365
## 1 138 433metricas_ar <- t(filter(umb_AR,umbral==umb_final_AR))
metricas_ar## [,1]
## umbral 0.20000
## acierto 75.79403
## precision 54.26065
## cobertura 75.83187
## F1 63.25785Analizando la matriz de confusión para el umbral fijado en P=0.2 ,vemos como, el modelo de RL ha identificado como VERDADEROS POSITIVOS, determinado como clientes que iban a abandonar la compañía y que realmente iban a hacerlo, a 433
FALSOS POSITIVOS, determinado cómo clientes que el modelo predice que van a abandonar la compañía pero no realmente no la han abandonado a 365
VERDADERO NEGATIVO, determinado cómo clientes que el modelo predice que va a abandonar la compañía y realmente la abandonan. 1142
FALSO POSITIVO, determinado cómo clientes que el modelo predice que va a abandonar la compañía y realmente no la abandonan. 138
Con este umbral (0.2), obtenemos unos valores para las métricas de precisión 54.2606516 y cobertura de 75.8318739
Por último, creamos la curva ROC del modelo y la métrica de AUC.
# curva ROC:
AR_prediction<-prediction(AR_predict,test$Target)
plot(performance(AR_prediction,'tpr','fpr'))
#AUC:
auc_AR<- performance(AR_prediction,'auc')@y.values[[1]]
auc_AR## [1] 0.8148506Creamos la matriz con las métricas del modelo para poder hacer una comparación de los modelos más sencilla.
metricas_ar<-rbind(metricas_ar,auc_AR)
colnames(metricas_ar)<-'MODELO AR'
metricas_ar## MODELO AR
## umbral 0.2000000
## acierto 75.7940327
## precision 54.2606516
## cobertura 75.8318739
## F1 63.2578524
## auc_AR 0.81485065.3 MODELIZACIÓN CON RANDOM FOREST:
Vamos a modelizar con el algoritmo de random forest, el cual, genera un gran número de árboles de decisión sencillos con una selección aleatoria de variables. Una vez generados estos árboles, por mayoría en los resultados de estos, genera una predicción.
Este es un tipo de algoritmo conocido como algoritmo de caja negra, debido a la escasa interpretabilidad que tiene. Pero también ofrece ciertas ventajas, como poco sobreajuste y la posibilidad de valorar la importancia de las variables en la predicción.
Formulamos el modelo con todas las variables y lo ejecutamos sobre el conjunto de entrenamiento:
formula_rf <- formula# formulamos el modelo de rf
rf<-randomForest(formula_rf,train, Ntree=5000, Mtry=19,importance=T)# entrenamos el modelo con el conjunto de train.
rf##
## Call:
## randomForest(formula = formula_rf, data = train, Ntree = 5000, Mtry = 19, importance = T)
## Type of random forest: classification
## Number of trees: 500
## No. of variables tried at each split: 4
##
## OOB estimate of error rate: 20.53%
## Confusion matrix:
## 0 1 class.error
## 0 3306 350 0.09573304
## 1 667 631 0.51386749A continuación, vamos a analizar la importancia que tienen las variables en la predicción, para tratar de afinar el modelo y ver si conseguimos un mejor modelo limitándonos a las variables más importantes.
# observamos la importancia de las variables en el modelo.
varImpPlot(rf)
La importancia de las variables viene determinada por dos métricas,el decremento medio en la precisión y el decremento medio de Gini. Vamos a crear una variable que reúna la información de ambas, normalizando las escalas para tener una medida más robusta y la utilizaremos como criterio de selección.
importancia_RF <- importance(rf)[,3:4]
importancia_RF_norm <- as.data.frame(scale(importancia_RF)) # normalizamos las variables para que las escalas sean comparables (con función scale). Tipificamos las variables.
importancia_RF_norm <- importancia_RF_norm %>% mutate(
Variable = rownames(importancia_RF_norm),
Imp_tot = MeanDecreaseAccuracy + MeanDecreaseGini) %>%
mutate(Imp_tot = Imp_tot + abs(min(Imp_tot))) %>%
arrange(desc(Imp_tot)) %>%
select(Variable,Imp_tot,MeanDecreaseAccuracy,MeanDecreaseGini)
importancia_RF_norm| Variable | Imp_tot | MeanDecreaseAccuracy | MeanDecreaseGini |
|---|---|---|---|
| Tenure_DISC | 6.3541358 | 1.6647686 | 2.8944560 |
| Contract | 5.4417378 | 1.9944023 | 1.6524243 |
| InternetService | 4.2649127 | 1.8361763 | 0.6338251 |
| TotalCharges_DISC | 3.0624064 | 0.6745805 | 0.5929146 |
| MonthlyCharges_DISC | 3.0313158 | 0.8756853 | 0.3607192 |
| PaymentMethod | 2.8022326 | -0.2098861 | 1.2172074 |
| OnlineSecurity | 1.6856601 | 0.3736106 | -0.4828618 |
| TechSupport | 1.3493933 | 0.0937581 | -0.5392761 |
| OnlineBackup | 1.3403912 | 0.0257974 | -0.4803175 |
| PaperlessBilling | 1.1058672 | -0.2753099 | -0.4137342 |
| MultipleLines | 0.8054014 | -0.4734689 | -0.5160410 |
| SeniorCitizen | 0.7201610 | -0.5206051 | -0.5541452 |
| StreamingMovies | 0.6990898 | -0.4577706 | -0.6380509 |
| Partner | 0.3630062 | -0.9495390 | -0.4823661 |
| StreamingTV | 0.3529478 | -0.7732597 | -0.6687038 |
| DeviceProtection | 0.3476400 | -0.8622152 | -0.5850561 |
| Dependents | 0.2127068 | -0.9776411 | -0.6045634 |
| PhoneService | 0.1643087 | -0.5689031 | -1.0616994 |
| gender | 0.0000000 | -1.4701804 | -0.3247309 |
ggplot(importancia_RF_norm, aes(reorder(Variable,-Imp_tot),Imp_tot)) + geom_bar(stat = "identity") + theme(axis.text.x = element_text(angle = 90,size = 7))
importancia_RF_norm # observamos gráficamente la importancia total de las variables.| Variable | Imp_tot | MeanDecreaseAccuracy | MeanDecreaseGini |
|---|---|---|---|
| Tenure_DISC | 6.3541358 | 1.6647686 | 2.8944560 |
| Contract | 5.4417378 | 1.9944023 | 1.6524243 |
| InternetService | 4.2649127 | 1.8361763 | 0.6338251 |
| TotalCharges_DISC | 3.0624064 | 0.6745805 | 0.5929146 |
| MonthlyCharges_DISC | 3.0313158 | 0.8756853 | 0.3607192 |
| PaymentMethod | 2.8022326 | -0.2098861 | 1.2172074 |
| OnlineSecurity | 1.6856601 | 0.3736106 | -0.4828618 |
| TechSupport | 1.3493933 | 0.0937581 | -0.5392761 |
| OnlineBackup | 1.3403912 | 0.0257974 | -0.4803175 |
| PaperlessBilling | 1.1058672 | -0.2753099 | -0.4137342 |
| MultipleLines | 0.8054014 | -0.4734689 | -0.5160410 |
| SeniorCitizen | 0.7201610 | -0.5206051 | -0.5541452 |
| StreamingMovies | 0.6990898 | -0.4577706 | -0.6380509 |
| Partner | 0.3630062 | -0.9495390 | -0.4823661 |
| StreamingTV | 0.3529478 | -0.7732597 | -0.6687038 |
| DeviceProtection | 0.3476400 | -0.8622152 | -0.5850561 |
| Dependents | 0.2127068 | -0.9776411 | -0.6045634 |
| PhoneService | 0.1643087 | -0.5689031 | -1.0616994 |
| gender | 0.0000000 | -1.4701804 | -0.3247309 |
Viendo la gráfica, Vamos modelizar introduciendo en el modelo las 10 variables más importantes.
independientes_RF_corta <-importancia_RF_norm$Variable[1:10]
formula_rf_corta <- reformulate(independientes_RF_corta,Target)Volvemos a ejecutar el algoritmo sobre el conjunto de entrenamiento, pero solo con las variables seleccionadas según su importancia.
rf_corta <-randomForest(formula_rf_corta,train, Ntree=5000, Mtry=10,importance=T)
rf_corta##
## Call:
## randomForest(formula = formula_rf_corta, data = train, Ntree = 5000, Mtry = 10, importance = T)
## Type of random forest: classification
## Number of trees: 500
## No. of variables tried at each split: 3
##
## OOB estimate of error rate: 20.15%
## Confusion matrix:
## 0 1 class.error
## 0 3266 390 0.1066740
## 1 608 690 0.4684129Comparando el error OOB(out of the bag) de ambos modelos, vemos que la diferencia entre ambos es muy pequeña. Prácticamente no conseguimos mejora, podríamos tratar de afinar los Hiperparámetros aplicando técnicas de grid search o random search, para encontrar una combinación de los hiperparámetros óptima, basádandose en probar las diferentes combinaciones de manera iterativa. En este proyecto no vamos a profundizar más en el afinamiento del modelo.
Realizamos la predicción sobre el conjunto de Test a partir del modelo conlas 10 variables más importantes, ya que el número de variables es muy reducido, por lo tanto más sencillo y además consigue un nivel de error OOB ligeramente menor .
RF_predict <- predict(rf_corta,test,type='prob')[,2]# ejectuamos la predicción y nos quedamos con la columna que contiene los valores de probabilidad.
summary(RF_predict)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0000 0.0040 0.0820 0.2552 0.4380 1.0000Evaluamos el modelo con los mismos criterios que hemos empleado anteriormente.
plot(RF_predict~test$Target) 
Analizamos gráficamente las predicciones. Podemos observar que la forma de los gráficos es buena, y es lo que cabría esperar de la predicción.
Continuamos evaluando el modelo bajo los mismos criterios empleados en el resto de modelos.
Definimos el umbral de decisión, a partir del umbral que maximiza la de F1. y calculamos las métricas de precisión y cobertura, de la misma manera que anteriormente.
#analizamos los umbrales para la predicción.
umbral_RF<-umbrales(test$Target,RF_predict)
umbral_RF| umbral | acierto | precision | cobertura | F1 |
|---|---|---|---|---|
| 0.05 | 64.96631 | 43.31915 | 89.14186 | 58.30470 |
| 0.10 | 71.02984 | 48.41351 | 82.83713 | 61.11111 |
| 0.15 | 73.86910 | 51.61663 | 78.28371 | 62.21294 |
| 0.20 | 75.07218 | 53.35019 | 73.90543 | 61.96769 |
| 0.25 | 76.56400 | 56.03448 | 68.30123 | 61.56275 |
| 0.30 | 77.33397 | 57.66871 | 65.84939 | 61.48814 |
| 0.35 | 78.20019 | 59.80066 | 63.04729 | 61.38107 |
| 0.40 | 78.92204 | 61.85383 | 60.77058 | 61.30742 |
| 0.45 | 79.59577 | 64.61233 | 56.91769 | 60.52142 |
| 0.50 | 79.30703 | 65.29284 | 52.71454 | 58.33333 |
| 0.55 | 79.49952 | 66.97892 | 50.08757 | 57.31463 |
| 0.60 | 79.49952 | 69.02887 | 46.05954 | 55.25210 |
| 0.65 | 79.25890 | 70.00000 | 42.90718 | 53.20304 |
| 0.70 | 79.21078 | 71.12462 | 40.98074 | 52.00000 |
| 0.75 | 79.01829 | 73.68421 | 36.77758 | 49.06542 |
| 0.80 | 78.82579 | 77.17842 | 32.57443 | 45.81281 |
| 0.85 | 78.24832 | 78.46890 | 28.72154 | 42.05128 |
| 0.90 | 77.62271 | 80.81395 | 24.34326 | 37.41588 |
| 0.95 | 76.90087 | 83.21168 | 19.96497 | 32.20339 |
#establecemos el umbral en función del max F1.
umbral_final_RF<-umbral_RF[which.max(umbral_RF$F1),1]
umbral_final_RF## [1] 0.15#analizamos graficamente PRECISIÓn VS COBERTURA.
umbral_RF %>%
ggplot(aes(umbral))+
geom_line(aes(y=precision,color='precision'))+
geom_line(aes(y=cobertura,color='Cobertura'))+
scale_color_discrete(name ='Métrica',labels=c('Cobertura','Max F1','Precisión'))+
scale_x_continuous(breaks=seq(0,1,0.05))+
scale_y_continuous(breaks=seq(0,100,10))+
geom_vline(aes(xintercept = umbral_RF[which.max(umbral_RF$F1),1] , color = 'Max F1' ))## Warning: Use of `umbral_RF$F1` is discouraged. Use `F1` instead.
# creamos la matriz con las métricas del modelo.
metricas_RF <-t(filter(umbral_RF,umbral==umbral_final_RF))
colnames(metricas_RF)<- 'MODELO RF'
metricas_RF## MODELO RF
## umbral 0.15000
## acierto 73.86910
## precision 51.61663
## cobertura 78.28371
## F1 62.21294Toda predicción que tenga una probabilidad mayor o igual a 0.15, será considerada como un SÍ, el cliente abandonará la compañía.
Con este umbral definido, evaluamos el modelo a partir de la matriz de confusión y la curva ROC y el AUC.
m_confusion_RF<-confusion(test$Target,RF_predict,umbral_final_RF)
m_confusion_RF##
## real FALSE TRUE
## 0 1088 419
## 1 124 447Analizando la matriz de confusión para el umbral fijado en P=0.15,vemos como, el modelo de RL ha identificado como VERDADEROS POSITIVOS, determinado como clientes que iban a abandonar la compañía y que realmente iban a hacerlo, a 447
FALSOS POSITIVOS, determinado cómo clientes que el modelo predice que van a abandonar la compañía pero no realmente no la han abandonado a 419
VERDADERO NEGATIVO, determinado cómo clientes que el modelo predice que va a abandonar la compañía y realmente la abandonan. 1088
FALSO POSITIVO, determinado cómo clientes que el modelo predice que va a abandonar la compañía y realmente no la abandonan. 124
Con este umbral ( 0.15), obtenemos unos valores para las métricas de precisión 51.6166282y cobertura de 78.2837128
Continuamos evaluando el modelo a partir de la curva ROC y el AUC.
#curva ROC
RF_prediction<- prediction(RF_predict,test$Target)
plot(performance(RF_prediction,'tpr','fpr'))
#AUC
auc_RF<- performance(RF_prediction,'auc')@y.values[[1]]
auc_RF## [1] 0.8307618Creamos la matriz para comparar los modelos y tomar una decisión.
metricas_RF<- rbind(metricas_RF,auc_RF) # Añandimos esta métrica al resto, para poder compararlas con el resto de modelos posteriormente.
colnames(metricas_RF)<- 'MODELO RF'
metricas_RF## MODELO RF
## umbral 0.1500000
## acierto 73.8691049
## precision 51.6166282
## cobertura 78.2837128
## F1 62.2129436
## auc_RF 0.8307618#creamos la matriz de métricas para comparar los modelos
metricas_MODELOS <- cbind(metricas_rl,metricas_ar,metricas_RF)
metricas_MODELOS## MODELO RL MODELO AR MODELO RF
## umbral 0.3000000 0.2000000 0.1500000
## acierto 76.9971126 75.7940327 73.8691049
## precision 56.0625815 54.2606516 51.6166282
## cobertura 75.3064799 75.8318739 78.2837128
## F1 64.2750374 63.2578524 62.2129436
## auc_RL 0.8484527 0.8148506 0.8307618Con los resultados obtenidos, el modelo de Regresión logística es el que mejor AUC ha obtenido 0.8484527. Teniendo en cuenta este criterio y la capacidad explicativa que ofrece la regresión logística, nos quedamos con este modelo.
Realizamos una predicción del scoring de abandono que tiene cada uno de los clientes del df, calculados a partir del modelo de regresión logística y guardamos el modelo final.
df$Scoring_Churn <- predict(rl_corta,df,type='response') #creamos la variable con las predicciones que ha hecho el modelo
summary(df$Scoring_Churn)#hacemos un resulmen de los estadísticos de la variable para ver que aspecto tiene.## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.002252 0.042048 0.176448 0.262244 0.432968 0.944048saveRDS(rl_corta,'modelo_final_churn.rds') # guardamos el modelo final.
saveRDS(df,'cache3_proyecto_DS4B.rds') #guardamos el df final.6 EVALUACIÓN Y ANÁLISIS DE NEGOCIO.
Vamos a visualizar el abandono real por tramos de scoring. Este gráfico nos sirve para ver que el modelo es consistente, ya que debe presentar una línea descendente en la tasa de abandono conforme se desciende en el scoring
# creamos una función para visualizar la comparación de los tramos del scoring con los del abandono real.
vis <- function(scoring,real) {
vis_df<- data.frame( Scoring = scoring, Perc_scoring = cut_number(scoring, 20),Real= real) # creamos un data frame interno en el que le pasamos, la variable Real=real que son los datos del parámetro que le pasemos a la funcion (real), le pasamos también Scoring=scoring, y por último, creamos la var, percentil_scoring, que con cut numbers divide el vector del scoring en 20 tramos (20 tramos de 5% de los datos de scoring).
levels(vis_df$Perc_scoring) <- seq(from= 100, to = 5, by = -5) # reajustamos los niveles de la variable para que vayan de 5 a 100 de 5 en 5.
#creamos una var intermedia que agrupa por la variable Perc_scoring que regoge los valores del scoring en 20 tramos y calcula la tasa media de penetración de la target para cada tramo. que es lo que vamos a dibujar en el gráfico.
vis_gr <- vis_df %>%
group_by(Perc_scoring)%>%
summarise(Tasa_Churn = mean(as.numeric(as.character(Real)))) %>%
arrange(Perc_scoring)
#pasamos el perc_scoring de la variable intermedia a factor, le decimos que los niveles son los tramos del scoring y los ordenamos de manera descendente.
vis_gr$Perc_scoring <- factor(vis_gr$Perc_scoring, levels = vis_gr$Perc_scoring[order(vis_gr$Perc_scoring, decreasing = T)])
#creamos la gráfica donde le pasamos el data frame intermedio, el eje x Perc_scoring eje y Tasa_Churn le decimos que las columnas las haga azules y que ponga otra capa con una línea horizontal donde el intercepto de y sea la media de la variable Real del df_vis que hemos creado ( la media de la penetración de la target, la media de los abandonos reales) y por último, ponemos los títulos de los elementos.
ggplot(vis_gr,aes( Perc_scoring, Tasa_Churn)) +
geom_col(fill= 'lightblue') +
geom_hline(aes(yintercept= mean(as.numeric(as.character(vis_df$Real)))),col ='black') + labs(title = 'Abandono real por tramo de Scoring', x = 'Porcentaje de clientes por tramo de Scoring', y= ' Tasa de Abandono Real')
}
vis(df$Scoring_Churn,df$Target)
Viendo el gráfico, en el eje x se agrupan los clientes en función de su scoring, de izquierda a derecha, encontramos el 5 % de los clientes con mayor scoring y así sucesivamente hasta llegar al 100% de los clientes. En el eje Y, encontramos la tasa de Abandono real de los clientes de 0 a 1 ( 0% a 100% de abandono) y por último la línea horizontal es la tasa media de Penetración de la target ( tasa media de abandono real para todos los clientes ).
Analizando el gráfico, vemos como para los clientes que tienen un mayor scoring, la tasa de abandono real es muy alta, y esta va disminuyendo a medida que este scoring baja. De modo que el modelo le está asignando una probabilidad muy alta a aquellos clientes que realmente se marcharon de la compañía.
por ejemplo, para el 5% de los clientes con mayor scoring, la tasa de abandono real es superior al 85% y para el 5% siguiente de los clientes con mayor Scoring, la tasa es del 80% etc. El modelo está prediciendo bien el scoring de los clientes.
Una vez conseguido el modelo e identificado el scoring de abandono que tiene cada cliente, habría que diseñar una campaña comercial destinada a contactar a aquellos clientes con una alta probabilidad de abandono. El objetivo de esta campaña sería minimizar la pérdida de ingresos por abandono, maximizando el valor del cliente en el tiempo.
7 CONCLUSIONES.
Existe un problema con el servicio de Internet por fibra óptica, que está haciendo que los clientes abandonen la compañía.
Derivado del problema con el servicio de internet, el resto de servicios dependientes de este, están viéndose afectados y hacen que el abandono aumente.
La compañía es capaz, en general, de mantener a los clientes a lo largo del tiempo. La antigüedad esta ejerciendo un efecto negativo en el abandono.
Los clientes con un contrato de 1/2 años, abandonan la compañía mucho menos que los clientes con contratos mensuales. La compañía debe darle prioridad a este tipo de contratación.
Los clientes que eligen una forma de pago automática, abandonan la compañíaa en mucho menor medida que los clientes que no contratado una forma de pago automática. La compañía debe priorizar este tipo de formas de pago frente a las formas que requieren comprobación por parte del cliente.