Análisis de supervivencia.
Zindell Joselyn Molina Téllez
11 de noviembre de 2018
En el siguiente trabajo haremos uso de una base de datos de un Banco, buscamos responder a la pregunta ¿cómo mejorar la retención de los clientes?
Inicialmente cargamos las librerias que usaremos.
library(foreign)
library(survival)
library(mclust)
library(LifeTables)
library(KMsurv)
library(nlme)
library(muhaz)
library(MASS)
library(TH.data)
library(ggplot2)
library(proto)
library(GGally)
library(lattice)
library(mice)La base de datos es la siguiente:
Datos<-read.csv("/Users/elsys/Downloads/Bank_Churn_Modelling.csv")Hagamos un análisis de los datos en general. Nuestra base de datos contiene a 10,000 clientes.
summary(Datos)## RowNumber CustomerId Surname CreditScore
## Min. : 1 Min. :15565701 Smith : 32 Min. :350.0
## 1st Qu.: 2501 1st Qu.:15628528 Martin : 29 1st Qu.:584.0
## Median : 5000 Median :15690738 Scott : 29 Median :652.0
## Mean : 5000 Mean :15690941 Walker : 28 Mean :650.5
## 3rd Qu.: 7500 3rd Qu.:15753234 Brown : 26 3rd Qu.:718.0
## Max. :10000 Max. :15815690 Genovese: 25 Max. :850.0
## (Other) :9831
## Geography Gender Age Tenure
## France :5014 Female:4543 Min. :18.00 Min. : 0.000
## Germany:2509 Male :5457 1st Qu.:32.00 1st Qu.: 3.000
## Spain :2477 Median :37.00 Median : 5.000
## Mean :38.92 Mean : 5.013
## 3rd Qu.:44.00 3rd Qu.: 7.000
## Max. :92.00 Max. :10.000
##
## Balance NumOfProducts HasCrCard IsActiveMember
## Min. : 0 Min. :1.00 Min. :0.0000 Min. :0.0000
## 1st Qu.: 0 1st Qu.:1.00 1st Qu.:0.0000 1st Qu.:0.0000
## Median : 97199 Median :1.00 Median :1.0000 Median :1.0000
## Mean : 76486 Mean :1.53 Mean :0.7055 Mean :0.5151
## 3rd Qu.:127644 3rd Qu.:2.00 3rd Qu.:1.0000 3rd Qu.:1.0000
## Max. :250898 Max. :4.00 Max. :1.0000 Max. :1.0000
##
## EstimatedSalary Exited
## Min. : 11.58 Min. :0.0000
## 1st Qu.: 51002.11 1st Qu.:0.0000
## Median :100193.91 Median :0.0000
## Mean :100090.24 Mean :0.2037
## 3rd Qu.:149388.25 3rd Qu.:0.0000
## Max. :199992.48 Max. :1.0000
## str(Datos)## 'data.frame': 10000 obs. of 14 variables:
## $ RowNumber : int 1 2 3 4 5 6 7 8 9 10 ...
## $ CustomerId : int 15634602 15647311 15619304 15701354 15737888 15574012 15592531 15656148 15792365 15592389 ...
## $ Surname : Factor w/ 2932 levels "Abazu","Abbie",..: 1116 1178 2041 290 1823 538 178 2001 1147 1082 ...
## $ CreditScore : int 619 608 502 699 850 645 822 376 501 684 ...
## $ Geography : Factor w/ 3 levels "France","Germany",..: 1 3 1 1 3 3 1 2 1 1 ...
## $ Gender : Factor w/ 2 levels "Female","Male": 1 1 1 1 1 2 2 1 2 2 ...
## $ Age : int 42 41 42 39 43 44 50 29 44 27 ...
## $ Tenure : int 2 1 8 1 2 8 7 4 4 2 ...
## $ Balance : num 0 83808 159661 0 125511 ...
## $ NumOfProducts : int 1 1 3 2 1 2 2 4 2 1 ...
## $ HasCrCard : int 1 0 1 0 1 1 1 1 0 1 ...
## $ IsActiveMember : int 1 1 0 0 1 0 1 0 1 1 ...
## $ EstimatedSalary: num 101349 112543 113932 93827 79084 ...
## $ Exited : int 1 0 1 0 0 1 0 1 0 0 ...attach(Datos)Veamos que de nuestros 10,000 clientes. Los que tienen tarjeta son 7055 clientes. Y los que no son 2945.
tabla1<-table(HasCrCard)
tabla1## HasCrCard
## 0 1
## 2945 7055b<-barplot(tabla1,col=rainbow(4),main="Tarjetahabientes",col.main="black", xlab =" Con Tarjeta Sin tarjeta",
col.lab="black",ylim = c(0,8000))
Veamos que los miembros activos de nuestra base son 5151.
tabla2<-table(IsActiveMember)
tabla2## IsActiveMember
## 0 1
## 4849 5151b<-barplot(tabla2,col=rainbow(5),main="Miembros Activos",col.main="black",
xlab = "Inactivos Activos",
col.lab="black",ylim = c(0,8000))
Los clientes contratan productos en el banco, pueden ser tarjetas de crédito, débito seguros, etc.
Veamos que 5084 personas contrataron 1 produto. 4590 personas contrataron 2 productos. 266 personas contrataron 3 productos. 60 perosnas contrataron 4 productos.
tabla3<-table(NumOfProducts)
tabla3## NumOfProducts
## 1 2 3 4
## 5084 4590 266 60b<-barplot(tabla3,col=rainbow(4),main="Productos contratados",col.main="black", xlab = "Produtos",
col.lab="black",ylim = c(0,8000))
Entendamos en la siguiente gráfica que 7963 personas aún son clientes del banco. Y qué 2037 clientes ya no son clientes.
tabla4<-table(Exited)
tabla4## Exited
## 0 1
## 7963 2037b<-barplot(tabla4,col=rainbow(5),main="Miembros Fuera",col.main="black",
xlab = "Estatus",
col.lab="black",ylim = c(0,8000))
Sabemos que la calificación crediticia establece la capacidad de una entidad en este caso de un cliente para pagar su deuda. Para este caso vemaos que aproximadamente 3000 clientes tienen una calificación regular.
a<-ggplot(data=Datos, aes(x=CreditScore))+
geom_histogram(breaks=seq(300, 800, by =50),aes(fill=..count..))+
scale_fill_gradient("Clientes", low = "gray", high = "blue")
a+ labs(title="Calificación crediticia",
x ="Malo Regular Excelente", y = "Clientes") 
Además hay clientes de ambos géneros y de diferentes países. Mujeres 4543. Hombres 5457. France Germany Spain 5014 2509 2477
summary(Datos$Geography)## France Germany Spain
## 5014 2509 2477barplot(table(Datos$Geography),col=c("blue3","orange1","firebrick"), main="País", ylab ="Clientes")
summary(Datos$Gender)## Female Male
## 4543 5457barplot(table(Datos$Gender),col=c("darkgoldenrod1","forestgreen"), main="Género", ylab ="Clientes")
En la edad podemos ver que las personas de esta base pudieorn aquirir un producto a los 18 años e incluso hay clientes de 95 años.
La edad media de la base es de 38-39 años.
summary(Datos$Age)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 18.00 32.00 37.00 38.92 44.00 92.00c<-ggplot(data=Datos, aes(x=Age))+
geom_histogram(breaks=seq(18, 92, by =2),aes(fill=..count..))+
scale_fill_gradient("Clientes", low = "lightblue3", high = "lightpink")
c+ labs(title="Edad",
x ="Años", y = "Clientes")
Y además que el tiempo de permanencia de los clientes va de 0 a 10 años. En el cual los clientes en promedio permanecen 5 años.
summary(Datos$Tenure)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 3.000 5.000 5.013 7.000 10.000d<-ggplot(data=Datos, aes(x=Tenure))+
geom_histogram(breaks=seq(0, 20, by =1),aes(fill=..count..))+
scale_fill_gradient("Clientes", low = "red", high = "lightcoral")
d+ labs(title="Tiempo de Permanencia",
x ="Años de permanencia", y = "Clientes")
Para el análisis de Supervivencia. Ajuste no paramétrico. En éste caso, utilizaremos el Método de Kaplan−Meier.
La mediana de la supervivencia es 10, lo que indica que a los 10 años la mitad de los clientes han salido del banco.
En esta función, podemos apreciar que, durante todo el tiempo de observación, en 10 años, todos los eventos suceden por intervalos, es decir, hay intervalos de tiempo algún en el que hay muchas fallas o censuras.
Como sabemos, la función de riesgo h(t) es una función que mide la probabilidad de que a un individuo le ocurra cierto suceso a lo largo del tiempo, en este caso, vemos que esta probabilidad es creciente en el tiempoy cuando esta cerca a los 10 años, el crecimiento es muy rápido.
attach(Datos)
datos1.surv<-Surv(Tenure,Exited)
#Utilizando Kaplan-Meier
estimador<-survfit(datos1.surv~1,type="kaplan-meier", conf.type="log-log", conf.int=0.95, data=Datos)
summary(estimador)## Call: survfit(formula = datos1.surv ~ 1, data = Datos, type = "kaplan-meier",
## conf.type = "log-log", conf.int = 0.95)
##
## time n.risk n.event survival std.err lower 95% CI upper 95% CI
## 0 10000 95 0.991 0.00097 0.988 0.992
## 1 9587 232 0.967 0.00182 0.963 0.970
## 2 8552 201 0.944 0.00238 0.939 0.948
## 3 7504 213 0.917 0.00294 0.911 0.923
## 4 6495 203 0.888 0.00347 0.881 0.895
## 5 5506 209 0.855 0.00404 0.847 0.862
## 6 4494 196 0.817 0.00466 0.808 0.826
## 7 3527 177 0.776 0.00535 0.766 0.787
## 8 2499 197 0.715 0.00647 0.702 0.728
## 9 1474 213 0.612 0.00857 0.595 0.628
## 10 490 101 0.486 0.01309 0.460 0.511#Funcion de supervivencia
plot(estimador, main="Funcion de supervivencia", xlab="Tiempo" , ylab="S(t)", col=2:4,lwd=1)
legend("bottomleft", c("Estimador K-M", "Lower", "Upper"), lty=c(1,1,1), col=2:4, lwd=1,xjust = 1,yjust = 1)
#Funcion de riesgo acumulado
plot(estimador, main="Funcion de riesgo",
xlab="Tiempo", ylab="h(t)",
fun="cumhaz", conf.int=F, col="red")
Ahora, para las funciones de supervivencia estimadas para la variable Gender, podemos ver, que es más probable que las mujeres permanezcan en el banco a que los hombres . sin embargo, hacemos su respectiva prueba de Log-Rank para determinar si rechazamos o no rechazamos Ho: Ho :Las funciones de supervivencia son iguales, p.t.t vs H1: Son distintas p.a. t>0 Donde rechazamos Ho cuando p-value<0.05 y se muestra la salida de las pruebas de hipótesis realizadas.
#K-M para sexo
comp1 <- survfit(Surv(Tenure,Exited)~factor(Gender), type = "kaplan-meier", conf.type="plain",
data=Datos)
plot(comp1, conf.int=F,xlab="Tiempo", ylab="Supervivencia", lty=c(1,4), col=c("blue","pink1"),
main = "Comparación S(t) variable Gender")
legend("bottomleft", c("Hombre", "Mujer"), lty=c(1,4), col=c("blue", "pink1"))
#Comparación de supervivencias
survdiff(Surv(Tenure,Exited)~factor(Gender),rho = 0)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(Gender), rho = 0)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(Gender)=Female 4543 1139 920 52.2 101
## factor(Gender)=Male 5457 898 1117 43.0 101
##
## Chisq= 101 on 1 degrees of freedom, p= <2e-16survdiff(Surv(Tenure,Exited)~factor(Gender),rho = 1)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(Gender), rho = 1)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(Gender)=Female 4543 990 799 45.5 98.6
## factor(Gender)=Male 5457 782 972 37.4 98.6
##
## Chisq= 98.6 on 1 degrees of freedom, p= <2e-16La cantidad de clientes activos en el banco. Rechazamos Ho: Las funciones de supervivencia son iguales ya que p-value<0.05 y se muestra la salida de las pruebas de hipótesis realizadas (para un nivel de significación del 5%)
#K-M para IsActiveMember
comp2 <- survfit(Surv(Tenure,Exited)~factor(IsActiveMember), type = "kaplan-meier", conf.type="plain",
data=Datos)
plot(comp2, conf.int=F,xlab="Tiempo", ylab="S(t)", lty=c(1,4), col=c("blue","red"),
main = "Comparación de S(t) para la variable IsActiveMember")
legend("bottomleft", c("Inactivos","Activos"), lty=c(1,1),
col=c("blue","red", xjust= 1, yjust = 1))
#Comparación de supervivencias
survdiff(Surv(Tenure,Exited)~factor(IsActiveMember),rho = 0)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(IsActiveMember),
## rho = 0)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(IsActiveMember)=0 4849 1302 1009 85.1 179
## factor(IsActiveMember)=1 5151 735 1028 83.5 179
##
## Chisq= 179 on 1 degrees of freedom, p= <2e-16survdiff(Surv(Tenure,Exited)~factor(IsActiveMember),rho = 1)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(IsActiveMember),
## rho = 1)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(IsActiveMember)=0 4849 1129 876 72.7 171
## factor(IsActiveMember)=1 5151 643 895 71.1 171
##
## Chisq= 171 on 1 degrees of freedom, p= <2e-16Para el caso de Tener o no Tener Tarjeta de Crédito.
No rechazamos Ho: Las funciones de supervivencia son iguales ya que p-value<0.05 y se muestra la salida de las pruebas de hipótesis realizadas (para un nivel de significación del 5%)
#K-M para HasCrCard
comp3 <- survfit(Surv(Tenure,Exited)~factor(HasCrCard), type = "kaplan-meier", conf.type="plain",
data=Datos)
plot(comp3, conf.int=F,xlab="Tiempo", ylab="S(t)", lty=c(1,4),
col=c("blue","red"),
main = "Comparación de S(t) para la variable HasCrCard")
legend("bottomleft", c("No Tiene", "Tiene"),
lty=c(1,4), col=c("blue","red"))
#Comparación de supervivencias
survdiff(Surv(Tenure,Exited)~factor(HasCrCard),rho = 0)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(HasCrCard),
## rho = 0)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(HasCrCard)=0 2945 613 587 1.197 1.78
## factor(HasCrCard)=1 7055 1424 1450 0.484 1.78
##
## Chisq= 1.8 on 1 degrees of freedom, p= 0.2survdiff(Surv(Tenure,Exited)~factor(HasCrCard),rho = 1)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(HasCrCard),
## rho = 1)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(HasCrCard)=0 2945 534 511 1.048 1.75
## factor(HasCrCard)=1 7055 1238 1261 0.424 1.75
##
## Chisq= 1.7 on 1 degrees of freedom, p= 0.2Para el caso de Número de productos. Rechazamos Ho: Las funciones de supervivencia son iguales ya que p-value<0.05 y se muestra la salida de las pruebas de hipótesis realizadas (para un nivel de significación del 5%) Esto nos indica que no importa le número de productos contratados, sin embargo podemos ver en la gráfica que son más los clientes que tiene entre uno y dos productos que permanecen como clientes del banco.
#K-M para NumOfProducts
comp4 <- survfit(Surv(Tenure,Exited)~factor(NumOfProducts), type = "kaplan-meier", conf.type="plain",
data=Datos)
plot(comp4, conf.int=F,xlab="Tiempo", ylab="S(t)", lty=c(1,4),
col=c("yellow","black","blue","red","green","violet","orange","magenta"),
main = "Comparación de s(t) para la variable NumofProducts")
legend("bottomleft", c("2 productos","1 producto","3 productos", "4 productos"), lty=c(1,4),
col=c("yellow","black","blue","red"))
#Comparación de supervivencias
survdiff(Surv(Tenure,Exited)~factor(NumOfProducts),rho = 0)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(NumOfProducts),
## rho = 0)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(NumOfProducts)=1 5084 1409 1027.2 142 304
## factor(NumOfProducts)=2 4590 348 941.4 374 737
## factor(NumOfProducts)=3 266 220 54.7 499 545
## factor(NumOfProducts)=4 60 60 13.7 157 169
##
## Chisq= 1246 on 3 degrees of freedom, p= <2e-16survdiff(Surv(Tenure,Exited)~factor(NumOfProducts),rho = 1)## Call:
## survdiff(formula = Surv(Tenure, Exited) ~ factor(NumOfProducts),
## rho = 1)
##
## N Observed Expected (O-E)^2/E (O-E)^2/V
## factor(NumOfProducts)=1 5084 1226.7 893.5 124 298
## factor(NumOfProducts)=2 4590 302.7 818.6 325 719
## factor(NumOfProducts)=3 266 190.4 47.4 432 530
## factor(NumOfProducts)=4 60 51.3 11.7 134 164
##
## Chisq= 1212 on 3 degrees of freedom, p= <2e-16Ajuste Paramétrico del modelo. Modelo de Cox. Con esto cual podemos concluir que el modelo es significativo para cualquiera de los tres criterios (test de razón de verosimilitud, test de Wald y test de los puntajes (score ologrank))
#Partiremos de la estimación KM
datos1.surv<-Surv(Tenure,Exited)
estimador<-survfit(datos1.surv~1,type="kaplan-meier", conf.type="log-log", conf.int=0.95, data=Datos)
## Modelo de Cox.
est1 <- coxph(datos1.surv~ Geography + Gender + Age + Balance + NumOfProducts
+ HasCrCard + IsActiveMember + EstimatedSalary )
est1## Call:
## coxph(formula = datos1.surv ~ Geography + Gender + Age + Balance +
## NumOfProducts + HasCrCard + IsActiveMember + EstimatedSalary)
##
## coef exp(coef) se(coef) z p
## GeographyGermany 4.892e-01 1.631e+00 5.433e-02 9.005 < 2e-16
## GeographySpain 4.677e-02 1.048e+00 6.049e-02 0.773 0.4394
## GenderMale -3.855e-01 6.801e-01 4.476e-02 -8.612 < 2e-16
## Age 4.751e-02 1.049e+00 1.776e-03 26.752 < 2e-16
## Balance 2.091e-06 1.000e+00 4.384e-07 4.770 1.84e-06
## NumOfProducts -6.572e-02 9.364e-01 3.871e-02 -1.698 0.0895
## HasCrCard -6.162e-02 9.402e-01 4.835e-02 -1.275 0.2025
## IsActiveMember -7.416e-01 4.764e-01 4.745e-02 -15.630 < 2e-16
## EstimatedSalary 6.358e-09 1.000e+00 3.834e-07 0.017 0.9868
##
## Likelihood ratio test=1152 on 9 df, p=< 2.2e-16
## n= 10000, number of events= 2037exp(est1$coefficients)## GeographyGermany GeographySpain GenderMale Age
## 1.6310532 1.0478841 0.6801060 1.0486571
## Balance NumOfProducts HasCrCard IsActiveMember
## 1.0000021 0.9363903 0.9402386 0.4763641
## EstimatedSalary
## 1.0000000modelo_Cox<-survfit(est1)
confint(est1, level = 0.95)## 2.5 % 97.5 %
## GeographyGermany 3.827423e-01 5.957096e-01
## GeographySpain -7.177890e-02 1.653248e-01
## GenderMale -4.732372e-01 -2.977761e-01
## Age 4.402956e-02 5.099115e-02
## Balance 1.232161e-06 2.950787e-06
## NumOfProducts -1.415925e-01 1.014672e-02
## HasCrCard -1.563827e-01 3.313938e-02
## IsActiveMember -8.345642e-01 -6.485814e-01
## EstimatedSalary -7.450948e-07 7.578098e-07plot(modelo_Cox,main="S(t) estimada con\n el modelo de Cox\n para las variables",
xlab="Tiempo", ylab="Proba. de sobrevivencia",
lwd=2, col="blue", cex.lab=0.7)
summary(est1)## Call:
## coxph(formula = datos1.surv ~ Geography + Gender + Age + Balance +
## NumOfProducts + HasCrCard + IsActiveMember + EstimatedSalary)
##
## n= 10000, number of events= 2037
##
## coef exp(coef) se(coef) z Pr(>|z|)
## GeographyGermany 4.892e-01 1.631e+00 5.433e-02 9.005 < 2e-16 ***
## GeographySpain 4.677e-02 1.048e+00 6.049e-02 0.773 0.4394
## GenderMale -3.855e-01 6.801e-01 4.476e-02 -8.612 < 2e-16 ***
## Age 4.751e-02 1.049e+00 1.776e-03 26.752 < 2e-16 ***
## Balance 2.091e-06 1.000e+00 4.384e-07 4.770 1.84e-06 ***
## NumOfProducts -6.572e-02 9.364e-01 3.871e-02 -1.698 0.0895 .
## HasCrCard -6.162e-02 9.402e-01 4.835e-02 -1.275 0.2025
## IsActiveMember -7.416e-01 4.764e-01 4.745e-02 -15.630 < 2e-16 ***
## EstimatedSalary 6.358e-09 1.000e+00 3.834e-07 0.017 0.9868
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## exp(coef) exp(-coef) lower .95 upper .95
## GeographyGermany 1.6311 0.6131 1.4663 1.8143
## GeographySpain 1.0479 0.9543 0.9307 1.1798
## GenderMale 0.6801 1.4704 0.6230 0.7425
## Age 1.0487 0.9536 1.0450 1.0523
## Balance 1.0000 1.0000 1.0000 1.0000
## NumOfProducts 0.9364 1.0679 0.8680 1.0102
## HasCrCard 0.9402 1.0636 0.8552 1.0337
## IsActiveMember 0.4764 2.0992 0.4341 0.5228
## EstimatedSalary 1.0000 1.0000 1.0000 1.0000
##
## Concordance= 0.717 (se = 0.006 )
## Rsquare= 0.109 (max possible= 0.967 )
## Likelihood ratio test= 1152 on 9 df, p=<2e-16
## Wald test = 1198 on 9 df, p=<2e-16
## Score (logrank) test = 1241 on 9 df, p=<2e-16variable_1 <- coxph(datos1.surv~Geography)
variable_1## Call:
## coxph(formula = datos1.surv ~ Geography)
##
## coef exp(coef) se(coef) z p
## GeographyGermany 0.70863 2.03120 0.04963 14.277 <2e-16
## GeographySpain 0.03123 1.03172 0.06047 0.516 0.606
##
## Likelihood ratio test=223.7 on 2 df, p=< 2.2e-16
## n= 10000, number of events= 2037variable_2 <- coxph(datos1.surv~Gender)
variable_2## Call:
## coxph(formula = datos1.surv ~ Gender)
##
## coef exp(coef) se(coef) z p
## GenderMale -0.44517 0.64072 0.04463 -9.974 <2e-16
##
## Likelihood ratio test=100.4 on 1 df, p=< 2.2e-16
## n= 10000, number of events= 2037variable_3 <- coxph(datos1.surv~Age)
variable_3## Call:
## coxph(formula = datos1.surv ~ Age)
##
## coef exp(coef) se(coef) z p
## Age 0.04281 1.04374 0.00165 25.94 <2e-16
##
## Likelihood ratio test=576.1 on 1 df, p=< 2.2e-16
## n= 10000, number of events= 2037variable_4 <- coxph(datos1.surv~Balance)
variable_4## Call:
## coxph(formula = datos1.surv ~ Balance)
##
## coef exp(coef) se(coef) z p
## Balance 4.145e-06 1.000e+00 3.695e-07 11.22 <2e-16
##
## Likelihood ratio test=130.3 on 1 df, p=< 2.2e-16
## n= 10000, number of events= 2037variable_5 <- coxph(datos1.surv~NumOfProducts)
variable_5## Call:
## coxph(formula = datos1.surv ~ NumOfProducts)
##
## coef exp(coef) se(coef) z p
## NumOfProducts -0.19450 0.82325 0.03996 -4.867 1.13e-06
##
## Likelihood ratio test=24.33 on 1 df, p=8.13e-07
## n= 10000, number of events= 2037variable_6 <- coxph(datos1.surv~HasCrCard)
variable_6## Call:
## coxph(formula = datos1.surv ~ HasCrCard)
##
## coef exp(coef) se(coef) z p
## HasCrCard -0.06356 0.93842 0.04831 -1.316 0.188
##
## Likelihood ratio test=1.72 on 1 df, p=0.1902
## n= 10000, number of events= 2037variable_7 <- coxph(datos1.surv~IsActiveMember)
variable_7## Call:
## coxph(formula = datos1.surv ~ IsActiveMember)
##
## coef exp(coef) se(coef) z p
## IsActiveMember -0.60943 0.54366 0.04614 -13.21 <2e-16
##
## Likelihood ratio test=182 on 1 df, p=< 2.2e-16
## n= 10000, number of events= 2037variable_8 <- coxph(datos1.surv~EstimatedSalary)
variable_8## Call:
## coxph(formula = datos1.surv ~ EstimatedSalary)
##
## coef exp(coef) se(coef) z p
## EstimatedSalary 3.013e-07 1.000e+00 3.859e-07 0.781 0.435
##
## Likelihood ratio test=0.61 on 1 df, p=0.4349
## n= 10000, number of events= 2037variables_Sig <- coxph(datos1.surv~ Geography + Gender + Age + Balance + NumOfProducts
+ IsActiveMember)
modelo_Cox_sig<-survfit(variables_Sig)
plot(modelo_Cox_sig,main="S(t) estimada con el modelo de Cox para\n variables significativas",
xlab="Tiempo", ylab="s(t)", lwd=2, col="lightseagreen",
cex.lab=0.7)
summary(variables_Sig)## Call:
## coxph(formula = datos1.surv ~ Geography + Gender + Age + Balance +
## NumOfProducts + IsActiveMember)
##
## n= 10000, number of events= 2037
##
## coef exp(coef) se(coef) z Pr(>|z|)
## GeographyGermany 4.875e-01 1.628e+00 5.432e-02 8.975 < 2e-16 ***
## GeographySpain 4.628e-02 1.047e+00 6.048e-02 0.765 0.4441
## GenderMale -3.861e-01 6.797e-01 4.475e-02 -8.627 < 2e-16 ***
## Age 4.753e-02 1.049e+00 1.775e-03 26.775 < 2e-16 ***
## Balance 2.104e-06 1.000e+00 4.383e-07 4.801 1.58e-06 ***
## NumOfProducts -6.545e-02 9.366e-01 3.868e-02 -1.692 0.0906 .
## IsActiveMember -7.407e-01 4.768e-01 4.742e-02 -15.620 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## exp(coef) exp(-coef) lower .95 upper .95
## GeographyGermany 1.6283 0.6141 1.4639 1.8112
## GeographySpain 1.0474 0.9548 0.9303 1.1792
## GenderMale 0.6797 1.4712 0.6226 0.7420
## Age 1.0487 0.9536 1.0450 1.0523
## Balance 1.0000 1.0000 1.0000 1.0000
## NumOfProducts 0.9366 1.0676 0.8683 1.0104
## IsActiveMember 0.4768 2.0974 0.4345 0.5232
##
## Concordance= 0.717 (se = 0.006 )
## Rsquare= 0.109 (max possible= 0.967 )
## Likelihood ratio test= 1150 on 7 df, p=<2e-16
## Wald test = 1197 on 7 df, p=<2e-16
## Score (logrank) test = 1239 on 7 df, p=<2e-16str(modelo_Cox_sig)## List of 14
## $ n : int 10000
## $ time : num [1:11] 0 1 2 3 4 5 6 7 8 9 ...
## $ n.risk : num [1:11] 10000 9587 8552 7504 6495 ...
## $ n.event : num [1:11] 95 232 201 213 203 209 196 177 197 213 ...
## $ n.censor : num [1:11] 318 803 847 796 786 803 771 851 828 771 ...
## $ surv : num [1:11] 0.993 0.974 0.956 0.935 0.913 ...
## $ type : chr "right"
## $ cumhaz : num [1:11] 0.00732 0.02625 0.04463 0.0669 0.09149 ...
## $ std.err : num [1:11] 0.00076 0.00151 0.00207 0.00269 0.00334 ...
## $ lower : num [1:11] 0.991 0.971 0.952 0.93 0.907 ...
## $ upper : num [1:11] 0.994 0.977 0.96 0.94 0.919 ...
## $ conf.type: chr "log"
## $ conf.int : num 0.95
## $ call : language survfit(formula = variables_Sig)
## - attr(*, "class")= chr [1:2] "survfit.cox" "survfit"confint(variables_Sig, level = 0.95)## 2.5 % 97.5 %
## GeographyGermany 3.810717e-01 5.940080e-01
## GeographySpain -7.225969e-02 1.648271e-01
## GenderMale -4.737739e-01 -2.983530e-01
## Age 4.405214e-02 5.101096e-02
## Balance 1.245045e-06 2.963105e-06
## NumOfProducts -1.412727e-01 1.036666e-02
## IsActiveMember -8.336391e-01 -6.477526e-01exp(confint(variables_Sig))## 2.5 % 97.5 %
## GeographyGermany 1.4638526 1.8112333
## GeographySpain 0.9302893 1.1791892
## GenderMale 0.6226480 0.7420394
## Age 1.0450368 1.0523344
## Balance 1.0000012 1.0000030
## NumOfProducts 0.8682525 1.0104206
## IsActiveMember 0.4344653 0.5232203Conclusiones. Nuestra base de datos tiene 10,000 usuarios registrados, de los cuales 7055 clientes tienen tarjeta, 5151 están activos y 5084 personas contrataron 1 produto. Además 7963 permanecen siendo clientes, es decir que 2037 se han ido. Esto nos puede indicar que las perosnas que sólo contratan un producto tiene mayor posibilidad de mantenerse activos en un banco.
Parael análisis de supervivencia podemos notar que permanecen como clientes del banco hasta aproximadamente 10 años como máximo. Esto nos indica que posiblemente el plan del banco es rentable para los clientes hasta esa fecha, podría ser por las tasas de interés que se cobran. Y que en intervalos de un año, los clientes salen o se censuran dentro del estudio.
Además que es más probable que las mujeres permanezcan como ususarios del banco a que los hombres pernmanezcan, considerando que inicialmente la cantidad de clientes hombres es mayor.
Otra información importante, obtenida directamente a través de salida anterior es la estimación de los riesgos relativos (a partir de los exp(coef)) es: En el Modelo de Cox veamos que:
IsActiveMember: Tenemos exp(coef)=0.4344, lo que nos dice que por cada unidad que aumenta, el riesgo disminuye un 52.3% Age: Tenemos esp(coef)=1.045036, lo que nos dice que por cada unidad que aumenta, el riesgo de sufrir el evento es 5.02% NumOfProducts: Tenemos exp(coef)=0.86825, lo que nos dice que por cada unidad que aumenta, el riesgo disminuye un 14.3%
Y que los miembros de España y Alemania son significativos puede implicar que tienen mayor permanencia en el banco que los de Francia. Así como las mujeres. GeographyGermany 1.4638526 1.8112333 GeographySpain 0.9302893 1.1791892 GenderMale 0.6226480 0.7420394 Age 1.0450368 1.0523344 Balance 1.0000012 1.0000030 NumOfProducts 0.8682525 1.0104206 IsActiveMember 0.4344653 0.5232203
Respondiendo a la pregunta ¿Qué podemos hacer para mejorar la retención del cliente? Dado un cliente del Banco, ¿podemos construir un clasificador que pueda determinar si se irán o no?
De acuerdo a lo analizado en la base de datos veamos que la satisfacción del cliente dentro del banco es de aproximadamente 10 años. Inicialmente creo que debe preguntarse el banco ¿quiénes son sus clientes? y con base en eso debe crear productos que se adapten a las ncesidades del cliente, ya que como podemos ver en la base son muy poco los clientes que tienen acceso a más de dos productos. Actaulmente existen muchas estrategias de retención de clientes, los cuales se van categorizando dependido del tipo de cliente que quiera consumir el producto, como jóvenes, empresarios, obreros, empresas etc.
Eso como parte de la compra y venta del producto. Actualmete para el análisis de la retención de clientes existen métodos más específicos que usan algoritmos complejos y logística para determinar las preferencias de los clientes. Donde se analizan los sitios Web, las redes sociales de los clientes. De este modo es posible determinar factores fundamentales que pueden ayudar a saber si un cliente permanece o no como parte de una empresa, obviamente con un posible margen de error.