Descripción

El scoring abarca una serie de técnicas estadísticas y es muy utilizado para otorgar crédito en las instituciones bancarias. Es un método que pronostica el riesgo futuro por el incumplimiento de pagos en una ventana de tiempo determinada. Este procedimiento lleva utilizándose desde hace 50 años gracias a los avances de los ordenadores que permiten trabajar con grandes volúmenes de datos de manera rápida y eficaz. Estas técnicas tienen como objetivo asociar una puntuación de riesgo a las solicitudes de crédito o a cuentas.

Para estre proyecto se trabajara sobre una base de datos encontrada en un curso de estadística en la universidad de Harvard, La base se encuentra en un archivo de excel llamado GermanCredit. Esta base esta conformada por 31 variables y 1000 observaciones, cada observación corresponde a un formulario para la solicitud de crédito.

Conjunto de datos

Germán credit

library(readxl)
library(data.table)
library(dplyr)
data <- read_excel("GermanCredit.xls")
#data %>% DT::datatable(options = list(pageLength = 5))
knitr::kable(head(data))

OBS#	CHK_ACCT	DURATION	HISTORY	NEW_CAR	FURNITURE	RADIO/TV	EDUCATION	AMOUNT	SAV_ACCT	EMPLOYMENT	INSTALL_RATE	MALE_SINGLE	GUARANTOR	PRESENT_RESIDENT	REAL_ESTATE	PROP_UNKN_NONE	AGE	OWN_RES	NUM_CREDITS	JOB	NUM_DEPENDENTS	TELEPHONE	RESPONSE
1	0	6	4	0	0	1	0	1169	4	4	4	1	0	4	1	0	67	1	2	2	1	1	1
2	1	48	2	0	0	1	0	5951	0	2	2	0	0	2	1	0	22	1	1	2	1	0	0
3	3	12	4	0	0	0	1	2096	0	3	2	1	0	3	1	0	49	1	1	1	2	0	1
4	0	42	2	0	1	0	0	7882	0	3	2	1	1	4	0	0	45	0	1	2	2	0	1
5	0	24	3	1	0	0	0	4870	0	2	3	1	0	4	0	1	53	0	2	2	2	0	0
6	3	36	2	0	0	0	1	9055	4	2	2	1	0	4	0	1	35	0	1	1	2	1	1

Minería de datos

Limpieza, transformación y discretización de datos

Primero realizamos una limpieza de la data. Para lo cuál eliminamos la columna OBS# púes no aporta información para nuestros objetivos.

library(dplyr)
data<-select(data,-c(`OBS#`))

La discretización esta relacionada con la transformación de datos nominales a numéricos o viceversa. Para el manejo de datos clasificaremos a las variables en categóricas y numéricas, a las variables categóricas en R se las trata como tipo factor. Ademas, dada la presentación de los datos compactaremos 6 variables binarias en una sola llamada TYPE que recoge toda la información de las variables RETRAINING, EDUCATION, RADIO/TV, FORNITURE, USED_cAR, NEW_cAR

Variables Factor, numérico

data1<-data %>% mutate(RESPONSE=factor(RESPONSE, levels = c(0,1), labels = c("No","Si")),
                      FOREIGN=factor(FOREIGN,levels = c(0,1), labels = c("No","Si")),
                      TELEPHONE=factor(TELEPHONE,levels = c(0,1), labels = c("No","Si")),
                      NUM_DEPENDENTS=as.numeric(NUM_DEPENDENTS),
                      JOB=factor(JOB, levels = c(0,1,2,3), labels = c("Desempleado","No calificado","Calificado","Gerente-Autónomo")),
                      NUM_CREDITS=as.numeric(NUM_CREDITS),
                      OWN_RES=factor(OWN_RES,levels = c(0,1), labels = c("No","Si") ),
                      RENT=factor(RENT,levels = c(0,1), labels = c("No","Si") ),
                      OTHER_INSTALL=factor(OTHER_INSTALL,levels = c(0,1), labels = c("No","Si")),
                      AGE=as.numeric(AGE),
                      PROP_UNKN_NONE=factor(PROP_UNKN_NONE, levels=c(0,1),labels = c("No","Si")),
                      REAL_ESTATE=factor(REAL_ESTATE, levels = c(0,1), labels = c("No","Si")),
                      PRESENT_RESIDENT=factor(PRESENT_RESIDENT, levels= c(1,2,3,4),labels = c("0 a 1","1 a 2","2 a 3","mayor a 3")),
                      GUARANTOR=factor(GUARANTOR, levels = c(0,1), labels = c("No","Si")),
                      `CO-APPLICANT`=factor(`CO-APPLICANT`, levels = c(0,1), labels = c("No","Si")),
                      MALE_MAR_or_WID=factor(MALE_MAR_or_WID, levels = c(0,1), labels = c("No","Si")),
                      MALE_SINGLE=factor(MALE_SINGLE,levels = c(0,1), labels = c("No","Si")),
                      MALE_DIV=factor(MALE_DIV,levels = c(0,1), labels = c("No","Si")),
                      INSTALL_RATE=as.numeric(INSTALL_RATE),
                      EMPLOYMENT=factor(EMPLOYMENT, levels = c(0,1,2,3,4)),
                      SAV_ACCT=factor(SAV_ACCT),
                      AMOUNT=as.numeric(AMOUNT),
                      TYPE=as.factor(ifelse(RETRAINING==1,"RETRAINING",ifelse(EDUCATION==1,"EDUCATION",ifelse(`RADIO/TV`==1,"RADIO/TV",ifelse(FURNITURE==1,"FORNITURE",ifelse(USED_CAR==1,"USED.CAR","NEW.CAR")))))),
                      HISTORY=factor(HISTORY),
                      DURATION=as.numeric(DURATION),
                      CHK_ACCT=factor(CHK_ACCT,levels = c(0,1,2,3), labels = c( "0 DM","0 A 200DM","mayor a200"," No tiene")))

data1<-select(data1, -c("MALE_DIV", "MALE_SINGLE","MALE_MAR_or_WID","EDUCATION","RADIO/TV" ,"USED_CAR","NEW_CAR","FURNITURE","RETRAINING"))
Civil<-ifelse(data$MALE_DIV==1,"Male_div",ifelse(data$MALE_SINGLE,"M-single",ifelse(data$MALE_MAR_or_WID==1,"M.mar.wid","other")))
Civil<-as.factor(Civil)
data1<-data.frame(data1,Civil)

knitr::kable(head(data1))

CHK_ACCT	DURATION	HISTORY	AMOUNT	SAV_ACCT	EMPLOYMENT	INSTALL_RATE	CO.APPLICANT	GUARANTOR	PRESENT_RESIDENT	REAL_ESTATE	PROP_UNKN_NONE	AGE	OTHER_INSTALL	RENT	OWN_RES	NUM_CREDITS	JOB	NUM_DEPENDENTS	TELEPHONE	FOREIGN	RESPONSE	TYPE	Civil
0 DM	6	4	1169	4	4	4	No	No	mayor a 3	Si	No	67	No	No	Si	2	Calificado	1	Si	No	Si	RADIO/TV	M-single
0 A 200DM	48	2	5951	0	2	2	No	No	1 a 2	Si	No	22	No	No	Si	1	Calificado	1	No	No	No	RADIO/TV	other
No tiene	12	4	2096	0	3	2	No	No	2 a 3	Si	No	49	No	No	Si	1	No calificado	2	No	No	Si	EDUCATION	M-single
0 DM	42	2	7882	0	3	2	No	Si	mayor a 3	No	No	45	No	No	No	1	Calificado	2	No	No	Si	FORNITURE	M-single
0 DM	24	3	4870	0	2	3	No	No	mayor a 3	No	Si	53	No	No	No	2	Calificado	2	No	No	No	NEW.CAR	M-single
No tiene	36	2	9055	4	2	2	No	No	mayor a 3	No	Si	35	No	No	No	1	No calificado	2	Si	No	Si	EDUCATION	M-single

