Prueba Técnica BS
Leonel Morales
2024-01-27
Presentación del problema
De un conjunto de datos, se requiere analizar la colección de clientes que han desertado o no.
Cargando la data
Cargamos la data de clientes del Banco, la delimitamos y hallamos posibles missing values, outliers.
download.file("https://raw.githubusercontent.com/vmoprojs/DataLectures/master/Bank_churn_modelling.csv",
"df", "curl")
df<-read.csv("df", header=T)
attach(df)Verificamos missing values
df[!complete.cases(df),] # no hay missing values [1] RowNumber CustomerId Surname CreditScore
[5] Geography Gender Age Tenure
[9] Balance NumOfProducts HasCrCard IsActiveMember
[13] EstimatedSalary Exited
<0 rows> (or 0-length row.names)Se observa, que la data, no tiene ningún missing value en cada una de sus columnas
Delimitamos la data eliminando, el código de fila, el id de cliente y su apellido.
df1<-df %>%
dplyr::select(-RowNumber,-CustomerId,-Surname)Transformación de los datos
Para crear los modelos de predicción se requiere que las variables categóricas sean transformadas a ceros y unos.
Geografía: España, Alemania y Francia serán 3, 2, 1 respectivamente.
Género: 1 para hombres y 0 para mujeres.
df1$Gender<- factor(df$Gender,levels = c("Male","Female"),labels=c(1,0))
df1$Geography<-factor(df1$Geography,levels = c("France","Germany","Spain"),
labels=c(1,2,3))Exploración de los datos
Se usa gráficos dinámicos para detectar posibles outliers, y otros análisis. Empezamos con un breve Resumen para las variables, edad vs Exited, Salario estimado vs Exited, género y geografía.
Los clientes que disertan tienen una mediana de 36 años, los datos son simetricos. Los clientes que no disertan tienen una mediana de 45 años con cierta tendencia a valores altos y un posible outlier de clientes de 18 años.
Los clientes que disertan tienen una mediana de casi 100 000 um, los datos son simétricos. Los clientes que disertan y no disertan tienen casi el mismo salario estimado, por lo que no convendría tenerla en cuenta para un modelo.
Se observa que la distribución del credit score, es similar para los clientes que desertan versus los que no.
Análisis Discriminante
Con el objeto de saber cuales de los clientes son desertores en función de las variables elegidas, se realiza el LDA, eliminando la variable \(EstimatedSalary\).
df2<-df1%>% # elimino la variable analizada
dplyr::select(-EstimatedSalary,-HasCrCard)
modelo_disc<-lda(Exited~.,df2)
modelo_discCall:
lda(Exited ~ ., data = df2)
Prior probabilities of groups:
0 1
0.7963 0.2037
Group means:
CreditScore Geography2 Geography3 Gender0 Age Tenure Balance
0 651.8532 0.2128595 0.2591988 0.4274771 37.40839 5.033279 72745.30
1 645.3515 0.3996073 0.2027491 0.5591556 44.83800 4.932744 91108.54
NumOfProducts IsActiveMember
0 1.544267 0.5545649
1 1.475209 0.3608247
Coefficients of linear discriminants:
LD1
CreditScore -6.510119e-04
Geography2 8.753846e-01
Geography3 2.825072e-02
Gender0 5.180358e-01
Age 7.705094e-02
Tenure -1.327664e-02
Balance 2.192320e-06
NumOfProducts -1.084348e-01
IsActiveMember -9.796034e-01Según el resultado, mientras más edad tenga el cliente más probabilidad tiene de que no diserte. El siguiente código muestra como el modelo clasfica a los clientes en virtud de las variables elegidas.
d<-predict(modelo_disc)$class # clasificación de los clientesMatriz de Clasificación
crt<-table(predict(modelo_disc)$class,Exited)
crt Exited
0 1
0 7603 1565
1 360 472Diagonalizamos para obtener el porcentaje de clasificación correcta
diag(prop.table(crt,1)) # clasificación correcta para unos y ceros 0 1
0.8292976 0.5673077 sum(diag(prop.table(crt))) # porcentaje de clasificación correcta[1] 0.8075El modelo clasifica muy bien cuando \(\mu=0.5\) (umbral), pues obtenemos el 80%.
Cambiando el umbral
El anterior análisis nos sirve cuando el umbral es 0.5, es decir si las probabilidades son mayores que 0.5, entonces el cliente va al grupo de clientes desertores. Sin embargo, lo ideal es usar el umbral verdadero. En efecto,
catia_base<-predict(modelo_disc)$posterior[,2] # extrae la segunda col.
umbr<-mean(catia_base)
umbr # umbral verdadero[1] 0.2034856De manera similar, analizamos el porcentaje correcto de clasificación del modelo para el nuevo umbral:
tabu<-table(catia_base>umbr,Exited)
tabu Exited
0 1
FALSE 5735 634
TRUE 2228 1403# diag, la matrioz
diag(prop.table(tabu,1)) # clasif, correcta para unos y ceros[1] 0.9004553 0.3863949sum(diag(prop.table(tabu))) # la clasif, correcta disminuyó[1] 0.7138Notamos que con un umbral de 0.2 me da un porcentaje de clasificación correcta del \(71\) por ciento. Disminuyó respecto al umbral de \(0.5\).
Curva Roc
pred<-prediction(catia_base,df1$Exited)
perfo<-performance(pred,"sens","spec")
sen<-slot(perfo,"y.values"[[1]])
esp<-slot(perfo,"x.values"[[1]])
alfa<-slot(perfo,"alpha.values"[[1]])
mati<-data.frame(alfa,sen,esp)
names(mati)[1]<-"alfa"
names(mati)[2] <- "sen"
names(mati)[3]<-"esp"
mi<-melt(mati,id=c("alfa"))p=ggplot(mi,aes(alfa,value,group=variable,colour=variable))+
geom_line(size=1.2)+
labs(title="punto de corte optimo para lda",x="cut off")
ggplotly(p)perf<-performance(pred, measure = "tpr",x.measure = "fpr")
plot(perf,colorize=T,lty=3)
abline(0,1,col="black")
Eligiendo el umbral de 0.5, el modelo clasifica bien. Basta comparar con los modelos logit y probit.
Modelos Logit y Probit
Eligiendo las mismas variables, se realiza el modelo logístico y probabilistico, para después comparar con LDA. Para el efecto, creamos una data de entrenamiento y de testing.
set.seed(1234)
training.muestra<-df1$Exited%>%
createDataPartition(p=0.8,list=F)
train.data<-df1[training.muestra,]
test.data<-df1[-training.muestra,]
set.seed(1234)
training.muestra2<-df2$Exited%>%
createDataPartition(p=0.8,list=F)
train.data2<-df2[training.muestra,]
test.data2<-df2[-training.muestra,]Ajustamos el modelo logit, luego validamos variables significativas.
Call:
glm(formula = Exited ~ ., family = binomial(link = "logit"),
data = train.data)
Deviance Residuals:
Min 1Q Median 3Q Max
-2.3546 -0.6580 -0.4525 -0.2660 2.9181
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) -3.959e+00 2.740e-01 -14.449 < 2e-16 ***
CreditScore -4.913e-04 3.150e-04 -1.560 0.1188
Geography2 8.170e-01 7.541e-02 10.834 < 2e-16 ***
Geography3 6.559e-02 7.892e-02 0.831 0.4059
Gender0 5.478e-01 6.101e-02 8.979 < 2e-16 ***
Age 7.222e-02 2.880e-03 25.078 < 2e-16 ***
Tenure -7.637e-03 1.044e-02 -0.731 0.4645
Balance 2.656e-06 5.733e-07 4.632 3.62e-06 ***
NumOfProducts -1.479e-01 5.280e-02 -2.801 0.0051 **
HasCrCard -4.435e-02 6.638e-02 -0.668 0.5041
IsActiveMember -1.093e+00 6.449e-02 -16.952 < 2e-16 ***
EstimatedSalary 2.133e-08 5.286e-07 0.040 0.9678
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 8113.4 on 7999 degrees of freedom
Residual deviance: 6846.1 on 7988 degrees of freedom
AIC: 6870.1
Number of Fisher Scoring iterations: 5Notamos que la variable hascrcard y estimatedSalary no son significativas, por lo tanto no son tomadas en cuenta para los modelos.
logit.l<-glm(Exited~CreditScore + Geography + Gender + Age +
Tenure + Balance + NumOfProducts + IsActiveMember,family=binomial(link = "logit"),data=train.data2)
probi<-glm(Exited~.,family = binomial(link = "probit"),data = train.data2)De esta manera las variables de Puntaje de crédito, Goegrafía, genero suben su significancia, respecto al modelo que contenia las dos variables.
Bondad de ajuste
Hosmer and Lemeshow goodness of fit (GOF) test
data: train.data2$Exited, fitted(logit.l)
X-squared = 19.225, df = 18, p-value = 0.3781
Hosmer and Lemeshow goodness of fit (GOF) test
data: train.data2$Exited, fitted(probi)
X-squared = 17.947, df = 18, p-value = 0.4591Según el contraste Hoslem-Lemeshow, los datos se ajustan muy bien. A continuación se presenta la matriz de clasificacion
$rawtab
resp
0 1
FALSE 4512 500
TRUE 1849 1139
$classtab
resp
0 1
FALSE 0.7093224 0.3050641
TRUE 0.2906776 0.6949359
$overall
[1] 0.706375
$mcFadden
[1] 0.156136$rawtab
resp
0 1
FALSE 4420 468
TRUE 1941 1171
$classtab
resp
0 1
FALSE 0.6948593 0.2855400
TRUE 0.3051407 0.7144600
$overall
[1] 0.698875
$mcFadden
[1] 0.1560952Según lo observado, el modelo logit es mucho mejor, pues tiene un porcentaje de clasificación de \(0.71\) vs \(0.69\) del probit. Además, es mucho mejor que el modelo LDA, incluso con umbrales de \(0.5\).
Áreas bajo la curva
[1] 0.7707911Comparación entre modelos
Una vez ajustado los modelos: LDA, logit y probit se hace una comparación según el overall y los coeficeintes AIC, BIC.
Calls:
logit.l: glm(formula = Exited ~ CreditScore + Geography + Gender + Age +
Tenure + Balance + NumOfProducts + IsActiveMember, family = binomial(link = "logit"),
data = train.data2)
probi: glm(formula = Exited ~ ., family = binomial(link = "probit"),
data = train.data2)
====================================================
logit.l probi
----------------------------------------------------
(Intercept) -3.988609*** -2.324615***
(0.264759) (0.149555)
CreditScore -0.000491 -0.000309
(0.000315) (0.000179)
Geography: 2/1 0.816492*** 0.469498***
(0.075403) (0.043338)
Geography: 3/1 0.065928 0.038533
(0.078921) (0.043930)
Gender: 0/1 0.548111*** 0.317178***
(0.060994) (0.034484)
Age 0.072215*** 0.041512***
(0.002879) (0.001630)
Tenure -0.007792 -0.004087
(0.010436) (0.005924)
Balance 0.000003*** 0.000002***
(0.000001) (0.000000)
NumOfProducts -0.147860** -0.077832*
(0.052786) (0.030243)
IsActiveMember -1.092342*** -0.592777***
(0.064462) (0.035598)
----------------------------------------------------
Nagelkerke R-sq. 0.230 0.230
Deviance 6846.597 6846.928
AIC 6866.597 6866.928
BIC 6936.469 6936.800
N 8000 8000
====================================================
Significance: *** = p < 0.001; ** = p < 0.01;
* = p < 0.05 Según los coeficientes AIC, BIC, se deduce que el mejor modelo es el logístico, pues tiene un mejor porcentaje de clasificación cuando \(\mu=0.2\), incluso cuando \(\mu=0.5\).
Conclusiones
-Se concluye que los clientes que tienen edades de entre 37 y 51 son los que están desertando más.
-El salario estimado de los clientes no es una buena predictora, debido a que, tienen un salario casi igual en detrimento a los que no.
-Posiblemente el banco está perdiendo clientes, pues los clientes con más balance, también son los que están desertando.
-Las variables Credit score y tenure también se podrían quitar del modelo. Sin embargo, según las necesidades y requerimientos del área debe ser analizada en conjunto.
Índices y Agrupaciones
Se podría usar el análisis RFM, sin emabargo falta la fecha. Se ejecuta para este análisis se usa el árbol de clasificación para segmentar a los clientes. Entrenamos la data: dividimos en 80 por ciento y 20 por ceinto.
load("C:/Users/Admin/Downloads/FRI.RData")
set.seed(1649)
train.muestra <- sample_frac(FRI, 0.8) # usamos la funcion de dplyr
test.muestra<-setdiff(FRI,train.muestra)Ajuste del modelo
arbol<- rpart(formula = Ingresos ~ ., data = train.muestra)```