R Notebook
T########################################################################### # Handout 2 # # Machin Learning and Public Policy # # Universidad de los Andes # # 2018 # ########################################################################### #Name: Lukas Sanz Ramirez #Code: 201529628 ############################################################################ # ¿Qué puede decir acerca de la solvencia de los clientes a partir de los # # datos de uso del teléfono disponibles? ¿Qué sugiere su análisis mediante # # herramientas de aprendizaje automático sobre el diseño de productos para # # la inclusión financiera de los pobres? Su análisis debe mostrar # #claramente que tiene # ############################################################################ #instalar paquetes install.packages(c(“ggplot2”,“rpart”, “rpart.plot”, “MASS”, “randomForest”, “tree”,“glmnet”,“dummies”,“Mlmetrics”,“dplyr”,“arules”, “factoextra”, “NbClust”))
fije un directorio
setwd("~/handout")cargue la base de datos
base<-read.csv("~/handout/momo_z.csv")
dt <- read.csv("~/handout/momo_z.csv")explore los datos disponibles
library("ggplot2")
summary(dt)## send_amt send_qty send_dgr received_amt
## Min. :-0.33732 Min. :-0.6407 Min. :-0.7832 Min. :-0.42023
## 1st Qu.:-0.29962 1st Qu.:-0.5012 1st Qu.:-0.5143 1st Qu.:-0.35224
## Median :-0.23625 Median :-0.3020 Median :-0.2992 Median :-0.25383
## Mean : 0.00000 Mean : 0.0000 Mean : 0.0000 Mean : 0.00000
## 3rd Qu.:-0.06165 3rd Qu.: 0.0765 3rd Qu.: 0.1848 3rd Qu.:-0.02446
## Max. :41.58243 Max. :23.3243 Max. :29.5477 Max. :36.13196
## received_qty received_dgr deposit_amt deposit_qty
## Min. :-0.8062 Min. :-0.9927 Min. :-0.33486 Min. :-0.7089
## 1st Qu.:-0.5568 1st Qu.:-0.6120 1st Qu.:-0.28696 1st Qu.:-0.5043
## Median :-0.2717 Median :-0.2313 Median :-0.21928 Median :-0.2705
## Mean : 0.0000 Mean : 0.0000 Mean : 0.00000 Mean : 0.0000
## 3rd Qu.: 0.2271 3rd Qu.: 0.2445 3rd Qu.:-0.05462 3rd Qu.: 0.1094
## Max. :58.5592 Max. :38.8827 Max. :39.80240 Max. :28.5453
## deposity_dgr withdraw_amt withdraw_qty withdraw_dgr
## Min. :-1.1330 Min. :-0.35510 Min. :-0.8215 Min. :-0.9545
## 1st Qu.:-0.6693 1st Qu.:-0.31032 1st Qu.:-0.6443 1st Qu.:-0.6758
## Median :-0.3216 Median :-0.22060 Median :-0.2901 Median :-0.2577
## Mean : 0.0000 Mean : 0.00000 Mean : 0.0000 Mean : 0.0000
## 3rd Qu.: 0.2580 3rd Qu.:-0.01633 3rd Qu.: 0.2413 3rd Qu.: 0.2997
## Max. :11.3854 Max. :36.88574 Max. :18.7217 Max. :16.0477
## bill_amt bill_qty bill_dgr
## Min. : -0.00724 Min. :-0.32578 Min. :-0.3679
## 1st Qu.: -0.00724 1st Qu.:-0.32578 1st Qu.:-0.3679
## Median : -0.00724 Median :-0.32578 Median :-0.3679
## Mean : 0.00000 Mean : 0.00000 Mean : 0.0000
## 3rd Qu.: -0.00642 3rd Qu.:-0.06983 3rd Qu.:-0.3679
## Max. :223.46174 Max. :50.47888 Max. :12.6897
## airtime topup days_no_balance age
## Min. :-1.1974 Min. :-1.3327 Min. :-2.10806 Min. :-1.5562
## 1st Qu.:-0.6405 1st Qu.:-0.6615 1st Qu.:-0.81861 1st Qu.:-0.7743
## Median :-0.2901 Median :-0.2900 Median : 0.07612 Median :-0.1905
## Mean : 0.0000 Mean : 0.0000 Mean : 0.00000 Mean : 0.0000
## 3rd Qu.: 0.3078 3rd Qu.: 0.3510 3rd Qu.: 0.78663 3rd Qu.: 0.5648
## Max. :12.4662 Max. :11.5195 Max. : 2.47082 Max. : 7.1109
## gender default
## FEMALE:16288 Default:11999
## MALE :33331 Paid :38001
## OTHER : 381
##
##
## head(dt)str(dt)## 'data.frame': 50000 obs. of 21 variables:
## $ send_amt : num -0.276 -0.204 -0.122 0.499 0.794 ...
## $ send_qty : num -0.282 -0.302 -0.143 0.176 1.192 ...
## $ send_dgr : num -0.192 -0.138 0.131 0.346 1.422 ...
## $ received_amt : num -0.219 -0.24 -0.354 0.384 0.443 ...
## $ received_qty : num -0.1648 -0.3074 -0.5568 -0.0579 -0.0223 ...
## $ received_dgr : num -0.136 -0.422 -0.422 -0.231 -0.136 ...
## $ deposit_amt : num -0.3002 -0.1736 0.0129 0.1834 0.4428 ...
## $ deposit_qty : num -0.475 -0.271 0.139 -0.329 0.197 ...
## $ deposity_dgr : num -0.5534 -0.5534 0.0261 -0.4375 0.6057 ...
## $ withdraw_amt : num -0.0786 -0.1621 -0.2749 0.3322 -0.2621 ...
## $ withdraw_qty : num 0.123 -0.349 -0.585 0.123 -0.644 ...
## $ withdraw_dgr : num 0.3 -0.258 -0.815 0.3 -0.676 ...
## $ bill_amt : num -0.007237 -0.002772 0.000621 0.005557 0.006142 ...
## $ bill_qty : num -0.326 0.442 1.21 1.21 0.698 ...
## $ bill_dgr : num -0.368 3.549 3.549 6.161 2.244 ...
## $ airtime : num -0.4 0.248 0.567 3.86 0.433 ...
## $ topup : num -0.275 0.692 0.978 -1.333 -0.243 ...
## $ days_no_balance: num -0.398 -1.582 -1.766 -2.108 -1.476 ...
## $ age : num -0.711 -0.323 0.337 -0.408 0.365 ...
## $ gender : Factor w/ 3 levels "FEMALE","MALE",..: 1 1 2 2 2 2 1 1 1 2 ...
## $ default : Factor w/ 2 levels "Default","Paid": 2 2 2 2 2 2 2 2 2 2 ...table(dt$gender) ##
## FEMALE MALE OTHER
## 16288 33331 381prop.table(table(dt$gender))##
## FEMALE MALE OTHER
## 0.32576 0.66662 0.00762Como se observó en las tablas presentadas arriba el 66% de la poblacion son de género masculino, el 32% de genero femenino y el 0,7% de la población se consideran de otro genero. Por otra parte como se puede ver mas adelante el 76% de la población total pagan sus deudas relacionadas con créditos de las plataformas de dinero móvil, por otra parte el grueso de la población se encuentra entre las -1.9 y 1.9 deviaciones estándar de la media como se muestra el histograma de frecuencia presentado a continuación.prop.table(table(dt$default))##
## Default Paid
## 0.23998 0.76002barplot(table(dt$default), col=heat.colors(2))
title("Estado de pago de creditos mobiles")
hist(dt$age, main="Histograma de la Edad", xlab="Edad")
library(scatterplot3d)
scatterplot3d(dt$age,dt$default,dt$airtime,color=(3))
names(dt)## [1] "send_amt" "send_qty" "send_dgr"
## [4] "received_amt" "received_qty" "received_dgr"
## [7] "deposit_amt" "deposit_qty" "deposity_dgr"
## [10] "withdraw_amt" "withdraw_qty" "withdraw_dgr"
## [13] "bill_amt" "bill_qty" "bill_dgr"
## [16] "airtime" "topup" "days_no_balance"
## [19] "age" "gender" "default"scatterplot3d(dt$send_amt,dt$default,dt$received_amt,color=(3))
Por otra parte parece existir una relación positiva entre la proporción de personas que pagan sus créditos otorgados por las plataformas móviles y el tiempo que pasan usando sus teléfonos, de manera analoga aquellas personas que envían y reciben dinero por encima del promedio tienden a pagar sus deudas móviles. Por el contrario aquellas personas que envían y reciben menos dinero por medio de sus celulares tienden a no estar al día en sus deudas móviles.
Construyendo variables dummies
library(dummies)## dummies-1.5.6 provided by Decision Patternsdt = dummy.data.frame(dt)
dt <-dt[ ,!colnames(dt)=="defaultDefault"]
str(dt)## 'data.frame': 50000 obs. of 23 variables:
## $ send_amt : num -0.276 -0.204 -0.122 0.499 0.794 ...
## $ send_qty : num -0.282 -0.302 -0.143 0.176 1.192 ...
## $ send_dgr : num -0.192 -0.138 0.131 0.346 1.422 ...
## $ received_amt : num -0.219 -0.24 -0.354 0.384 0.443 ...
## $ received_qty : num -0.1648 -0.3074 -0.5568 -0.0579 -0.0223 ...
## $ received_dgr : num -0.136 -0.422 -0.422 -0.231 -0.136 ...
## $ deposit_amt : num -0.3002 -0.1736 0.0129 0.1834 0.4428 ...
## $ deposit_qty : num -0.475 -0.271 0.139 -0.329 0.197 ...
## $ deposity_dgr : num -0.5534 -0.5534 0.0261 -0.4375 0.6057 ...
## $ withdraw_amt : num -0.0786 -0.1621 -0.2749 0.3322 -0.2621 ...
## $ withdraw_qty : num 0.123 -0.349 -0.585 0.123 -0.644 ...
## $ withdraw_dgr : num 0.3 -0.258 -0.815 0.3 -0.676 ...
## $ bill_amt : num -0.007237 -0.002772 0.000621 0.005557 0.006142 ...
## $ bill_qty : num -0.326 0.442 1.21 1.21 0.698 ...
## $ bill_dgr : num -0.368 3.549 3.549 6.161 2.244 ...
## $ airtime : num -0.4 0.248 0.567 3.86 0.433 ...
## $ topup : num -0.275 0.692 0.978 -1.333 -0.243 ...
## $ days_no_balance: num -0.398 -1.582 -1.766 -2.108 -1.476 ...
## $ age : num -0.711 -0.323 0.337 -0.408 0.365 ...
## $ genderFEMALE : int 1 1 0 0 0 0 1 1 1 0 ...
## $ genderMALE : int 0 0 1 1 1 1 0 0 0 1 ...
## $ genderOTHER : int 0 0 0 0 0 0 0 0 0 0 ...
## $ defaultPaid : int 1 1 1 1 1 1 1 1 1 1 ...clustering
install.packages(c(“arules”, “factoextra”, “NbClust”))
library("ggplot2")
library("factoextra")## Welcome! Related Books: `Practical Guide To Cluster Analysis in R` at https://goo.gl/13EFCZset.seed(123)
grupos <- kmeans(dt,centers=4)
dt$clusters=grupos$cluster
fviz_cluster(grupos, data = dt,
palette = c("#00AFBB","#2E9FDF", "#E7B800", "#FC4E07"),
main = "Partitioning Clustering Plot")
# Initialize total within sum of squares error: wss
wss <- 0For 1 to 15 cluster centers
for (i in 1:15) {
grupos.out <- kmeans(scale(dt), centers = i, nstart = 20)
# Save total within sum of squares to wss variable
wss[i] <- grupos.out$tot.withinss
}## Warning: Quick-TRANSfer stage steps exceeded maximum (= 2500000)## Warning: did not converge in 10 iterations## Warning: Quick-TRANSfer stage steps exceeded maximum (= 2500000)## Warning: did not converge in 10 iterations## Warning: Quick-TRANSfer stage steps exceeded maximum (= 2500000)## Warning: did not converge in 10 iterations
## Warning: did not converge in 10 iterations
## Warning: did not converge in 10 iterations
## Warning: did not converge in 10 iterations
## Warning: did not converge in 10 iterations
## Warning: did not converge in 10 iterationsplot(1:15, wss, type = "b",
xlab = "Number of Clusters",
ylab = "Within groups sum of squares")
grupos.best <- kmeans(dt,centers=7)
dt$clusters=grupos.best$cluster
fviz_cluster(grupos.best, data = dt,
palette = c("#00AFBB","#2E9FDF", "#E7B800", "#FC4E07","#006633","#330066","#0000c1"),
main = "Partitioning Clustering Plot"
) 
barplot(table(grupos.best$cluster), col=heat.colors(7))
dt$clusters=as.factor(dt$clusters)
dt = dummy.data.frame(dt)
str(dt)## 'data.frame': 50000 obs. of 30 variables:
## $ send_amt : num -0.276 -0.204 -0.122 0.499 0.794 ...
## $ send_qty : num -0.282 -0.302 -0.143 0.176 1.192 ...
## $ send_dgr : num -0.192 -0.138 0.131 0.346 1.422 ...
## $ received_amt : num -0.219 -0.24 -0.354 0.384 0.443 ...
## $ received_qty : num -0.1648 -0.3074 -0.5568 -0.0579 -0.0223 ...
## $ received_dgr : num -0.136 -0.422 -0.422 -0.231 -0.136 ...
## $ deposit_amt : num -0.3002 -0.1736 0.0129 0.1834 0.4428 ...
## $ deposit_qty : num -0.475 -0.271 0.139 -0.329 0.197 ...
## $ deposity_dgr : num -0.5534 -0.5534 0.0261 -0.4375 0.6057 ...
## $ withdraw_amt : num -0.0786 -0.1621 -0.2749 0.3322 -0.2621 ...
## $ withdraw_qty : num 0.123 -0.349 -0.585 0.123 -0.644 ...
## $ withdraw_dgr : num 0.3 -0.258 -0.815 0.3 -0.676 ...
## $ bill_amt : num -0.007237 -0.002772 0.000621 0.005557 0.006142 ...
## $ bill_qty : num -0.326 0.442 1.21 1.21 0.698 ...
## $ bill_dgr : num -0.368 3.549 3.549 6.161 2.244 ...
## $ airtime : num -0.4 0.248 0.567 3.86 0.433 ...
## $ topup : num -0.275 0.692 0.978 -1.333 -0.243 ...
## $ days_no_balance: num -0.398 -1.582 -1.766 -2.108 -1.476 ...
## $ age : num -0.711 -0.323 0.337 -0.408 0.365 ...
## $ genderFEMALE : int 1 1 0 0 0 0 1 1 1 0 ...
## $ genderMALE : int 0 0 1 1 1 1 0 0 0 1 ...
## $ genderOTHER : int 0 0 0 0 0 0 0 0 0 0 ...
## $ defaultPaid : int 1 1 1 1 1 1 1 1 1 1 ...
## $ clusters1 : int 0 0 0 0 0 0 0 0 0 0 ...
## $ clusters2 : int 0 0 0 0 0 0 0 0 0 0 ...
## $ clusters3 : int 0 0 0 0 0 0 0 0 0 0 ...
## $ clusters4 : int 0 0 0 0 0 1 0 0 0 0 ...
## $ clusters5 : int 0 1 1 1 1 0 0 0 0 1 ...
## $ clusters6 : int 0 0 0 0 0 0 0 0 0 0 ...
## $ clusters7 : int 1 0 0 0 0 0 1 1 1 0 ...
## - attr(*, "dummies")=List of 1
## ..$ clusters: int 24 25 26 27 28 29 30Enmarque el problema de la política como un problema de aprendizaje automático
Como se pudo observar anteriormente las variables relacionadas con las interacciones económicas en marco de la plataformas móviles capturan en cierta medida la riqueza y la capacidad de pago de la personas en la economía de una nación, de esta manera aquella porción de la población más pobre si bien no cuenta con activos que puedan ofertar como hipoteca o respaldo a la hora de solicitar un producto financiero, estas cuentan con un historial de transacciones económicas bajo el uso de plataformas móviles de intercambio de dinero y comunicaciones.
En ese orden de ideas, el uso de esta información puede ser de gran ayuda para el diseño de políticas públicas que busquen garantizar el acceso al crédito de aquellas poblaciones más pobres, reduciendo el riesgo que asumen las entidades financieras de perder sus recursos fruto del no pago de los créditos otorgados a este tipo de clientes sin respaldo económico en activos físicos.
Así las cosas, el emprender un programa de acceso al crédito para las poblaciones más pobres podrá permitir a estos hogares superar las barreras sociales que les impiden salir de la su estado de pobreza o incluso pobreza extrema.
Identifique las técnicas de maquinas de aprendizaje más relevantes para el problema en cuestión
Habiendo dicho lo anterior resulta relevante predecir con efectividad cuales de estas personas tienen una mayor probabilidad de pago con base a la información disponible de sus transacciones realizadas mediante el uso de la plataforma dinero móvil controlando por su edad y género, adicionalmente se tienen en cuenta luego de la implementación del algoritmo de k-medias el pertenecer a uno de los clúster asociados con el fin de controlar los modelos por aquellas variables que son comunes entre individuos y no se encuentran disponibles en la base de datos inicial.
Así mismo, se presentaran algunos modelos a ser tenidos en cuenta para la predicción de pago de la población con base en los datos disponibles en la base de datos de la plataforma dinero móvil
contruyendo las muestras para nuestro ejercicio de maquinas de aprendizaje
base<-base[,-22]
id=sample(1:nrow(dt),size=nrow(dt)*0.7)
train=dt[id,] #Selecciona el 70% de las filas
test=dt[-id,] #Selecciona el 30% restante de filas
names(train)## [1] "send_amt" "send_qty" "send_dgr"
## [4] "received_amt" "received_qty" "received_dgr"
## [7] "deposit_amt" "deposit_qty" "deposity_dgr"
## [10] "withdraw_amt" "withdraw_qty" "withdraw_dgr"
## [13] "bill_amt" "bill_qty" "bill_dgr"
## [16] "airtime" "topup" "days_no_balance"
## [19] "age" "genderFEMALE" "genderMALE"
## [22] "genderOTHER" "defaultPaid" "clusters1"
## [25] "clusters2" "clusters3" "clusters4"
## [28] "clusters5" "clusters6" "clusters7"x_train= data.matrix(train[, -23]) # Variables indep de base de entrenamiento.
x_test= data.matrix(test[, -23]) # Variables indep de la base de prueba
y_train = train$defaultPaid # Variable dependiente
y_test = test$defaultPaid # Variable dependiente
id=sample(1:nrow(base),size=nrow(base)*0.7)
trainb=base[id,] #Selecciona el 70% de las filas
testb=base[-id,] #Selecciona el 30% restante de filas
names(trainb)## [1] "send_amt" "send_qty" "send_dgr"
## [4] "received_amt" "received_qty" "received_dgr"
## [7] "deposit_amt" "deposit_qty" "deposity_dgr"
## [10] "withdraw_amt" "withdraw_qty" "withdraw_dgr"
## [13] "bill_amt" "bill_qty" "bill_dgr"
## [16] "airtime" "topup" "days_no_balance"
## [19] "age" "gender" "default"pensando el modelo lineal
Partiendo del modelo mas sencillo a continuacion se estima un modelo minimos cuadrados ponderados. #Ordinary least scuares
lm.fit=lm(y_train~x_train, data=train) #Regresion Simple
step= step(lm.fit, direction="both") # Stepwise## Start: AIC=-61621.47
## y_train ~ x_train
##
## Df Sum of Sq RSS AIC
## <none> 6008.3 -61621
## - x_train 27 348.63 6356.9 -59701back= step(lm.fit, direction = "backward", trace=FALSE) # Backward
forw= step(lm.fit, direction="forward", trace=FALSE) #Forward
summary(step)##
## Call:
## lm(formula = y_train ~ x_train, data = train)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.20480 0.00493 0.18834 0.26898 1.10488
##
## Coefficients: (2 not defined because of singularities)
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.7531270 0.0291442 25.841 < 2e-16 ***
## x_trainsend_amt 0.0162062 0.0062067 2.611 0.009030 **
## x_trainsend_qty 0.0115846 0.0082078 1.411 0.158134
## x_trainsend_dgr 0.0169251 0.0059098 2.864 0.004187 **
## x_trainreceived_amt 0.0049387 0.0058237 0.848 0.396430
## x_trainreceived_qty -0.0565386 0.0058556 -9.656 < 2e-16 ***
## x_trainreceived_dgr 0.0348800 0.0049636 7.027 2.15e-12 ***
## x_traindeposit_amt 0.0003401 0.0050867 0.067 0.946695
## x_traindeposit_qty 0.0018918 0.0048382 0.391 0.695788
## x_traindeposity_dgr -0.0254079 0.0038724 -6.561 5.41e-11 ***
## x_trainwithdraw_amt 0.0077656 0.0046912 1.655 0.097859 .
## x_trainwithdraw_qty 0.0173480 0.0058887 2.946 0.003221 **
## x_trainwithdraw_dgr 0.0539351 0.0049412 10.915 < 2e-16 ***
## x_trainbill_amt 0.0051375 0.0808885 0.064 0.949358
## x_trainbill_qty 0.0094925 0.0033985 2.793 0.005223 **
## x_trainbill_dgr 0.0104923 0.0031862 3.293 0.000992 ***
## x_trainairtime -0.0240480 0.0100846 -2.385 0.017102 *
## x_traintopup -0.0419827 0.0080457 -5.218 1.82e-07 ***
## x_traindays_no_balance -0.0501650 0.0028406 -17.660 < 2e-16 ***
## x_trainage 0.0149660 0.0029820 5.019 5.23e-07 ***
## x_traingenderFEMALE 0.0373395 0.0287633 1.298 0.194240
## x_traingenderMALE -0.0164205 0.0283253 -0.580 0.562113
## x_traingenderOTHER NA NA NA NA
## x_trainclusters1 0.0293019 0.0109905 2.666 0.007677 **
## x_trainclusters2 -0.0035978 0.0097006 -0.371 0.710728
## x_trainclusters3 -0.0181470 0.0114630 -1.583 0.113409
## x_trainclusters4 0.0018604 0.0182419 0.102 0.918770
## x_trainclusters5 0.0364394 0.0111459 3.269 0.001079 **
## x_trainclusters6 -0.0813771 0.0422379 -1.927 0.054033 .
## x_trainclusters7 NA NA NA NA
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.4145 on 34972 degrees of freedom
## Multiple R-squared: 0.05484, Adjusted R-squared: 0.05411
## F-statistic: 75.16 on 27 and 34972 DF, p-value: < 2.2e-16plm= predict(lm.fit, test)## Warning: 'newdata' had 15000 rows but variables found have 35000 rows## Warning in predict.lm(lm.fit, test): prediction from a rank-deficient fit
## may be misleadingplm_step= predict(step, test)## Warning: 'newdata' had 15000 rows but variables found have 35000 rows## Warning in predict.lm(step, test): prediction from a rank-deficient fit may
## be misleadingplm_back= predict(back, test)## Warning: 'newdata' had 15000 rows but variables found have 35000 rows## Warning in predict.lm(back, test): prediction from a rank-deficient fit may
## be misleadingplm_forw= predict(forw, test)## Warning: 'newdata' had 15000 rows but variables found have 35000 rows## Warning in predict.lm(forw, test): prediction from a rank-deficient fit may
## be misleadingComo se puede se puede observar para un nivel de confianza del 95% las variables clúster 6 y 1, edad, tiempo al aire, el pago de facturas, el dinero retirado, enviado y recibido tienen un efecto positivo en la probabilidad de pago de las personas en la economía. Con el fin de reducir la sobre especificación del modelo, a continuación se presentan los modelos de Ridge y Lasso de penalización para identificar las variables más importantes para construir un modelo adecuado de predicción #Ridge
library(glmnet)## Loading required package: Matrix## Loading required package: foreach## Loaded glmnet 2.0-16grilla=seq(from=0.0001, to=5,length=1000)
set.seed(123)
ridge= cv.glmnet(x_train, y_train, alpha=0, family="gaussian" ,
type.measure = "mse", nfold=5, lambda = grilla)
coef(ridge)## 30 x 1 sparse Matrix of class "dgCMatrix"
## 1
## (Intercept) 0.7677255236
## send_amt 0.0067697274
## send_qty 0.0052579818
## send_dgr 0.0115970852
## received_amt 0.0004835315
## received_qty -0.0162488223
## received_dgr 0.0068961409
## deposit_amt 0.0031658112
## deposit_qty 0.0027538661
## deposity_dgr -0.0116762885
## withdraw_amt 0.0058063155
## withdraw_qty 0.0148602521
## withdraw_dgr 0.0306752865
## bill_amt 0.0152482381
## bill_qty 0.0064987900
## bill_dgr 0.0115182034
## airtime -0.0197204459
## topup -0.0307443649
## days_no_balance -0.0386394376
## age 0.0139171543
## genderFEMALE 0.0176185874
## genderMALE -0.0171431861
## genderOTHER -0.0051883654
## clusters1 0.0223030761
## clusters2 -0.0218981469
## clusters3 -0.0063064138
## clusters4 0.0066140496
## clusters5 0.0186422549
## clusters6 -0.0291766367
## clusters7 -0.0037529626ridge$lambda.min # lambda con el minimo error de validación cruzada## [1] 0.005104905plot(ridge) # Resultados de la validación
pridge= predict(ridge, newx=x_test, s="lambda.min") #Predecir con el lambda de minimo errorLasso
install.packages(“ROCR”)
library(ROCR)## Loading required package: gplots##
## Attaching package: 'gplots'## The following object is masked from 'package:stats':
##
## lowessset.seed(123)
lasso= cv.glmnet(x_train, y_train, alpha=1, family="gaussian" ,
type.measure = "mse", nfold=5, lambda=grilla)
coef(lasso)## 30 x 1 sparse Matrix of class "dgCMatrix"
## 1
## (Intercept) 7.900916e-01
## send_amt 1.594543e-02
## send_qty 1.200933e-02
## send_dgr 1.635478e-02
## received_amt 3.856306e-03
## received_qty -5.504031e-02
## received_dgr 3.387924e-02
## deposit_amt 2.694812e-05
## deposit_qty 1.832729e-03
## deposity_dgr -2.523571e-02
## withdraw_amt 8.115575e-03
## withdraw_qty 1.663505e-02
## withdraw_dgr 5.395641e-02
## bill_amt 2.398800e-03
## bill_qty 9.425810e-03
## bill_dgr 1.053563e-02
## airtime -2.229458e-02
## topup -4.306817e-02
## days_no_balance -5.000728e-02
## age 1.498047e-02
## genderFEMALE 1.315084e-04
## genderMALE -5.286332e-02
## genderOTHER -3.418072e-02
## clusters1 2.865279e-02
## clusters2 -4.145922e-03
## clusters3 -1.774200e-02
## clusters4 1.651621e-03
## clusters5 3.571473e-02
## clusters6 -7.751759e-02
## clusters7 .lasso$lambda.min## [1] 1e-04plot(lasso)
plasso= predict(lasso, newx=x_test, s="lambda.min")
classo= glmnet(x_train, y_train, alpha=1)
plot(classo,xvar="lambda",label=TRUE)
predr4 <- prediction(plasso, test$defaultPaid)
perf4 <- performance(predr4, measure = "tpr", x.measure = "fpr")
plot(perf4,col=rainbow(3), main="ROC curve defaultPaid", xlab="Specificity",
ylab="Sensitivity")
abline(0, 1) 
Luego de correr los modelo de penalización se encuentra que la variable relacionada con pertenecer al clúster 7 deja de ser importante para predecir la probabilidad de pago. Por otra parte la cantidad de dinero recibido deja de ser una variable positiva sobre la probabilidad de pago.
A continuación se presentan las versiones de los modelos anteriores a manera de un modelo logit con el fin de estimar el mejor modelo posible dados los supuestos sobre la distribución de los modelos binomiales de regresión. #viendo el modelo comoun logit #logit
glm.fit=glm(y_test ~x_test, data=train, family=binomial(link = "logit")) #logit## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredstep= step(glm.fit, direction="both") # Stepwise## Start: AIC=15785.75
## y_test ~ x_test
##
## Df Deviance AIC
## <none> 15730 15786
## - x_test 27 16649 16651back= step(glm.fit, direction = "backward", trace=FALSE) # Backward
forw= step(glm.fit, direction="forward", trace=FALSE) #Forward
summary(step)##
## Call:
## glm(formula = y_test ~ x_test, family = binomial(link = "logit"),
## data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -3.0412 0.2390 0.6273 0.7823 2.7037
##
## Coefficients: (2 not defined because of singularities)
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.61038 0.35848 4.492 7.05e-06 ***
## x_testsend_amt 0.62044 0.13968 4.442 8.92e-06 ***
## x_testsend_qty -0.14494 0.09458 -1.532 0.125407
## x_testsend_dgr 0.35480 0.08848 4.010 6.07e-05 ***
## x_testreceived_amt -0.21695 0.09595 -2.261 0.023750 *
## x_testreceived_qty -0.30375 0.06878 -4.416 1.01e-05 ***
## x_testreceived_dgr 0.17558 0.05046 3.479 0.000503 ***
## x_testdeposit_amt -0.40780 0.13265 -3.074 0.002111 **
## x_testdeposit_qty 0.19476 0.06094 3.196 0.001395 **
## x_testdeposity_dgr -0.20193 0.03805 -5.307 1.11e-07 ***
## x_testwithdraw_amt 0.25315 0.08576 2.952 0.003160 **
## x_testwithdraw_qty 0.13961 0.06872 2.032 0.042195 *
## x_testwithdraw_dgr 0.34853 0.05125 6.800 1.04e-11 ***
## x_testbill_amt 3.94500 2.29878 1.716 0.086139 .
## x_testbill_qty 0.06631 0.03988 1.663 0.096399 .
## x_testbill_dgr 0.07692 0.03393 2.267 0.023397 *
## x_testairtime -0.20722 0.09657 -2.146 0.031885 *
## x_testtopup -0.16918 0.07460 -2.268 0.023344 *
## x_testdays_no_balance -0.32293 0.02595 -12.444 < 2e-16 ***
## x_testage 0.10767 0.02780 3.873 0.000107 ***
## x_testgenderFEMALE -0.06782 0.35725 -0.190 0.849425
## x_testgenderMALE -0.32454 0.35355 -0.918 0.358655
## x_testgenderOTHER NA NA NA NA
## x_testclusters1 0.03716 0.10375 0.358 0.720209
## x_testclusters2 -0.03149 0.08818 -0.357 0.720973
## x_testclusters3 -0.42117 0.10908 -3.861 0.000113 ***
## x_testclusters4 -0.40064 0.18269 -2.193 0.028311 *
## x_testclusters5 -0.05745 0.10315 -0.557 0.577581
## x_testclusters6 -0.95530 0.48849 -1.956 0.050511 .
## x_testclusters7 NA NA NA NA
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 16649 on 14999 degrees of freedom
## Residual deviance: 15730 on 14972 degrees of freedom
## AIC: 15786
##
## Number of Fisher Scoring iterations: 10plmlog= predict(glm.fit, test)## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleadingplm_steplog= predict(step, test)## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleadingplm_backlog= predict(back, test)## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleadingplm_forwlog= predict(forw, test)## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleadinglibrary("ROCR")
predr3 <- prediction(plmlog, test$defaultPaid)
perf3 <- performance(predr3, measure = "tpr", x.measure = "fpr")
plot(perf3, col=rainbow(7), main="ROC curve defaultPaid", xlab="Specificity",
ylab="Sensitivity")
abline(0, 1) 
Así mismo, como en el modelo de regresión lineal las variables relacionadas con el envío, la recepción y la conversión de dinero vía plataforma movil, y aquellas variables relacionadas con el pago de facturas, tiempo al aire, días de mora y edad; son estadísticamente significativas para un nivel de confianza del 95% para explicar las variaciones en la probabilidad de pagar un credito.
Con el fin de reducir el problema de sobrespecificación del modelo se corren a continuación las versiones de lasso y ridge para un modelo logit. #ridege logit
library(glmnet)
set.seed(123)
grilla=seq(from=0.0001, to=10,length=1000)
set.seed(123)
ridgelog= cv.glmnet(x_train, y_train, alpha=0, family="binomial" ,
type.measure = "auc", nfold=3, lambda = grilla)
coef(ridgelog) # Coeficientes## 30 x 1 sparse Matrix of class "dgCMatrix"
## 1
## (Intercept) 1.274825894
## send_amt 0.056232875
## send_qty 0.041434941
## send_dgr 0.142582453
## received_amt -0.015796600
## received_qty -0.168829976
## received_dgr 0.069173508
## deposit_amt 0.024546715
## deposit_qty 0.038791008
## deposity_dgr -0.122344821
## withdraw_amt 0.075028399
## withdraw_qty 0.101811342
## withdraw_dgr 0.244711168
## bill_amt 0.306408832
## bill_qty 0.052023450
## bill_dgr 0.086225502
## airtime -0.142153343
## topup -0.187502079
## days_no_balance -0.251268301
## age 0.089230633
## genderFEMALE 0.127295614
## genderMALE -0.124668291
## genderOTHER 0.006525196
## clusters1 0.139848857
## clusters2 -0.068655539
## clusters3 -0.112829535
## clusters4 -0.004857019
## clusters5 0.125014306
## clusters6 -0.234695675
## clusters7 -0.041575453ridgelog$lambda.min # lambda con el minimo error de validación cruzada## [1] 1e-04plot(ridgelog) # Resultados de la validación
pridgelog= predict(ridgelog, newx=x_test, s="lambda.min")
library("ROCR")
predr2 <- prediction(pridgelog, test$defaultPaid)
perf2 <- performance(predr2, measure = "tpr", x.measure = "fpr")
plot(perf2, col=rainbow(7), main="ROC curve defaultPaid", xlab="Specificity",
ylab="Sensitivity")
abline(0, 1) 
#Lasso Logit
install.packages("weatherData",repos = "http://cran.us.r-project.org")## Installing package into 'C:/Users/anroj/Documents/R/win-library/3.5'
## (as 'lib' is unspecified)## Warning: package 'weatherData' is not available (for R version 3.5.1)options(repos="https://cran.rstudio.com" )
lassolog= cv.glmnet(x_train, y_train, alpha=1, family="binomial",
type.measure = "auc", nfold=3, lambda=grilla)
coef(lassolog)## 30 x 1 sparse Matrix of class "dgCMatrix"
## 1
## (Intercept) 1.24219385
## send_amt 0.13543492
## send_qty .
## send_dgr 0.31908751
## received_amt -0.03055818
## received_qty -0.38323369
## received_dgr 0.19459310
## deposit_amt -0.01495177
## deposit_qty 0.07079716
## deposity_dgr -0.20635734
## withdraw_amt 0.12763235
## withdraw_qty 0.12361649
## withdraw_dgr 0.34539179
## bill_amt 0.34815100
## bill_qty 0.06689925
## bill_dgr 0.08252905
## airtime -0.22585594
## topup -0.17262281
## days_no_balance -0.28841083
## age 0.09484132
## genderFEMALE 0.24653296
## genderMALE -0.09818810
## genderOTHER 0.08078784
## clusters1 0.15773281
## clusters2 .
## clusters3 -0.20430058
## clusters4 -0.08963106
## clusters5 0.15032017
## clusters6 -0.49051163
## clusters7 -0.04868583lassolog$lambda.min## [1] 1e-04plot(lassolog)
plassolog= predict(lassolog, newx=x_test, s="lambda.min")
classolog= glmnet(x_train, y_train, alpha=1)
plot(classolog,xvar="lambda",label=TRUE)
install.packages("RocR")## Installing package into 'C:/Users/anroj/Documents/R/win-library/3.5'
## (as 'lib' is unspecified)## Warning: package 'RocR' is not available (for R version 3.5.1)## Warning: Perhaps you meant 'ROCR' ?library("ROCR")
predr <- prediction(plassolog, test$defaultPaid)
perf <- performance(predr, measure = "tpr", x.measure = "fpr")
plot(perf, col=rainbow(7), main="ROC curve defaultPaid", xlab="Specificity",
ylab="Sensitivity")
abline(0, 1) 
Como se pudo ver en las curvas ROC estimadas en el apartado anterior la capacidad del modelo sigue siendo aún muy limitada, es por esta razón que a continuación se presenta el modelo desde el punto de vista de un Árbol de Calificación.
Arbol de clasificación
install.packages(c(“rpart”, “rpart.plot”, “MASS”, “randomForest”, “tree”))
library(rpart.plot) #Gráficos## Loading required package: rpartset.seed(123)
tree <- rpart(y_train ~ x_train, data = train, method="class", control=rpart.control(xval=10, cp=1e-04))
printcp(tree) # Resultado de CV##
## Classification tree:
## rpart(formula = y_train ~ x_train, data = train, method = "class",
## control = rpart.control(xval = 10, cp = 1e-04))
##
## Variables actually used in tree construction:
## [1] x_trainage x_trainairtime x_trainbill_amt
## [4] x_trainbill_dgr x_trainbill_qty x_trainclusters1
## [7] x_trainclusters2 x_trainclusters5 x_traindays_no_balance
## [10] x_traindeposit_amt x_traindeposit_qty x_traindeposity_dgr
## [13] x_traingenderFEMALE x_traingenderMALE x_trainreceived_amt
## [16] x_trainreceived_dgr x_trainreceived_qty x_trainsend_amt
## [19] x_trainsend_dgr x_trainsend_qty x_traintopup
## [22] x_trainwithdraw_amt x_trainwithdraw_dgr x_trainwithdraw_qty
##
## Root node error: 8348/35000 = 0.23851
##
## n= 35000
##
## CP nsplit rel error xerror xstd
## 1 0.00862482 0 1.00000 1.00000 0.0095508
## 2 0.00722728 3 0.97413 0.97892 0.0094807
## 3 0.00263536 6 0.95244 0.96287 0.0094261
## 4 0.00203642 7 0.94981 0.96095 0.0094195
## 5 0.00199649 11 0.94166 0.96011 0.0094167
## 6 0.00167705 14 0.93567 0.95927 0.0094138
## 7 0.00155726 16 0.93232 0.95580 0.0094017
## 8 0.00137758 17 0.93076 0.95556 0.0094009
## 9 0.00131768 19 0.92801 0.95424 0.0093963
## 10 0.00099824 20 0.92669 0.95340 0.0093934
## 11 0.00095831 23 0.92369 0.95161 0.0093872
## 12 0.00083852 31 0.91507 0.95256 0.0093905
## 13 0.00077863 38 0.90896 0.95496 0.0093988
## 14 0.00075866 42 0.90585 0.95424 0.0093963
## 15 0.00071874 45 0.90357 0.95604 0.0094026
## 16 0.00065884 51 0.89914 0.95747 0.0094076
## 17 0.00062889 53 0.89782 0.95999 0.0094162
## 18 0.00062290 57 0.89530 0.95987 0.0094158
## 19 0.00059895 62 0.89219 0.95999 0.0094162
## 20 0.00056900 76 0.88321 0.95963 0.0094150
## 21 0.00055902 81 0.87949 0.95879 0.0094121
## 22 0.00053905 84 0.87782 0.95855 0.0094113
## 23 0.00049912 92 0.87350 0.96011 0.0094167
## 24 0.00047916 99 0.86991 0.96059 0.0094183
## 25 0.00043923 117 0.86104 0.96334 0.0094278
## 26 0.00041926 152 0.84104 0.96682 0.0094397
## 27 0.00039930 175 0.82966 0.97017 0.0094511
## 28 0.00038931 181 0.82726 0.97664 0.0094731
## 29 0.00035937 190 0.82355 0.97832 0.0094787
## 30 0.00031944 232 0.80834 0.98347 0.0094960
## 31 0.00029947 247 0.80247 1.00084 0.0095535
## 32 0.00028749 318 0.77659 1.00419 0.0095645
## 33 0.00027951 328 0.77300 1.01198 0.0095898
## 34 0.00026953 387 0.75180 1.01390 0.0095960
## 35 0.00023958 391 0.75072 1.03234 0.0096547
## 36 0.00020963 486 0.72544 1.03965 0.0096776
## 37 0.00019965 500 0.72149 1.05247 0.0097173
## 38 0.00019166 530 0.71394 1.07379 0.0097819
## 39 0.00017968 558 0.70664 1.07822 0.0097951
## 40 0.00015972 634 0.68675 1.09104 0.0098328
## 41 0.00015573 674 0.67897 1.10529 0.0098741
## 42 0.00014974 691 0.67549 1.10697 0.0098789
## 43 0.00014375 719 0.67058 1.11021 0.0098881
## 44 0.00013975 747 0.66447 1.11272 0.0098953
## 45 0.00013690 759 0.66279 1.11272 0.0098953
## 46 0.00011979 792 0.65632 1.14974 0.0099979
## 47 0.00010268 994 0.62482 1.15549 0.0100134
## 48 0.00010000 1001 0.62410 1.15932 0.0100236rootnodexerror100
prp(tree) # Gráfico 2## Warning: labs do not fit even at cex 0.15, there may be some overplotting
Así las cosas este primer árbol resulta muy profundo y difícil de leer por lo que a continuación se podan las ramas del árbol que están de más con base en el número de nodos óptimos para hacer del árbol el mejor modelo de predicción posible.
Minimo error
bestcp=tree$cptable[which.min(tree$cptable[,"xerror"]),"CP"]Podar árbol con el parámetro de error m�??nimo
set.seed(123)
ptree<- prune(tree,cp= bestcp)
prp(ptree)
Como se observa en el árbol presentado anteriormente, solo por dar un ejemplo, aquellas personas que han cambiado menos de -0.75 desviaciones estándar de dinero móvil a dinero real, que han pasado más de -0.36 desviaciones de días sin pagar, que no han recibido más de -0.36 desviaciones estándar de dinero vía mobil money y que han cambiado más de -0.33 desviaciones estándar de dinero movil a dinero físico pagan su crédito.
Predecir
predtree <- predict(ptree, test, type = "class")## Warning: 'newdata' had 15000 rows but variables found have 35000 rowscon el fin de afinar el poder predictivo de la maquina de aprendizaje se procede a la adecuación del modelo al algoritmo de bosques aleatorios que por causa de la carga computacional que requiere la implementación del algoritmo, se seleciona un universo de 100 arboles de clasificación.
Random Forest
library(randomForest)## randomForest 4.6-14## Type rfNews() to see new features/changes/bug fixes.##
## Attaching package: 'randomForest'## The following object is masked from 'package:ggplot2':
##
## margin# Default m: sqrt(p):mtry, ntree= número de árboles para construir
fitrf = randomForest(trainb$default ~.,
data=train,
importance=TRUE, ntree=100)
fitrf$ntree## [1] 100Importancia de variables
varImpPlot(fitrf, type=2)
# Error cv
plot(fitrf)
pred_rf=predict(fitrf, test, type = "class")Matriz de confusión
CM = table( testb$default, pred_rf)
CM## pred_rf
## Default Paid
## Default 24 3511
## Paid 100 11365Como se pudo observar en la gráfica de barras estimada a manera de ranking de importancia para predecir la capacidad de pago de las personas en la economía las variables de la edad, cantidad de dinero recibido vía plataforma dinero móvil, la cantidad de dinero convertido de dinero móvil a dinero físico, la cantidad de dinero depositado en plataformas móvil, el tiempo que tiene las personas al aire en la plataforma mobil money, la cantidad de dinero enviado por este tipo de plataformas y los días en mora son aquellas variables de mayor peso a ser tenidas en cuenta a la hora de predecir la capacidad de pago de un individuo en la economía.
Finalmente, se presenta un modelo bosting siendo este el mejor modelo predictor de capacidad de pago por parte de los agentes en la economía a partir de la información disponible en la base de datos de la plataforma dinero móvil.
Bosting
install.packages(c(“gbm”, “ggplot2”,“survival”, “prodlim”))
library(survival)##
## Attaching package: 'survival'## The following object is masked from 'package:rpart':
##
## solderlibrary(gbm)## Loading required package: lattice## Loading required package: splines## Loading required package: parallel## Loaded gbm 2.1.3gbmf=gbm(defaultPaid~.,data=train,distribution="bernoulli",n.trees=100,interaction.depth=10, cv.folds = 10)
print(gbmf)## gbm(formula = defaultPaid ~ ., distribution = "bernoulli", data = train,
## n.trees = 100, interaction.depth = 10, cv.folds = 10)
## A gradient boosted model with bernoulli loss function.
## 100 iterations were performed.
## The best cross-validation iteration was 100.
## There were 29 predictors of which 19 had non-zero influence.summary(gbmf) 
mejor = gbm.perf(gbmf, method="cv") 
gbmf=gbm(defaultPaid~.,data=train,distribution="bernoulli",n.trees=mejor,interaction.depth=10)
summary(gbmf) 
importancia_pred <- summary(gbmf, plotit = FALSE, n.trees=mejor)
ggplot(data = importancia_pred, aes(x = reorder(var, rel.inf), y = rel.inf,
fill = rel.inf)) +
labs(x = "variable", title = "Reducción de MSE") +
geom_col() +
coord_flip() +
theme_bw() +
theme(legend.position = "bottom")
predict<-predict(gbmf,newdata=test,n.trees=100)
mean((predict-test$defaultPaid)^2)## [1] 0.3370699Luego de haber corrido el modelo mediante el algoritmo de boosting, se consolida un modelo de predicción con un 33% de error, mejor que los modelos anteriores que terminan por predecir con un error del 44%. Finalmente, dentro de las variables más importantes a ser tenidas en cuenta para la predicción de la capacidad de pago de los agentes en la economía se encontró que la variable más importante es el cambio de dinero de la plataforma móvil a dinero físico, seguido por los días en mora que presentan los individuos en sus deudas el topup y la cantidad de dinero recibido mediante la plataforma móvil.
Por otra parte, en lo que respecta al diseño de una política pública que busque garantizar el acceso de al crédito de la poblaciones más pobres de la economía, resulta útil el uso de este modelo predictivo con el fin de aumentar la cantidad de personas que a pesar de no tener algún activo que de soporte a la deuda adquirida con el banco, estos tengan la capacidad de pago de las mismas, así de esta manera conseguir la reducción de las barreras sociales que impiden la superación de la pobreza en los países menos desarrollados.
Si bien los modelos presentados al inicio del ejercicio presentan estimaciones más consistentes su varianza es muy amplia lo cual termina perjudicando la capacidad de predicción de estos modelos, los modelos de bosques aleatorios y boosting resuelven el problema de predicción reduciendo la varianza de las estimaciones asumiendo un costo en término de sesgo estos resultaran más útiles a la hora de predecir el comportamiento de los individuos sujetos a un programa o una intervención de política pública.
Para el caso puntual del ejercicio resulta clara la necesidad de minimizar el riesgo que puede asumir una banca de desarrollo al afrontarse a la decisión de brindar crédito a los menos favorecidos dada la incertidumbre y el no sustento de la deuda que hacen ver los individuos beneficiarios del programa de crédito