Tratamiento de atípicos

## Division de la data en tipo de variables
library(PCAmixdata)
corte<-splitmix(data1)
dquanti<-as.data.frame(corte$X.quanti)
dcuali<-as.data.frame(corte$X.quali)

Para obtener una base de datos consistente debemos realizar un tratamiento de datos atípicos, para eliminar u ajustar su influencia en los modelos.

KNN

Algorítmo Knn. (K Vecinos más cercanos)

Para el subconjunto de variables cuantitativas aplicamos el algoritmo knn con $K=5$.

library(FNN)
X<-get.knn(data = dquanti,k=5)
score<-rowMeans(X$nn.dist)

Tomaremos el percentil $0.975$ para declarar como cota y obtenemos una lista de indices que superan la cota.

cota<-quantile(score,c(0.75,0.975))[2]
index<-which(score>cota)
Out<-score[index]
length(Out)

## [1] 25

Asì, existen 25 valores detectados como atípicos.

library(ggplot2)
valores<-as.factor(ifelse(score>cota,"Eliminar","No eliminar"))
obs<-c(1:length(score))
pd<-data.frame(score,valores,obs) 
ggplot(pd, aes(x=obs,y=score, col=valores)) +geom_point()

Por lo tanto, estos 25 datos deben ser separados del conjunto de datos para futuros análisis. Sin embargo, antes de eliminarlos vamos a realizar otro análisis mediante el algoritmo Lof.

LOF

De igual manera procedemos a tomar un limite o cota para declarar atípicos a los datos que superen este límite.

library(dbscan)
lof<-lof(as.data.frame(scale(dquanti)),5)
lim<-quantile(lof,c(0.75,0.975))[2]
indexout<-which(lof>lim)
length(lof[indexout])

## [1] 25

Observamos que de igual manera tenemos 25 datos atípicos.

library(ggplot2)
valores<-as.factor(ifelse(lof>lim,"Eliminar","No eliminar"))
obs<-c(1:length(lof))
pd<-data.frame(lof,valores,obs) 
ggplot(pd, aes(x=obs,y=lof, col=valores)) +geom_point()

Vemos que podrían ser más los datos atípicos, pero al análisar los dos algoritmos concluimos que es mejor tomar estos 25 y separarlos.

ELIMINACIÓN DE DATOS ATÍPICOS

Datos<-data1
Datos<-Datos[-indexout,]
nrow(Datos)

## [1] 975

Ahora, de aquí en adelante trabajaremos con el conjunto de datos **Datos*.

Anális univariante y Multivariante

Univariante

V. Cuantitativas

summary(dquanti)

##     DURATION        AMOUNT       INSTALL_RATE        AGE         NUM_CREDITS   
##  Min.   : 4.0   Min.   :  250   Min.   :1.000   Min.   :19.00   Min.   :1.000  
##  1st Qu.:12.0   1st Qu.: 1366   1st Qu.:2.000   1st Qu.:27.00   1st Qu.:1.000  
##  Median :18.0   Median : 2320   Median :3.000   Median :33.00   Median :1.000  
##  Mean   :20.9   Mean   : 3271   Mean   :2.973   Mean   :35.55   Mean   :1.407  
##  3rd Qu.:24.0   3rd Qu.: 3972   3rd Qu.:4.000   3rd Qu.:42.00   3rd Qu.:2.000  
##  Max.   :72.0   Max.   :18424   Max.   :4.000   Max.   :75.00   Max.   :4.000  
##  NUM_DEPENDENTS 
##  Min.   :1.000  
##  1st Qu.:1.000  
##  Median :1.000  
##  Mean   :1.155  
##  3rd Qu.:1.000  
##  Max.   :2.000

Tenemos las siguientes observaciones:
- La cantidad media de préstamo que es solicitado es de $2303,00\$$.
- La duración media de los préstamos es $ 19 $ meses.
- La edad promedio de los solicitantes a préstamo es de $35$ años.

Correlaciones

library(dplyr)
library(corrplot)
matriz<-cor(dquanti)
corrplot(matriz)

Densidades

library(dplyr)
library(tidyr)
data %>%
  select(AGE, AMOUNT,DURATION, INSTALL_RATE,NUM_CREDITS,NUM_DEPENDENTS) %>%
  gather(metric, value) %>%
  ggplot(aes(value, fill = metric)) +
  geom_density(show.legend = FALSE) +
  facet_wrap(~ metric, scales = "free")

Variables Cualitativas

summary(dcuali)

##        CHK_ACCT   HISTORY SAV_ACCT EMPLOYMENT CO.APPLICANT GUARANTOR
##  0 DM      :274   0: 40   0:603    0: 62      No:959       No:948   
##  0 A 200DM :269   1: 49   1:103    1:172      Si: 41       Si: 52   
##  mayor a200: 63   2:530   2: 63    2:339                            
##   No tiene :394   3: 88   3: 48    3:174                            
##                   4:293   4:183    4:253                            
##                                                                     
##   PRESENT_RESIDENT REAL_ESTATE PROP_UNKN_NONE OTHER_INSTALL RENT     OWN_RES 
##  0 a 1    :130     No:718      No:846         No:814        No:821   No:287  
##  1 a 2    :308     Si:282      Si:154         Si:186        Si:179   Si:713  
##  2 a 3    :149                                                               
##  mayor a 3:413                                                               
##                                                                              
##                                                                              
##                JOB      TELEPHONE FOREIGN  RESPONSE         TYPE    
##  Desempleado     : 22   No:596    No:963   No:300   EDUCATION : 50  
##  No calificado   :200   Si:404    Si: 37   Si:700   FORNITURE :181  
##  Calificado      :630                               NEW.CAR   :289  
##  Gerente-Autónomo:148                               RADIO/TV  :280  
##                                                     RETRAINING: 97  
##                                                     USED.CAR  :103  
##        Civil    
##  M-single :548  
##  M.mar.wid: 92  
##  Male_div : 50  
##  other    :310  
##                 
##

Tenemos las siguientes observaciones:
- La mayor parte de solicitantes de crédito son recidentes locales
- Un gran número de solicitantes tienen un trabajo entre calificado y no calificado.
- El motivo de crédito es mayormente para la adquisisción de un vehívulo, la comra de electrodomesticos y muebles.

Correlaciones Cualitativas

$Ho:$ las variables son independientes $Ha:$ las variables son dependientes

Gráficos cruzados

 ggplot(data,aes(x=AGE,fill=RESPONSE))+
  geom_histogram()+
  labs(y="Apariciones",title="AGE")

 ggplot(data,aes(x=AMOUNT,fill=RESPONSE))+
  geom_histogram()+
  labs(y="Apariciones",title="AMOUNT")

 ggplot(data1,aes(x=TYPE,fill=RESPONSE))+
  geom_bar()+
  labs(y="Apariciones",title="Objetivo de crédito")

 ggplot(data1, aes(x=JOB, fill=RESPONSE))+
  geom_bar()+
  labs(y="Apariciones",title="Condicion de empleo")

ggplot(data1, aes(x=CHK_ACCT, fill=RESPONSE))+
  geom_bar()+
  labs(y="Apariciones",title = "Cuenta en el banco")

Multivariante

