Caso de estudio institución bancaria portuguesa
Mikel De Juan
1 Contexto del proyecto
Los datos están relacionados con las campañas de marketing directo de una institución bancaria portuguesa. Las campañas de marketing se basaron en llamadas telefónicas. A menudo, se requirió más de un contacto para el mismo cliente, para poder acceder si el producto (depósito a plazo bancario) estaría suscrito (‘sí’) o no (‘no’).
Nuestra labor es evaluar con multiples modelos de machine learning cual produce los mejores resultados
2 Objetivos
2.1 Objetivos de la tarea
El objetivo de la clasificación es predecir si el cliente suscribirá (sí / no) un depósito a plazo (variable y).
2.2 Contexto del database
Hay cuatro conjuntos de datos:
- bank-additional-full.csv con todos los ejemplos (41188) y 20 entradas, ordenados por fecha (de mayo de 2008 a noviembre de 2010), muy cerca de los datos analizados en [Moro et al., 2014]
- bank-additional.csv con 10% de los ejemplos (4119), seleccionados aleatoriamente de 1), y 20 entradas.
- bank-full.csv con todos los ejemplos y 17 entradas, ordenadas por fecha (versión anterior de este conjunto de datos con menos entradas).
- bank.csv con 10% de los ejemplos y 17 entradas, seleccionadas al azar de 3 (versión anterior de este conjunto de datos con menos entradas). Los conjuntos de datos más pequeños se proporcionan para probar algoritmos de aprendizaje de máquina que requieren más computación (por ejemplo, SVM).
2.3 Constitucion del dataset
Nos han provisto con un amplio database que consta de los siguientes atributos:
*1 - age (numeric)
*2 - job : type of job (categorical: ‘admin.’,‘blue-collar’,‘entrepreneur’,‘housemaid’,‘management’,‘retired’,‘self-employed’,‘services’,‘student’,‘technician’,‘unemployed’,‘unknown’)
*3 - marital : marital status (categorical: ‘divorced’,‘married’,‘single’,‘unknown’; note: ‘divorced’ means divorced or widowed)
*4 - education (categorical: ‘basic.4y’,‘basic.6y’,‘basic.9y’,‘high.school’,‘illiterate’,‘professional.course’,‘university.degree’,‘unknown’)
*5 - default: has credit in default? (categorical: ‘no’,‘yes’,‘unknown’)
*6 - housing: has housing loan? (categorical: ‘no’,‘yes’,‘unknown’)
*7 - loan: has personal loan? (categorical: ‘no’,‘yes’,‘unknown’)
*8 - contact: contact communication type (categorical: ‘cellular’,‘telephone’)
*9 - month: last contact month of year (categorical: ‘jan’, ‘feb’, ‘mar’, …, ‘nov’, ‘dec’)
*10 - day_of_week: last contact day of the week (categorical: ‘mon’,‘tue’,‘wed’,‘thu’,‘fri’)
*11 - duration: last contact duration, in seconds (numeric). Important note: this attribute highly affects the output target (e.g., if duration=0 then y=‘no’). Yet, the duration is not known before a call is performed. Also, after the end of the call y is obviously known. Thus, this input should only be included for benchmark purposes and should be discarded if the intention is to have a realistic predictive model.
*12 - campaign: number of contacts performed during this campaign and for this client (numeric, includes last contact)
*13 - pdays: number of days that passed by after the client was last contacted from a previous campaign (numeric; 999 means client was not previously contacted)
*14 - previous: number of contacts performed before this campaign and for this client (numeric)
*15 - poutcome: outcome of the previous marketing campaign (categorical: ‘failure’,‘nonexistent’,‘success’)
*16 - emp.var.rate: employment variation rate - quarterly indicator (numeric)
*17 - cons.price.idx: consumer price index - monthly indicator (numeric)
*18 - cons.conf.idx: consumer confidence index - monthly indicator (numeric)
*19 - euribor3m: euribor 3 month rate - daily indicator (numeric)
*20 - nr.employed: number of employees - quarterly indicator (numeric)
*21 - y - has the client subscribed a term deposit? (binary: ‘yes’,‘no’)
3 Proceso de trabajo
1.Exploración del dataset 2.Pre-procesado de la información 3.División de la información 4.Predicción de las variables 5.Conclusiones
4 Preprocesado de los datos
Cargamos las librerias.
library("openxlsx")
library("xlsx")
library("readxl")
library("caret")
library("tidyr")
library("dplyr")
library("lubridate")
library("ggplot2")
library("ROCR")
library("C50")Leemos las tabla de datos.
df <- read.csv("C:/Users/mikel/Desktop/Data Analysis/Banco/Bank additional/bank-additional.csv",sep = ";", header = TRUE, stringsAsFactors = FALSE)En primera instancia vamos a valorar la estructura del dataset, conocer la clase de variables con las que vamos a trabajar y si dentro del dataset encontramos missing values que puedan dificultar la gestión de los datos. En este caso, no hay ningún NA, lo que nos hace trabajar el dataset sin ningún problema.
Destacamos que, teniendo en cuenta nuestro objetivo, actualmente un 89% de las personas no disponen de un plazo a deposito variable, lo que supone 3668 personas de un total de 4119.
dim(df)## [1] 4119 21head(df)## age job marital education default housing loan
## 1 30 blue-collar married basic.9y no yes no
## 2 39 services single high.school no no no
## 3 25 services married high.school no yes no
## 4 38 services married basic.9y no unknown unknown
## 5 47 admin. married university.degree no yes no
## 6 32 services single university.degree no no no
## contact month day_of_week duration campaign pdays previous poutcome
## 1 cellular may fri 487 2 999 0 nonexistent
## 2 telephone may fri 346 4 999 0 nonexistent
## 3 telephone jun wed 227 1 999 0 nonexistent
## 4 telephone jun fri 17 3 999 0 nonexistent
## 5 cellular nov mon 58 1 999 0 nonexistent
## 6 cellular sep thu 128 3 999 2 failure
## emp.var.rate cons.price.idx cons.conf.idx euribor3m nr.employed y
## 1 -1.8 92.893 -46.2 1.313 5099.1 no
## 2 1.1 93.994 -36.4 4.855 5191.0 no
## 3 1.4 94.465 -41.8 4.962 5228.1 no
## 4 1.4 94.465 -41.8 4.959 5228.1 no
## 5 -0.1 93.200 -42.0 4.191 5195.8 no
## 6 -1.1 94.199 -37.5 0.884 4963.6 nostr(df)## 'data.frame': 4119 obs. of 21 variables:
## $ age : int 30 39 25 38 47 32 32 41 31 35 ...
## $ job : chr "blue-collar" "services" "services" "services" ...
## $ marital : chr "married" "single" "married" "married" ...
## $ education : chr "basic.9y" "high.school" "high.school" "basic.9y" ...
## $ default : chr "no" "no" "no" "no" ...
## $ housing : chr "yes" "no" "yes" "unknown" ...
## $ loan : chr "no" "no" "no" "unknown" ...
## $ contact : chr "cellular" "telephone" "telephone" "telephone" ...
## $ month : chr "may" "may" "jun" "jun" ...
## $ day_of_week : chr "fri" "fri" "wed" "fri" ...
## $ duration : int 487 346 227 17 58 128 290 44 68 170 ...
## $ campaign : int 2 4 1 3 1 3 4 2 1 1 ...
## $ pdays : int 999 999 999 999 999 999 999 999 999 999 ...
## $ previous : int 0 0 0 0 0 2 0 0 1 0 ...
## $ poutcome : chr "nonexistent" "nonexistent" "nonexistent" "nonexistent" ...
## $ emp.var.rate : num -1.8 1.1 1.4 1.4 -0.1 -1.1 -1.1 -0.1 -0.1 1.1 ...
## $ cons.price.idx: num 92.9 94 94.5 94.5 93.2 ...
## $ cons.conf.idx : num -46.2 -36.4 -41.8 -41.8 -42 -37.5 -37.5 -42 -42 -36.4 ...
## $ euribor3m : num 1.31 4.86 4.96 4.96 4.19 ...
## $ nr.employed : num 5099 5191 5228 5228 5196 ...
## $ y : chr "no" "no" "no" "no" ...summary(df)## age job marital education
## Min. :18.00 Length:4119 Length:4119 Length:4119
## 1st Qu.:32.00 Class :character Class :character Class :character
## Median :38.00 Mode :character Mode :character Mode :character
## Mean :40.11
## 3rd Qu.:47.00
## Max. :88.00
## default housing loan
## Length:4119 Length:4119 Length:4119
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
## contact month day_of_week duration
## Length:4119 Length:4119 Length:4119 Min. : 0.0
## Class :character Class :character Class :character 1st Qu.: 103.0
## Mode :character Mode :character Mode :character Median : 181.0
## Mean : 256.8
## 3rd Qu.: 317.0
## Max. :3643.0
## campaign pdays previous poutcome
## Min. : 1.000 Min. : 0.0 Min. :0.0000 Length:4119
## 1st Qu.: 1.000 1st Qu.:999.0 1st Qu.:0.0000 Class :character
## Median : 2.000 Median :999.0 Median :0.0000 Mode :character
## Mean : 2.537 Mean :960.4 Mean :0.1903
## 3rd Qu.: 3.000 3rd Qu.:999.0 3rd Qu.:0.0000
## Max. :35.000 Max. :999.0 Max. :6.0000
## emp.var.rate cons.price.idx cons.conf.idx euribor3m
## Min. :-3.40000 Min. :92.20 Min. :-50.8 Min. :0.635
## 1st Qu.:-1.80000 1st Qu.:93.08 1st Qu.:-42.7 1st Qu.:1.334
## Median : 1.10000 Median :93.75 Median :-41.8 Median :4.857
## Mean : 0.08497 Mean :93.58 Mean :-40.5 Mean :3.621
## 3rd Qu.: 1.40000 3rd Qu.:93.99 3rd Qu.:-36.4 3rd Qu.:4.961
## Max. : 1.40000 Max. :94.77 Max. :-26.9 Max. :5.045
## nr.employed y
## Min. :4964 Length:4119
## 1st Qu.:5099 Class :character
## Median :5191 Mode :character
## Mean :5166
## 3rd Qu.:5228
## Max. :5228sapply(df,class)## age job marital education default
## "integer" "character" "character" "character" "character"
## housing loan contact month day_of_week
## "character" "character" "character" "character" "character"
## duration campaign pdays previous poutcome
## "integer" "integer" "integer" "integer" "character"
## emp.var.rate cons.price.idx cons.conf.idx euribor3m nr.employed
## "numeric" "numeric" "numeric" "numeric" "numeric"
## y
## "character"prop.table(table(df$y))##
## no yes
## 0.8905074 0.1094926Reparto_y <- table(df$y)
anyNA(df,recursive = FALSE) ## [1] FALSElength(which(!complete.cases(df)))## [1] 0Una vez entendido el contexto, trataremos las variables que necesitamos para su correcta ejecución.
#Definicion de las variables del dataset
df$age <- as.numeric(df$age)
df$duration <- as.numeric(df$duration)
df$campaign <- as.numeric(df$campaign)
df$pdays <- as.numeric(df$pdays)
df$previous<- as.numeric(df$previous)
df$emp.var.rate <- as.numeric(df$emp.var.rate)
df$cons.price.idx <- as.numeric(df$cons.price.idx)
df$cons.conf.idx <- as.numeric(df$cons.conf.idx)
df$euribor3m <- as.numeric(df$euribor3m)
df$nr.employed <- as.numeric(df$nr.employed)
df$y <- as.factor(df$y)
summary(df)## age job marital education
## Min. :18.00 Length:4119 Length:4119 Length:4119
## 1st Qu.:32.00 Class :character Class :character Class :character
## Median :38.00 Mode :character Mode :character Mode :character
## Mean :40.11
## 3rd Qu.:47.00
## Max. :88.00
## default housing loan
## Length:4119 Length:4119 Length:4119
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
## contact month day_of_week duration
## Length:4119 Length:4119 Length:4119 Min. : 0.0
## Class :character Class :character Class :character 1st Qu.: 103.0
## Mode :character Mode :character Mode :character Median : 181.0
## Mean : 256.8
## 3rd Qu.: 317.0
## Max. :3643.0
## campaign pdays previous poutcome
## Min. : 1.000 Min. : 0.0 Min. :0.0000 Length:4119
## 1st Qu.: 1.000 1st Qu.:999.0 1st Qu.:0.0000 Class :character
## Median : 2.000 Median :999.0 Median :0.0000 Mode :character
## Mean : 2.537 Mean :960.4 Mean :0.1903
## 3rd Qu.: 3.000 3rd Qu.:999.0 3rd Qu.:0.0000
## Max. :35.000 Max. :999.0 Max. :6.0000
## emp.var.rate cons.price.idx cons.conf.idx euribor3m
## Min. :-3.40000 Min. :92.20 Min. :-50.8 Min. :0.635
## 1st Qu.:-1.80000 1st Qu.:93.08 1st Qu.:-42.7 1st Qu.:1.334
## Median : 1.10000 Median :93.75 Median :-41.8 Median :4.857
## Mean : 0.08497 Mean :93.58 Mean :-40.5 Mean :3.621
## 3rd Qu.: 1.40000 3rd Qu.:93.99 3rd Qu.:-36.4 3rd Qu.:4.961
## Max. : 1.40000 Max. :94.77 Max. :-26.9 Max. :5.045
## nr.employed y
## Min. :4964 no :3668
## 1st Qu.:5099 yes: 451
## Median :5191
## Mean :5166
## 3rd Qu.:5228
## Max. :5228Una vez realizado un primer análisis de la estructura de los datos, llevamos a cabo un análisis visual para facilitar la compresión de los datos. En este punto podemos llevar a cabo una gran variedad de puntos y visualizaciones, desde segmento concretos, bucles y condicionales..etc. En este caso, a modo de muestra simplemente visualizaremos un histograma con la edad respecto al dataset.
Dentro de este punto podemos explorar aspectos como:
- Correlación de edad, estado sentimental y trabajo en la aceptación/no de un depósito.
- Posibilidad de renovación del depósito en base a un histórico anterior
- Número de contactos por qué medio y tasas de éxito (alternativas de mejora del proceso)
hist(df$age, col = "light blue", freq = FALSE, main = "Histograma evolucion edad dataset", xlab = "Edad", ylab = "Densidad")
ggplot(df, aes(x=job, fill = y)) + geom_bar() + ggtitle("Job types vs decision") + xlab("Job Types") + ylab("Densidad") + labs(fill= "y")
ggplot(df,aes(x=age,fill = marital)) + geom_bar() + ggtitle ("Edad y situación sentimental") + xlab("Edad") + ylab("Estado sentimental") + labs(fill="y") 
ggplot(df,aes(x=age,fill = job)) + geom_bar() + ggtitle ("Edad y trabajo") + xlab("Edad") + ylab("Trabajo") + labs(fill="y")
ggplot(df,aes(x=contact,fill = y),stat = "identity") + geom_bar() + ggtitle ("Medio de contacto y Estado actual de depósito") + xlab("Edad") + ylab("Estado actual del depósito")
barplot(Reparto_y, col = "light blue", freq = FALSE, main = "Reparto de estado actual depositos", xlab = "Estado deposito", ylab = "Cantidad")
ggplot (df, aes(x=y, y=age, fill=y))+ geom_boxplot()
Un ejemplo es la posibilidad de calcular o trabajar con preguntas como; ¿Cuál es el canal por el que hemos tenido más éxito? Esto nos capacita para definir acciones de gran valor como mejora del proceso de telemarketing.
df_duracion_medio_exito <- group_by(df,df$contact,df$y)
df_duracion_medio_exito <- summarise(df_duracion_medio_exito,Duration=n())
table(df_duracion_medio_exito$`df$contact`,df_duracion_medio_exito$`df$y`,df_duracion_medio_exito$Duration)## , , = 76
##
##
## no yes
## cellular 0 0
## telephone 0 1
##
## , , = 375
##
##
## no yes
## cellular 0 1
## telephone 0 0
##
## , , = 1391
##
##
## no yes
## cellular 0 0
## telephone 1 0
##
## , , = 2277
##
##
## no yes
## cellular 1 0
## telephone 0 0En este apartado crearemos los dataset de Train y Test para poder realizar posteriormente la predicción necesaria. Vamos a trabajar con un TrainSet de un 75% del actual y un 25% para realizar el testing.
inTrain <- createDataPartition(y=df$y,
p=.75,
list=FALSE)
TrainSet <- df[inTrain,]
TestSet <- df[-inTrain,]
table(TrainSet$y)##
## no yes
## 2751 339table(TestSet$y)##
## no yes
## 917 112Los árboles de clasificación tienen como objetivo crear un modelo que predice el valor de una variable de destino en función de diversas variables de entrada y son una de las técnicas más eficaces de la clasificación supervisada.
Existen diferentes algoritmos que implementan este método entre los más conocidos se encuentran: ID3, C4.5, C5.0, CHAID, MARS o Árboles de Inferencia Condicional.
En este caso emplearemos el algoritmo C5.0.
C50_Model <- C5.0(y~., data = TrainSet)
summary(C50_Model)##
## Call:
## C5.0.formula(formula = y ~ ., data = TrainSet)
##
##
## C5.0 [Release 2.07 GPL Edition] Mon Aug 13 01:45:52 2018
## -------------------------------
##
## Class specified by attribute `outcome'
##
## Read 3090 cases (21 attributes) from undefined.data
##
## Decision tree:
##
## pdays <= 21:
## :...duration > 157: yes (92/24)
## : duration <= 157:
## : :...euribor3m > 0.861: no (15)
## : euribor3m <= 0.861:
## : :...pdays <= 3: yes (4)
## : pdays > 3: no (5/1)
## pdays > 21:
## :...duration > 478:
## :...duration <= 820:
## : :...nr.employed > 5076.2: no (244/58)
## : : nr.employed <= 5076.2:
## : : :...loan in {no,unknown}: yes (21/3)
## : : loan = yes:
## : : :...poutcome = nonexistent: yes (1)
## : : poutcome in {failure,success}: no (3)
## : duration > 820:
## : :...cons.conf.idx <= -42.7: yes (53/12)
## : cons.conf.idx > -42.7:
## : :...default = yes: no (0)
## : default = unknown:
## : :...age <= 37: no (2)
## : : age > 37: yes (7)
## : default = no:
## : :...job in {services,self-employed,technician,management,
## : : student,housemaid,unemployed,unknown}: no (23/6)
## : job = admin.:
## : :...emp.var.rate <= -0.1: no (3)
## : : emp.var.rate > -0.1: yes (11/3)
## : job = entrepreneur:
## : :...age <= 40: no (2)
## : : age > 40: yes (3)
## : job = blue-collar:
## : :...campaign <= 1: yes (2)
## : : campaign > 1: no (4)
## : job = retired:
## : :...age <= 64: no (2)
## : age > 64: yes (3)
## duration <= 478:
## :...month in {sep,mar,oct,dec}:
## :...duration <= 114: no (29/2)
## : duration > 114:
## : :...marital = unknown: yes (0)
## : marital = divorced: no (3)
## : marital = single:
## : :...age <= 39: yes (28/6)
## : : age > 39: no (4)
## : marital = married:
## : :...day_of_week in {fri,mon,tue,thu}: no (37/12)
## : day_of_week = wed: yes (6)
## month in {may,jun,nov,jul,aug,apr}:
## :...nr.employed > 5076.2: no (2316/31)
## nr.employed <= 5076.2:
## :...duration <= 174:
## :...default in {no,yes}: no (72/4)
## : default = unknown: yes (3/1)
## duration > 174:
## :...default in {unknown,yes}: no (4)
## default = no:
## :...poutcome = success: no (0)
## poutcome = nonexistent:
## :...emp.var.rate <= -2.9: no (39/16)
## : emp.var.rate > -2.9: yes (20/5)
## poutcome = failure:
## :...campaign <= 1: no (14/1)
## campaign > 1:
## :...day_of_week in {fri,tue,thu}: yes (9/2)
## day_of_week in {wed,mon}: no (6/1)
##
##
## Evaluation on training data (3090 cases):
##
## Decision Tree
## ----------------
## Size Errors
##
## 35 188( 6.1%) <<
##
##
## (a) (b) <-classified as
## ---- ----
## 2695 56 (a): class no
## 132 207 (b): class yes
##
##
## Attribute usage:
##
## 100.00% duration
## 100.00% pdays
## 89.06% nr.employed
## 83.82% month
## 7.41% default
## 3.72% cons.conf.idx
## 2.98% poutcome
## 2.52% marital
## 2.36% emp.var.rate
## 1.88% day_of_week
## 1.72% job
## 1.65% age
## 1.13% campaign
## 0.81% loan
## 0.78% euribor3m
##
##
## Time: 0.0 secspredictionC50 <- predict(C50_Model,TestSet)
summary(predictionC50)## no yes
## 952 77plot(predictionC50)
postResample(predictionC50,TestSet$y)## Accuracy Kappa
## 0.9057337 0.4368261graficoversus <- table(predictionC50,TestSet$y)
barplot(graficoversus,main="Estado actual de los depositos vs Prediccion",
xlab="Respuesta", col=c("darkblue","red"),
legend = rownames(graficoversus), beside=TRUE)
Algunos aspectos interesantes que podemos valorar:
*El error de algortimo implementado es de un 6,6% en la clasificación de datos
*Nos devuelve una predicción de 935 respuestas negativas y 94 positivas de suscripción al depósito de un total de 1029 personas
*Tenemos un modelo con una fiabilidad de 90,6%
*Nuestro valor Kappa es de 0,48. Un valor aceptable. Kappa es la representación de la azarabilidad de los resultados, en este caso que Kappa = 1,significa que existe concordancia perfecta.El manual AIAG1 sugiere que un valor de kappa de al menos 0.75 indica una concordancia adecuada.
*En la matriz generada podemos apreciar 878 personas que verdaderamente no renovarán su suscripción al depósito (True Positives), 55 personas que si que renovaran la suscripción (True Negatives),57 personas especifican que sí renovarán pero finalmente no lo harán (False Positives) y 39 personas específican que no renovarán pero finalmente lo harán (False Negatives).confusion_matrix <- prop.table(table(predictionC50, TestSet$y))
plot(confusion_matrix)
summary(confusion_matrix)## Number of cases in table: 1
## Number of factors: 2
## Test for independence of all factors:
## Chisq = 0.19904, df = 1, p-value = 0.6555
## Chi-squared approximation may be incorrectaccuracy <- confusion_matrix[1,1] + confusion_matrix[2,2]Finalmente, podremos valorar los porcentajes de accucary con los que se expone nuestra matriz de confusión.
5 Conclusiones
Hemos trabajara de manera general este dataset a modo de ejemplo. Pero podemos definir los siguientes output:
Hemos cumplido el objetivo planteado inicialmente; “La clasificación es predecir si el cliente suscribirá (sí / no) un depósito a plazo (variable y)”
Siendo más precisos deberíamos segmentar por múltiples variables y personalizar planes de acciones para cada cliente tipo.La decisión de una renovación de un depósito a plazo variable es compleja. Todos los factores del proceso de contacto con el cliente afectan, desde el contacto, medio hasta la situación económica de la persona.
¿Podemos ofrecer facilidades para sus suscripción?¿Es parte activa de nuestro banco (ingresos, cuentas..etc)? Alternativas de packs de productos personalizados son recurrentes.
Por otro lado, una de las fases más importantes es la inicial. ¿A través de qué medio contactamos con ellos?¿Qué porcentaje de éxito estamos teniendo? ¿El contacto point to point está siendo el correcto o podemos mejorar aspectos del discurso o la forma de abordarlo?
El algoritmo nos ofrece una fiabilidad de un 90% en cuanto a la clasificación de los resultados por lo que podemos fiarnos de ellos. Aun así deberíamos seguir mejorando nuestro dataset para conseguir una fiabilidad mayor. Todo ello se consigue con una limpieza y segmentación más específica de los datos.