Vamos a realizar algunos gráficos.

library(ggplot2)
ggplot(dcuali, aes(x=TYPE,fill=TELEPHONE)) + geom_bar() + facet_wrap(~RESPONSE)

Podemos observar que el tipo para el cuál es solicitado el prestamo en alguna manera afecta, pues hay una gran cantidad de aceptación en los tipo:

ggplot(dcuali, aes(x=GUARANTOR,fill=GUARANTOR)) + geom_bar() + facet_wrap(~RESPONSE)

El tener garante, no afecta directamente a la desición de otorgar o no el crédito.

Selección de variables

Para realizar un buen modelo, es necesario introducir las variables que tengan el mayor poder predictivo con respecto a la variable objetivo.

En nuestro caso, la variable objetivo es RESPONSE la cual es cualitativa.

Valor de información IV

Muy tradicionalmente se ah conciderado el IV como una regla discriminatoria para el poder predictivo de las variables. Este IV tiene las siguientes reglas.

Reglas:
- IV < 0.2 : Sin poder predictivo.
- 0.02 < IV < 0.1 : poder predictivo bajo
- 0.1 < IV < 0.3 : poder predictivo medio
- 0.3 < IV < 0.5 : poder predictivo fuerte
- IV > 0.5 : poder predictivo sospechosamente fuerte

library(Information)
DatosIV<-Datos
DatosIV$RESPONSE<-as.numeric(DatosIV$RESPONSE)
DatosIV$RESPONSE<-ifelse(DatosIV$RESPONSE==1,0,1)
IV<- Information::create_infotables(data=DatosIV, y="RESPONSE", parallel = FALSE)
knitr::kable(head(IV$Summary))

	Variable	IV
1	CHK_ACCT	0.6702618
2	DURATION	0.3149655
3	HISTORY	0.2844285
5	SAV_ACCT	0.2060674
22	TYPE	0.1572077
13	AGE	0.1039258

En esta primera agrupación vemos que solo 6 variables tienen un poder predictivo conciderable para la aplicación de un modelo. Talvez si se concidera otra agrupación en cada una de las variables podamos tener alguna otra variable con IV apropiado.

Árboles de clasificación

Otra forma de realizar una selección de variables es utilizando los árboles de clasificación, ya que estos nos retornan los nodos principales para la clasificación.

library(rpart)
library(rpart.plot)
arb <- rpart(RESPONSE ~.,data=Datos)
rpart.plot(arb)

Podemos ver las variables más importantes o más descriminatorias para la clasificación

arb$variable.importance

##         CHK_ACCT         DURATION           AMOUNT          HISTORY 
##       52.1694846       25.1261708       19.0368613       16.1695856 
##             TYPE         SAV_ACCT              AGE PRESENT_RESIDENT 
##       15.6450494       14.6325529        3.8334869        2.7565081 
##   PROP_UNKN_NONE       EMPLOYMENT              JOB     INSTALL_RATE 
##        2.7193477        2.0374776        1.7648015        1.3058787 
##        GUARANTOR          FOREIGN 
##        1.1109237        0.1103915

Partición de datos

Es necesario conciderar un subconjunto de los datos para entrenar nuestro modelo y otro subconjunto para testear el modelo.

Así, también se debe conciderar dicha partición de manera que los datos sean balanceados en ambos subsets. Conjunto de datos de entrenamiento y test

library(rsample)
set.seed(123)
corte<- initial_split(Datos, prop = 0.7, strata = "RESPONSE")
train <- training(corte)
test  <- testing(corte)

table(train$RESPONSE) %>% prop.table()

## 
##        No        Si 
## 0.3011696 0.6988304

Una regla paradeterminar si los datos estan desbalanceados es observar la clase minoritaria, y si la clase minoritaria no supera el 5% de los datos, entonces se procede a realizar un balance de datos.

Balanceo de Datos

Se puede ver más sobre balanceo de datos Aqui Link

library(ROSE)
Dtrain<-train
Dtrain <- ovun.sample(RESPONSE ~ ., data = Dtrain, method = "both", p=0.5, N=700, seed = 1)$data
table(Dtrain$RESPONSE) %>% prop.table()

## 
##        Si        No 
## 0.5142857 0.4857143

Ahora vemos que ambas clases tienen casi la misma proporcion.

Modelos de Regresión Logística

Modelo 1

Implementación

Para el primer modelo consideraremos todas las variables y los datos balanceados.

library(glm2)
model1<-glm(RESPONSE ~. , family = binomial , data= Dtrain)
summary(model1)

## 
## Call:
## glm(formula = RESPONSE ~ ., family = binomial, data = Dtrain)
## 
## Deviance Residuals: 
##      Min        1Q    Median        3Q       Max  
## -2.56849  -0.59682  -0.08616   0.57934   2.77194  
## 
## Coefficients:
##                             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                5.886e-01  1.702e+00   0.346 0.729430    
## CHK_ACCT0 A 200DM         -1.725e-01  2.994e-01  -0.576 0.564361    
## CHK_ACCTmayor a200        -1.910e+00  5.083e-01  -3.758 0.000171 ***
## CHK_ACCT No tiene         -1.984e+00  3.107e-01  -6.384 1.72e-10 ***
## DURATION                   3.808e-02  1.332e-02   2.860 0.004243 ** 
## HISTORY1                   9.270e-01  7.857e-01   1.180 0.238100    
## HISTORY2                   1.161e-01  6.255e-01   0.186 0.852758    
## HISTORY3                  -1.841e-01  6.569e-01  -0.280 0.779276    
## HISTORY4                  -1.144e+00  6.111e-01  -1.872 0.061154 .  
## AMOUNT                     6.203e-05  6.443e-05   0.963 0.335636    
## SAV_ACCT1                 -1.064e+00  4.062e-01  -2.621 0.008779 ** 
## SAV_ACCT2                 -8.633e-01  4.921e-01  -1.754 0.079363 .  
## SAV_ACCT3                 -2.427e+00  7.429e-01  -3.267 0.001088 ** 
## SAV_ACCT4                 -7.633e-01  3.364e-01  -2.269 0.023241 *  
## EMPLOYMENT1                3.099e-01  6.154e-01   0.504 0.614557    
## EMPLOYMENT2               -7.014e-01  5.998e-01  -1.169 0.242314    
## EMPLOYMENT3               -1.455e+00  6.381e-01  -2.281 0.022567 *  
## EMPLOYMENT4               -1.149e+00  5.842e-01  -1.967 0.049184 *  
## INSTALL_RATE               5.714e-01  1.284e-01   4.449 8.61e-06 ***
## CO.APPLICANTSi             9.558e-01  5.631e-01   1.697 0.089625 .  
## GUARANTORSi               -8.979e-01  6.300e-01  -1.425 0.154060    
## PRESENT_RESIDENT1 a 2      1.616e+00  4.226e-01   3.823 0.000132 ***
## PRESENT_RESIDENT2 a 3      4.742e-01  4.744e-01   1.000 0.317524    
## PRESENT_RESIDENTmayor a 3  5.516e-01  4.154e-01   1.328 0.184230    
## REAL_ESTATESi              3.583e-01  2.828e-01   1.267 0.205131    
## PROP_UNKN_NONESi           6.622e-01  5.340e-01   1.240 0.214963    
## AGE                       -1.885e-02  1.188e-02  -1.587 0.112472    
## OTHER_INSTALLSi            1.337e+00  3.069e-01   4.356 1.33e-05 ***
## RENTSi                    -5.782e-01  6.396e-01  -0.904 0.365991    
## OWN_RESSi                 -3.901e-01  5.990e-01  -0.651 0.514873    
## NUM_CREDITS                2.843e-01  2.940e-01   0.967 0.333440    
## JOBNo calificado          -1.116e+00  1.098e+00  -1.016 0.309526    
## JOBCalificado             -8.152e-01  1.065e+00  -0.766 0.443885    
## JOBGerente-Autónomo       -8.792e-01  1.088e+00  -0.808 0.418971    
## NUM_DEPENDENTS             1.333e-01  3.472e-01   0.384 0.701125    
## TELEPHONESi               -4.534e-01  2.663e-01  -1.703 0.088619 .  
## FOREIGNSi                 -2.449e+00  1.050e+00  -2.333 0.019665 *  
## TYPEFORNITURE             -6.559e-01  5.405e-01  -1.214 0.224900    
## TYPENEW.CAR               -7.616e-01  4.953e-01  -1.538 0.124149    
## TYPERADIO/TV              -2.166e+00  5.306e-01  -4.082 4.47e-05 ***
## TYPERETRAINING            -1.389e+00  6.069e-01  -2.288 0.022119 *  
## TYPEUSED.CAR              -2.053e+00  6.189e-01  -3.318 0.000907 ***
## CivilM.mar.wid            -1.736e-01  4.359e-01  -0.398 0.690344    
## CivilMale_div              1.534e+00  5.598e-01   2.740 0.006139 ** 
## Civilother                 9.821e-02  2.778e-01   0.354 0.723704    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 969.83  on 699  degrees of freedom
## Residual deviance: 566.61  on 655  degrees of freedom
## AIC: 656.61
## 
## Number of Fisher Scoring iterations: 5

Vemos que pocas variables son significativas para el modelo y tenemos:

AIC = $656.61$
Null deviance = $969.83$

Matriz de confución

library(caret)
y_fit<-predict(model1,newdata = Dtrain, type="response")
y_fit<-as.factor(ifelse(y_fit>0.5,"Si","No"))

confusionMatrix(Dtrain$RESPONSE,y_fit)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  No  Si
##         No  60 280
##         Si 293  67
##                                          
##                Accuracy : 0.1814         
##                  95% CI : (0.1536, 0.212)
##     No Information Rate : 0.5043         
##     P-Value [Acc > NIR] : 1.0000         
##                                          
##                   Kappa : -0.6367        
##                                          
##  Mcnemar's Test P-Value : 0.6162         
##                                          
##             Sensitivity : 0.16997        
##             Specificity : 0.19308        
##          Pos Pred Value : 0.17647        
##          Neg Pred Value : 0.18611        
##              Prevalence : 0.50429        
##          Detection Rate : 0.08571        
##    Detection Prevalence : 0.48571        
##       Balanced Accuracy : 0.18153        
##                                          
##        'Positive' Class : No             
##

Muy por debajo de lo esperado, una presición muy inferior y que decir de la sensibilidad y especificidad.

En primera instancia se sospecha que no se debe balancear los datos.

Modelo 2

Implementación

Para el segundo modelo consideraremos todas las variables y los datos sin balancear.

model2<-glm(RESPONSE~., family = binomial(),data=train)
summary(model2)

## 
## Call:
## glm(formula = RESPONSE ~ ., family = binomial(), data = train)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.7774  -0.6804   0.3524   0.6740   2.4001  
## 
## Coefficients:
##                             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                2.011e+00  1.425e+00   1.411 0.158269    
## CHK_ACCT0 A 200DM          1.286e-01  2.737e-01   0.470 0.638432    
## CHK_ACCTmayor a200         7.476e-01  4.609e-01   1.622 0.104804    
## CHK_ACCT No tiene          1.465e+00  2.829e-01   5.177 2.25e-07 ***
## DURATION                  -2.740e-02  1.211e-02  -2.263 0.023661 *  
## HISTORY1                   9.676e-02  6.538e-01   0.148 0.882336    
## HISTORY2                   4.706e-01  5.350e-01   0.879 0.379136    
## HISTORY3                   5.835e-01  5.870e-01   0.994 0.320220    
## HISTORY4                   1.326e+00  5.512e-01   2.405 0.016162 *  
## AMOUNT                    -1.087e-04  5.798e-05  -1.875 0.060827 .  
## SAV_ACCT1                  4.043e-01  3.741e-01   1.081 0.279866    
## SAV_ACCT2                  6.071e-01  4.991e-01   1.216 0.223886    
## SAV_ACCT3                  1.894e+00  7.106e-01   2.666 0.007683 ** 
## SAV_ACCT4                  9.831e-01  3.165e-01   3.106 0.001896 ** 
## EMPLOYMENT1               -1.398e-01  5.314e-01  -0.263 0.792453    
## EMPLOYMENT2                5.357e-01  5.208e-01   1.029 0.303661    
## EMPLOYMENT3                8.067e-01  5.623e-01   1.435 0.151375    
## EMPLOYMENT4                4.241e-01  5.191e-01   0.817 0.413921    
## INSTALL_RATE              -4.661e-01  1.121e-01  -4.159 3.20e-05 ***
## CO.APPLICANTSi            -4.077e-01  5.812e-01  -0.702 0.482956    
## GUARANTORSi                5.806e-01  5.142e-01   1.129 0.258850    
## PRESENT_RESIDENT1 a 2     -9.045e-01  3.742e-01  -2.417 0.015650 *  
## PRESENT_RESIDENT2 a 3     -3.119e-01  4.224e-01  -0.738 0.460240    
## PRESENT_RESIDENTmayor a 3 -4.650e-01  3.728e-01  -1.247 0.212258    
## REAL_ESTATESi              2.469e-01  2.600e-01   0.949 0.342455    
## PROP_UNKN_NONESi          -6.198e-01  4.809e-01  -1.289 0.197483    
## AGE                        1.168e-02  1.197e-02   0.975 0.329447    
## OTHER_INSTALLSi           -9.680e-01  2.596e-01  -3.728 0.000193 ***
## RENTSi                    -6.063e-01  5.868e-01  -1.033 0.301513    
## OWN_RESSi                 -4.717e-02  5.563e-01  -0.085 0.932417    
## NUM_CREDITS               -1.217e-01  2.373e-01  -0.513 0.608009    
## JOBNo calificado          -2.599e-01  8.515e-01  -0.305 0.760164    
## JOBCalificado             -3.373e-01  8.234e-01  -0.410 0.682040    
## JOBGerente-Autónomo       -1.512e-01  8.387e-01  -0.180 0.856970    
## NUM_DEPENDENTS            -3.631e-01  3.184e-01  -1.140 0.254134    
## TELEPHONESi                4.455e-01  2.431e-01   1.833 0.066866 .  
## FOREIGNSi                  2.121e+00  9.069e-01   2.339 0.019359 *  
## TYPEFORNITURE              7.330e-01  5.032e-01   1.457 0.145208    
## TYPENEW.CAR                1.920e-01  4.704e-01   0.408 0.683084    
## TYPERADIO/TV               1.269e+00  4.972e-01   2.552 0.010721 *  
## TYPERETRAINING             6.961e-01  5.793e-01   1.202 0.229510    
## TYPEUSED.CAR               1.646e+00  5.981e-01   2.752 0.005924 ** 
## CivilM.mar.wid            -2.546e-01  3.936e-01  -0.647 0.517677    
## CivilMale_div             -9.529e-01  4.846e-01  -1.967 0.049237 *  
## Civilother                -5.304e-01  2.566e-01  -2.067 0.038716 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 837.01  on 683  degrees of freedom
## Residual deviance: 596.50  on 639  degrees of freedom
## AIC: 686.5
## 
## Number of Fisher Scoring iterations: 5

Vemos que igualmente pocas variables son significativas para el modelo y tenemos:

AIC = $686.51$
Null deviance = $837.01$

Matriz de confunción

y2_fit<-as.factor(ifelse(model2$fitted.values>0.5,"Si","No"))
confusionMatrix(train$RESPONSE,y2_fit)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  No  Si
##         No 120  86
##         Si  49 429
##                                           
##                Accuracy : 0.8026          
##                  95% CI : (0.7708, 0.8318)
##     No Information Rate : 0.7529          
##     P-Value [Acc > NIR] : 0.001201        
##                                           
##                   Kappa : 0.5059          
##                                           
##  Mcnemar's Test P-Value : 0.001946        
##                                           
##             Sensitivity : 0.7101          
##             Specificity : 0.8330          
##          Pos Pred Value : 0.5825          
##          Neg Pred Value : 0.8975          
##              Prevalence : 0.2471          
##          Detection Rate : 0.1754          
##    Detection Prevalence : 0.3012          
##       Balanced Accuracy : 0.7715          
##                                           
##        'Positive' Class : No              
##

Ahora si, podemos ver que tenemos una presición del $80.26%$, y una sensibilidad, especificidad con un comportamiento muy estable.

Ps.R-cuadrado

library(sigr)
R2 <- wrapChiSqTest(model2)
R2$pseudoR2

## [1] 0.2873498

Deviance

library(broom)

broom::glance(model2) %>%
  summarize(deviance)

## # A tibble: 1 x 1
##   deviance
##      <dbl>
## 1     596.

Predicciones

y_pred<-predict(model2, newdata = test , type="response")
y_pred<- as.factor(ifelse(y_pred>0.5,"Si","No"))
confusionMatrix(test$RESPONSE,y_pred)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  No  Si
##         No  41  46
##         Si  32 172
##                                          
##                Accuracy : 0.732          
##                  95% CI : (0.6771, 0.782)
##     No Information Rate : 0.7491         
##     P-Value [Acc > NIR] : 0.773          
##                                          
##                   Kappa : 0.3296         
##                                          
##  Mcnemar's Test P-Value : 0.141          
##                                          
##             Sensitivity : 0.5616         
##             Specificity : 0.7890         
##          Pos Pred Value : 0.4713         
##          Neg Pred Value : 0.8431         
##              Prevalence : 0.2509         
##          Detection Rate : 0.1409         
##    Detection Prevalence : 0.2990         
##       Balanced Accuracy : 0.6753         
##                                          
##        'Positive' Class : No             
##

Con los datos de test vemos que tenemos una caída de la presición de $80.26%$ a $73.2%$ y la sensibilidad y especificidad se ve un poco deteriorada.

Modelo 3

Implementación

Para el modelo 3, concideraremos las variables más importantes obtenidas por el árbol de clasificación y con los datos sin balancear.

model3<-glm(RESPONSE ~ CHK_ACCT + DURATION + AMOUNT +  HISTORY + TYPE + SAV_ACCT +  AGE 
                        + PRESENT_RESIDENT + PROP_UNKN_NONE + EMPLOYMENT + JOB + INSTALL_RATE
                        + GUARANTOR + FOREIGN, data=train , family = binomial())
summary(model3)

## 
## Call:
## glm(formula = RESPONSE ~ CHK_ACCT + DURATION + AMOUNT + HISTORY + 
##     TYPE + SAV_ACCT + AGE + PRESENT_RESIDENT + PROP_UNKN_NONE + 
##     EMPLOYMENT + JOB + INSTALL_RATE + GUARANTOR + FOREIGN, family = binomial(), 
##     data = train)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.8263  -0.7044   0.4027   0.7188   1.8998  
## 
## Coefficients:
##                             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                4.154e-01  1.089e+00   0.382  0.70279    
## CHK_ACCT0 A 200DM          2.204e-01  2.628e-01   0.839  0.40163    
## CHK_ACCTmayor a200         6.671e-01  4.415e-01   1.511  0.13083    
## CHK_ACCT No tiene          1.497e+00  2.733e-01   5.476 4.34e-08 ***
## DURATION                  -2.964e-02  1.154e-02  -2.569  0.01020 *  
## AMOUNT                    -8.709e-05  5.430e-05  -1.604  0.10876    
## HISTORY1                  -1.997e-01  6.323e-01  -0.316  0.75219    
## HISTORY2                   6.212e-01  5.067e-01   1.226  0.22023    
## HISTORY3                   6.252e-01  5.723e-01   1.092  0.27464    
## HISTORY4                   1.346e+00  5.346e-01   2.518  0.01179 *  
## TYPEFORNITURE              6.005e-01  4.913e-01   1.222  0.22168    
## TYPENEW.CAR                2.403e-01  4.616e-01   0.521  0.60261    
## TYPERADIO/TV               1.251e+00  4.835e-01   2.587  0.00967 ** 
## TYPERETRAINING             5.869e-01  5.595e-01   1.049  0.29422    
## TYPEUSED.CAR               1.638e+00  5.790e-01   2.828  0.00468 ** 
## SAV_ACCT1                  3.586e-01  3.568e-01   1.005  0.31496    
## SAV_ACCT2                  5.548e-01  4.984e-01   1.113  0.26569    
## SAV_ACCT3                  1.694e+00  6.851e-01   2.473  0.01340 *  
## SAV_ACCT4                  9.068e-01  3.011e-01   3.012  0.00259 ** 
## AGE                        1.538e-02  1.109e-02   1.386  0.16574    
## PRESENT_RESIDENT1 a 2     -8.453e-01  3.579e-01  -2.362  0.01817 *  
## PRESENT_RESIDENT2 a 3     -2.839e-01  4.073e-01  -0.697  0.48571    
## PRESENT_RESIDENTmayor a 3 -4.857e-01  3.464e-01  -1.402  0.16079    
## PROP_UNKN_NONESi          -5.395e-01  3.096e-01  -1.743  0.08138 .  
## EMPLOYMENT1               -3.203e-01  5.135e-01  -0.624  0.53280    
## EMPLOYMENT2                4.519e-01  5.018e-01   0.901  0.36782    
## EMPLOYMENT3                7.704e-01  5.432e-01   1.418  0.15613    
## EMPLOYMENT4                3.789e-01  5.002e-01   0.757  0.44882    
## JOBNo calificado          -1.558e-01  8.246e-01  -0.189  0.85015    
## JOBCalificado             -1.969e-01  7.964e-01  -0.247  0.80472    
## JOBGerente-Autónomo        5.646e-02  8.059e-01   0.070  0.94415    
## INSTALL_RATE              -3.656e-01  1.052e-01  -3.475  0.00051 ***
## GUARANTORSi                5.453e-01  4.898e-01   1.113  0.26563    
## FOREIGNSi                  1.909e+00  8.545e-01   2.234  0.02551 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 837.01  on 683  degrees of freedom
## Residual deviance: 624.61  on 650  degrees of freedom
## AIC: 692.61
## 
## Number of Fisher Scoring iterations: 5

AIC = $692.61$
Null deviance = $837.01$

Matriz de confusion

y3_fit<-as.factor(ifelse(model3$fitted.values>0.45,"Si","No"))
confusionMatrix(train$RESPONSE,y3_fit)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  No  Si
##         No  95 111
##         Si  38 440
##                                           
##                Accuracy : 0.7822          
##                  95% CI : (0.7493, 0.8126)
##     No Information Rate : 0.8056          
##     P-Value [Acc > NIR] : 0.9429          
##                                           
##                   Kappa : 0.4245          
##                                           
##  Mcnemar's Test P-Value : 3.669e-09       
##                                           
##             Sensitivity : 0.7143          
##             Specificity : 0.7985          
##          Pos Pred Value : 0.4612          
##          Neg Pred Value : 0.9205          
##              Prevalence : 0.1944          
##          Detection Rate : 0.1389          
##    Detection Prevalence : 0.3012          
##       Balanced Accuracy : 0.7564          
##                                           
##        'Positive' Class : No              
##

Tenemos una presición de $78.22%$ no supera al modelo 2. La sensibilidd se mantiene en buen comportamiento con la especificidad.

R-cuadrado

library(sigr)
R2 <- wrapChiSqTest(model3)
R2$pseudoR2

## [1] 0.2537628

Deviance

library(broom)

broom::glance(model3) %>%
  summarize( deviance)

## # A tibble: 1 x 1
##   deviance
##      <dbl>
## 1     625.

Predicciones

y_pred<-predict(model3, newdata = test , type="response")
y_pred<- as.factor(ifelse(y_pred>0.5,"Si","No"))
confusionMatrix(test$RESPONSE,y_pred)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  No  Si
##         No  46  41
##         Si  27 177
##                                           
##                Accuracy : 0.7663          
##                  95% CI : (0.7134, 0.8137)
##     No Information Rate : 0.7491          
##     P-Value [Acc > NIR] : 0.2738          
##                                           
##                   Kappa : 0.4156          
##                                           
##  Mcnemar's Test P-Value : 0.1149          
##                                           
##             Sensitivity : 0.6301          
##             Specificity : 0.8119          
##          Pos Pred Value : 0.5287          
##          Neg Pred Value : 0.8676          
##              Prevalence : 0.2509          
##          Detection Rate : 0.1581          
##    Detection Prevalence : 0.2990          
##       Balanced Accuracy : 0.7210          
##                                           
##        'Positive' Class : No              
##

Podemos ver que la presición en el conjunto de datos test no cambia mucho en relación con los datos train, y la sensibilidad empieza a verse un poco afectada en contraste con la especificidad.

Bondad de Ajuste

Curvas ROC

Modelo 2

Baja capacidad discriminante: $ [0.5, 0.7).$
Capacidad discriminante útil: $ [0.7, 0.9).$
Alta capacidad discriminante: $ [0.9, 1].$

library(InformationValue)
plotROC(as.numeric(ifelse(train$RESPONSE=="Si",1,0)),model2$fitted.values)

MOdelo 3

plotROC(as.numeric(ifelse(train$RESPONSE=="Si",1,0)),model3$fitted.values)

Ks y Ks-PLOT

Modelo 2

Para estudiar la eficacia del modelo podemos también análisar el estadístico Ks de Kolmogorov: + un Ks < 0.2 la eficacia es baja + 0.2< ks <0.7 : buena eficacia + ks> 0.7 : puede existir un sobreajuste

Por tanto, cuánto mayor sea el valor del AUC mejor será la capacidad discriminante y se obtienen mejores resultados.

ks_stat(as.numeric(ifelse(train$RESPONSE=="Si",1,0)),model2$fitted.values)

## [1] 0.5271

ks_plot(as.numeric(ifelse(train$RESPONSE=="Si",1,0)),model2$fitted.values)

Modelo 3

ks_stat(as.numeric(ifelse(train$RESPONSE=="Si",1,0)),model3$fitted.values)

## [1] 0.4993

ks_plot(as.numeric(ifelse(train$RESPONSE=="Si",1,0)),model3$fitted.values)

Índice de Gini

El Índice de gini viende dado por: \[ Gini= 2*AUC -1 \]

El rango de valores del coeficiente de Gini es [0, 1]. Cuanto más cerca esté el coeficiente a uno, mejor será la separación de los clientes morosos y de los no morosos.

Modelo 2

AUC<-0.8432
GINI<- 2*AUC - 1
GINI

## [1] 0.6864

Modelo 3

AUC<-0.8224
GINI<- 2*AUC - 1
GINI

## [1] 0.6448

Así, concluimos que nuestro mejor modelo es el Modelo 2.

Score Card

Una vez obtenido un modelo adecuado, se debe proceder a realizar una score-card.

y_fit_end<-predict(model3, Datos, type="response")
DataFin<-data.frame(Datos, y_fit_end) %>% rename(y_fit=y_fit_end)
knitr::kable(head(DataFin))

CHK_ACCT	DURATION	HISTORY	AMOUNT	SAV_ACCT	EMPLOYMENT	INSTALL_RATE	CO.APPLICANT	GUARANTOR	PRESENT_RESIDENT	REAL_ESTATE	PROP_UNKN_NONE	AGE	OTHER_INSTALL	RENT	OWN_RES	NUM_CREDITS	JOB	NUM_DEPENDENTS	TELEPHONE	FOREIGN	RESPONSE	TYPE	Civil	y_fit
0 DM	6	4	1169	4	4	4	No	No	mayor a 3	Si	No	67	No	No	Si	2	Calificado	1	Si	No	Si	RADIO/TV	M-single	0.9480474
0 A 200DM	48	2	5951	0	2	2	No	No	1 a 2	Si	No	22	No	No	Si	1	Calificado	1	No	No	No	RADIO/TV	other	0.3973955
No tiene	12	4	2096	0	3	2	No	No	2 a 3	Si	No	49	No	No	Si	1	No calificado	2	No	No	Si	EDUCATION	M-single	0.9557696
0 DM	42	2	7882	0	3	2	No	Si	mayor a 3	No	No	45	No	No	No	1	Calificado	2	No	No	Si	FORNITURE	M-single	0.5742962
0 DM	24	3	4870	0	2	3	No	No	mayor a 3	No	Si	53	No	No	No	2	Calificado	2	No	No	No	NEW.CAR	M-single	0.2876637
No tiene	36	2	9055	4	2	2	No	No	mayor a 3	No	Si	35	No	No	No	1	No calificado	2	Si	No	Si	EDUCATION	M-single	0.6597635

ggplot(DataFin, aes(x=y_fit)) + geom_density()

La scorcard se construye con los estimadores de los parámetros de la regresión logística. Los puntajes del score son resultado de un reescalamiento y una traslación del modelo logístico, dado por la ecuación:

\[ Score = Offset + Factor · ln(odds) \]

Donde Offset es un término de traslación (o compensación) y Factor es un término de reescalamiento. Offset y Factor deben satisfacer condiciones impuestas por la empresa de crédito.

ver más en este link http://mat.izt.uam.mx/mcmai/documentos/tesis/Gen.07-O/Nieto-S-Tesis.pdf.

Se acostumbra a calibrar la scorecard de tal manera que cada cierto incremento en el puntaje P0, se obtenga el doble de la relación buenos/malos.

Para obtener los valores de Offset y Factor se resuelve el siguiente sistema de ecuaciones \[Score = Offset + Factor · ln(odds)\] \[Score + P0 = Offset + Factor · ln(2 · odds)\] de aquí obtenemos: \[Factor = P0/ln(2)\] \[Offset = Score − Factor · ln(Odds)\]

Cálculo de la score-card

Por ejemplo si consideramos que un Odds de 1:1 equivale a 600 puntos en la scorecard, que los odds se duplican cada P0 = 80 puntos en la scorecard; es decir, que 680 puntos equivalen a un odds de 2:1, a los 760 puntos equivalen a 4:1 y as´ı sucesivamente. Entonces los valores de Factor y Offset quedan como: \[Factor = 80/ln(2) = 115.4156;\] \[Offset = 600 − 115.4156 · ln(1) = 600\] Con esto se obtiene la funci´on de score dada por

\[Score = 600 + 115.416 · ln(odds).\]

Así nuestro Score para cada solicitud en nuestro conjunto de datos queda de la siguiente forma:

El odds asociado a un evento es el cociente entre la probabilidad de que ocurra con la probabilidad de que no ocurra. \[odss = pi/1 − pi\]

Odds<-(DataFin$y_fit/(1-DataFin$y_fit))
Score=600+145.416*log(Odds)
knitr::kable(head(DataFin))

CHK_ACCT	DURATION	HISTORY	AMOUNT	SAV_ACCT	EMPLOYMENT	INSTALL_RATE	CO.APPLICANT	GUARANTOR	PRESENT_RESIDENT	REAL_ESTATE	PROP_UNKN_NONE	AGE	OTHER_INSTALL	RENT	OWN_RES	NUM_CREDITS	JOB	NUM_DEPENDENTS	TELEPHONE	FOREIGN	RESPONSE	TYPE	Civil	y_fit
0 DM	6	4	1169	4	4	4	No	No	mayor a 3	Si	No	67	No	No	Si	2	Calificado	1	Si	No	Si	RADIO/TV	M-single	0.9480474
0 A 200DM	48	2	5951	0	2	2	No	No	1 a 2	Si	No	22	No	No	Si	1	Calificado	1	No	No	No	RADIO/TV	other	0.3973955
No tiene	12	4	2096	0	3	2	No	No	2 a 3	Si	No	49	No	No	Si	1	No calificado	2	No	No	Si	EDUCATION	M-single	0.9557696
0 DM	42	2	7882	0	3	2	No	Si	mayor a 3	No	No	45	No	No	No	1	Calificado	2	No	No	Si	FORNITURE	M-single	0.5742962
0 DM	24	3	4870	0	2	3	No	No	mayor a 3	No	Si	53	No	No	No	2	Calificado	2	No	No	No	NEW.CAR	M-single	0.2876637
No tiene	36	2	9055	4	2	2	No	No	mayor a 3	No	Si	35	No	No	No	1	No calificado	2	Si	No	Si	EDUCATION	M-single	0.6597635

Punto de Corte

Cuando se tiene los datos de un nuevo solicitante, se calcula su score y con el resultado se decide si se le otorga o no el cr´edito. Si score > a se otorga el crédito, en caso contrario si score ≤ a se rechaza la solicitud. El punto “a” se conoce como punto de corte o Cut Off y es importante determinarlo para optimizar la decisión

En nuestro caso se ah tomado el punto de corte p>06

Aprobacion<-predict(model3, newdata = Datos, type="response")
Aprobacion<-ifelse(Aprobacion>0.6,"Aprobado","Denegado")
DataFin<-data.frame(DataFin,Score, Aprobacion)
knitr::kable(head(DataFin))

CHK_ACCT	DURATION	HISTORY	AMOUNT	SAV_ACCT	EMPLOYMENT	INSTALL_RATE	CO.APPLICANT	GUARANTOR	PRESENT_RESIDENT	REAL_ESTATE	PROP_UNKN_NONE	AGE	OTHER_INSTALL	RENT	OWN_RES	NUM_CREDITS	JOB	NUM_DEPENDENTS	TELEPHONE	FOREIGN	RESPONSE	TYPE	Civil	y_fit	Score	Aprobacion
0 DM	6	4	1169	4	4	4	No	No	mayor a 3	Si	No	67	No	No	Si	2	Calificado	1	Si	No	Si	RADIO/TV	M-single	0.9480474	1022.2987	Aprobado
0 A 200DM	48	2	5951	0	2	2	No	No	1 a 2	Si	No	22	No	No	Si	1	Calificado	1	No	No	No	RADIO/TV	other	0.3973955	539.4591	Denegado
No tiene	12	4	2096	0	3	2	No	No	2 a 3	Si	No	49	No	No	Si	1	No calificado	2	No	No	Si	EDUCATION	M-single	0.9557696	1046.8785	Aprobado
0 DM	42	2	7882	0	3	2	No	Si	mayor a 3	No	No	45	No	No	No	1	Calificado	2	No	No	Si	FORNITURE	M-single	0.5742962	643.5378	Denegado
0 DM	24	3	4870	0	2	3	No	No	mayor a 3	No	Si	53	No	No	No	2	Calificado	2	No	No	No	NEW.CAR	M-single	0.2876637	468.1429	Denegado
No tiene	36	2	9055	4	2	2	No	No	mayor a 3	No	Si	35	No	No	No	1	No calificado	2	Si	No	Si	EDUCATION	M-single	0.6597635	696.3003	Aprobado

ggplot(DataFin,aes(y=y_fit,x=c(1:nrow(DataFin)),col=Aprobacion)) + geom_point()

Teoría de Desición

Ahora, una vez obtenida la probabilidad de Default de una solicitud, es importante analizar ciertos aspectos como, el monto que está solicitando el cliente, la tasa de interés que se va a aplicare incluso se podría tomar en cuenta también el timpo de duración.

Si suponemos 3 clientes A ,B y C, de los cuales los montos del prestamo son $25000\$$ , $50000\$$ , $75000\$$ , respectivamente, una vez receptada su petición de crédito obtenemos las siguientes probabilidades de default 0.6, 0.75 ,0.8 respectivamente. Dadas las probabilidades podríamos pensar que el cliente A talvés no me cancele el préstamo, el cliente B si me puede cancelar y el cliente C más seguramente que si lo haga. Sin embargo que sucede, el cliente C pese a tener una buena probabilidad el monto que me solicita es muy alto y si en caso de no poder completar la devolución del préstamo la entidad debe hacerce responsable del préstamo y eso afecta a la líquidez de la institución.

Debido a esto, análizaremos una herramienta que nos ayude a tomar una mejor desición de otorgamiento de préstamo, conciderando la máxima pérdida y máximo retorno que deseamos tener.

Nuevos Clientes

De nuestro conjunto de datos vamos a extraer al azar 10 nuevos clientes.

indexnew<-sample(1:nrow(Datos),10, replace = TRUE)
NuevosClientes<-Datos[indexnew,]
knitr::kable(NuevosClientes)

	CHK_ACCT	DURATION	HISTORY	AMOUNT	SAV_ACCT	EMPLOYMENT	INSTALL_RATE	CO.APPLICANT	GUARANTOR	PRESENT_RESIDENT	REAL_ESTATE	PROP_UNKN_NONE	AGE	OTHER_INSTALL	RENT	OWN_RES	NUM_CREDITS	JOB	NUM_DEPENDENTS	TELEPHONE	FOREIGN	RESPONSE	TYPE	Civil
143	0 DM	27	2	3416	0	2	3	No	No	1 a 2	No	No	27	No	No	Si	1	Gerente-Autónomo	1	No	No	Si	RADIO/TV	M-single
355	No tiene	10	2	727	2	4	4	No	No	mayor a 3	No	Si	46	No	No	No	1	Calificado	1	Si	No	Si	EDUCATION	M-single
611	0 DM	12	2	741	1	0	4	No	No	2 a 3	No	No	22	No	No	Si	1	Calificado	1	No	No	No	NEW.CAR	other
647	0 DM	30	0	4583	0	2	2	No	Si	1 a 2	Si	No	32	No	No	Si	2	Calificado	1	No	No	Si	FORNITURE	Male_div
965	0 A 200DM	6	2	454	0	1	3	No	No	0 a 1	No	No	22	No	No	Si	1	No calificado	1	No	No	Si	NEW.CAR	M.mar.wid
986	0 DM	15	4	1433	0	2	4	No	No	2 a 3	No	No	25	No	Si	No	2	Calificado	1	No	No	Si	FORNITURE	other
836	0 DM	12	0	1082	0	2	4	No	No	mayor a 3	No	No	48	Si	No	Si	2	Calificado	1	No	No	No	NEW.CAR	M-single
794	mayor a200	24	2	2892	0	4	3	No	No	mayor a 3	No	Si	51	No	No	No	1	Calificado	1	No	No	Si	FORNITURE	Male_div
224	No tiene	24	3	2978	4	2	4	No	No	mayor a 3	Si	No	32	No	No	Si	2	Calificado	2	Si	No	Si	RETRAINING	M-single
876	0 A 200DM	11	4	1322	3	2	4	No	No	mayor a 3	No	No	40	No	No	Si	2	Calificado	1	No	No	Si	NEW.CAR	other

Vamos a obtener sus probabilidades

probabilidades<-predict(model3, newdata = NuevosClientes, type="response")
probabilidades

##       143       355       611       647       965       986       836       794 
## 0.5426920 0.7558247 0.4037819 0.3642955 0.5113251 0.6650509 0.3209732 0.5461166 
##       224       876 
## 0.8651917 0.9166375

Vamos a suponer los montos que nos solicitan y las tasas de interés.

montos<-c(10000,50000,70000,25000,5000,90000,15000,45000,100000,1000)
tasas<-c(0.16, 0.12, 0.06 , 0.04 , 0.08, 0.05 , 0.08)
interes<-sample(tasas,10,replace = TRUE)

El siguiente paso es extraer los valores de la matriz de confusion de nuestro modelo.

yfin<-predict(model3, newdata = Datos,type="response")
yfinclass<-as.factor(ifelse(yfin>0.63,"Si","No"))
CM<-as.matrix(prop.table(table(yfinclass,Datos$RESPONSE),2))
CM

##          
## yfinclass        No        Si
##        No 0.6655290 0.2038123
##        Si 0.3344710 0.7961877

Matriz P*

Para cada individuo necesitamos calcular las siguientes probabilidades:

Probabilidad que el modelo me dice que es un buen pagador dado que es buen pagador.

\[ P(MdP | P) \] Probabilidad que el modelo me dice que es un buen pagador dado que no es buen pagador. \[P(MdP| N P) \] Probabilidad que el modelo me dice que no es un buen pagador dado que es buen pagador. \[ P(MdNP| P) \] Probabilidad que el modelo me dice que no es un buen pagador dado que no es buen pagador. \[ P(MdNP | N P) \]

p_techo<-function(CM,y)
{
  VP<-CM[4]
  FP<-CM[2]
  VN<-CM[1]
  FN<-CM[3]
  P_Y1_yf1<-NULL
  P_Y0_yf1<-NULL
  P_Y1_yf0<-NULL
  P_Y0_yf0<-NULL
  for (i in 1: length(y)) {
    p<-y[i]
    q<-(1-y[i])
    P_Y1_yf1[i]<-VP*p/(VP*p + FP*q)      
    P_Y0_yf1[i]<-FP*p/(VP*p + FP*q)   
    P_Y1_yf0[i]<-FN*p/(FN*p + VN*q) 
    P_Y0_yf0[i]<-VN*p/(FN*p + VN*q) 
  }
  P<-data.frame(P_Y1_yf1,P_Y0_yf1,P_Y1_yf0,P_Y0_yf0)
  return(P)

}

knitr::kable(head(p_techo(CM,probabilidades)))

P_Y1_yf1	P_Y0_yf1	P_Y1_yf0	P_Y0_yf0
0.7385546	0.3102599	0.2665500	0.8703926
0.8805036	0.3698913	0.4866383	1.5890694
0.6171699	0.2592673	0.1717729	0.5609073
0.5770113	0.2423971	0.1492938	0.4875040
0.7135305	0.2997475	0.2426740	0.7924282
0.8253711	0.3467307	0.3781290	1.2347428

Ahora, calculamos la perdida o ganancia esperada dado el monto y la tasa de interés.

beneficio<-function(Montos,interes,probabilidades,CM)
  {
    P<-p_techo(CM,probabilidades)
    paga<- NULL
    No_paga<-NULL
    for (i in 1:length(probabilidades)) {
    
        paga[i]<-Montos[i]*(1+interes[i])*P[i,1]
        No_paga[i]<-(-Montos[i]*P[i,2])
    }
    Data<-data.frame(Montos,Interes=Montos*(interes), tasa=interes, Retorno_esperado=paga,Perdida_esperada=No_paga,Beneficio=paga+No_paga)
   
    return(Data)
  }
  
knitr::kable(beneficio(montos,interes, probabilidades,CM))

Montos	Interes	tasa	Retorno_esperado	Perdida_esperada	Beneficio
10000	1200	0.12	8271.812	-3102.5988	5169.2130
50000	4000	0.08	47547.196	-18494.5663	29052.6293
70000	3500	0.05	45361.987	-18148.7103	27213.2764
25000	2000	0.08	15579.306	-6059.9264	9519.3795
5000	250	0.05	3746.035	-1498.7373	2247.2976
90000	7200	0.08	80226.072	-31205.7606	49020.3111
15000	600	0.04	8259.596	-3336.3257	4923.2698
45000	2700	0.06	35355.808	-14011.9280	21343.8795
100000	5000	0.05	98549.383	-39428.2599	59121.1231
1000	80	0.08	1040.257	-404.6318	635.6255

Para finalmente tomar una decisión sobre a cuál de los 10 clientes prestarles podemos obtener un indicador del beneficio respecto al mónto. Así, mientras mayor sea el indicador implica la desición de otorgar el préstamo.

benef<-beneficio(montos,interes, probabilidades,CM)
Indicador<-benef$Beneficio/benef$Montos
benef<-data.frame(benef,Indicador)
knitr::kable(benef)

Montos	Interes	tasa	Retorno_esperado	Perdida_esperada	Beneficio	Indicador
10000	1200	0.12	8271.812	-3102.5988	5169.2130	0.5169213
50000	4000	0.08	47547.196	-18494.5663	29052.6293	0.5810526
70000	3500	0.05	45361.987	-18148.7103	27213.2764	0.3887611
25000	2000	0.08	15579.306	-6059.9264	9519.3795	0.3807752
5000	250	0.05	3746.035	-1498.7373	2247.2976	0.4494595
90000	7200	0.08	80226.072	-31205.7606	49020.3111	0.5446701
15000	600	0.04	8259.596	-3336.3257	4923.2698	0.3282180
45000	2700	0.06	35355.808	-14011.9280	21343.8795	0.4743084
100000	5000	0.05	98549.383	-39428.2599	59121.1231	0.5912112
1000	80	0.08	1040.257	-404.6318	635.6255	0.6356255

Modelo de otorgamiento de crédito

Modelo de otorgamiento de crédito

AD Science Analytics

Descripción

Conjunto de datos

Minería de datos

Limpieza, transformación y discretización de datos

Tratamiento de atípicos

Anális univariante y Multivariante

Univariante

Multivariante

Selección de variables

Valor de información IV

Árboles de clasificación

Partición de datos

Balanceo de Datos

Modelos de Regresión Logística

Modelo 1

Modelo 2

Modelo 3

Bondad de Ajuste

Curvas ROC

Ks y Ks-PLOT

Índice de Gini

Score Card

Cálculo de la score-card

Teoría de Desición

Nuevos Clientes

Matriz P*