Unidad 3 - Modelo de regresión logístico

Universidad Pontificia Javeriana Cali

Métodos estadísticos para la toma de decisiones

Problema 2 : Créditos

Catalina Gómez Vallejo

Se trabajo con la base de datos “Creditos” del paqueteMOD

library(dplyr)
library(readxl)
creditos <- read_excel("C:/Users/Cata/Desktop/MAESTRIA CD/5. Metodos estadisticos/Regresion logistica/creditos.xlsx")
require(table1)
table1(~. |default, data=creditos, topclass="Rtable1-zebra")

	0 (N=741)	1 (N=39)	Overall (N=780)
antiguedad
Mean (SD)	18.2 (11.9)	14.5 (11.6)	18.0 (11.9)
Median [Min, Max]	15.5 [0.255, 37.3]	9.99 [1.37, 37.3]	15.1 [0.255, 37.3]
edad
Mean (SD)	57.1 (12.5)	55.2 (12.4)	57.0 (12.5)
Median [Min, Max]	58.0 [26.6, 92.4]	53.7 [30.4, 78.9]	57.9 [26.6, 92.4]
cuota
Mean (SD)	869000 (727000)	1200000 (911000)	885000 (740000)
Median [Min, Max]	674000 [387, 6660000]	1070000 [34400, 3520000]	694000 [387, 6660000]
ingresos
Mean (SD)	5400000 (2680000)	4650000 (2050000)	5370000 (2650000)
Median [Min, Max]	5040000 [634000, 22200000]	4800000 [1020000, 8640000]	5040000 [634000, 22200000]

t.test(creditos$antiguedad~creditos$default)$p.value

## [1] 0.05992064

t.test(creditos$edad~creditos$default)$p.value

## [1] 0.3516148

t.test(creditos$cuota~creditos$default)$p.value

## [1] 0.03274539

t.test(creditos$ingresos~creditos$default)$p.value

## [1] 0.03281113

Con base en el valor p de la prueba t, se puede considerar que existe diferencia entre las medias de las variables cuotas e ingresos para los grupos de cumplimiento e incumplimiento de pago; por lo cual, se ajustara un modelo de regresión logistica que permita predecir el riesgo de default es función de estas dos covariables.

require(caret)
control=trainControl(method = "cv", number = 10, p=0.2)
mod1=train(default~ cuota + ingresos, data=creditos, method="glm", family="binomial", trControl=control)
summary(mod1)

## 
## Call:
## NULL
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -0.6901  -0.3648  -0.2928  -0.2113   2.9753  
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept) -2.353e+00  3.966e-01  -5.933 2.97e-09 ***
## cuota        9.341e-07  2.404e-07   3.885 0.000102 ***
## ingresos    -3.134e-07  1.005e-07  -3.119 0.001817 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 309.68  on 779  degrees of freedom
## Residual deviance: 291.37  on 777  degrees of freedom
## AIC: 297.37
## 
## Number of Fisher Scoring iterations: 6

A un nivel de significancia del 5%, el intercepto y las variables cuota e ingresos influyen significativamente en la predicción del riesgo de default. Se tiene que:

• A mayor valor de cuota mayor posibilidad de incumplimiento en el pago.
• A mayor valor de ingresos menor posibilidad de incumplimiento en el pago.

varImp(mod1)

## glm variable importance
## 
##          Overall
## cuota        100
## ingresos       0

plot(varImp(mod1))

La variable que mas discriminan la posibilidad de incumplimiento en el pago es el valor de la cuota.

Se toma como umbral la proporcion de default de los datos (0.05)

Pred=predict(mod1, creditos)
Pred_modelo=as.factor(ifelse(Pred>0.05,"1","0"))
Pred_real=as.factor(creditos$default)
confusionMatrix(Pred_modelo,Pred_real)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction   0   1
##          0 429  13
##          1 312  26
##                                           
##                Accuracy : 0.5833          
##                  95% CI : (0.5478, 0.6182)
##     No Information Rate : 0.95            
##     P-Value [Acc > NIR] : 1               
##                                           
##                   Kappa : 0.053           
##                                           
##  Mcnemar's Test P-Value : <2e-16          
##                                           
##             Sensitivity : 0.57895         
##             Specificity : 0.66667         
##          Pos Pred Value : 0.97059         
##          Neg Pred Value : 0.07692         
##              Prevalence : 0.95000         
##          Detection Rate : 0.55000         
##    Detection Prevalence : 0.56667         
##       Balanced Accuracy : 0.62281         
##                                           
##        'Positive' Class : 0               
## 

El modelo esta clasificando bien aproximadamente el 58% de los creditos, y de la cantidad de creditos que incurrieron en no pago clasifico correctamente el 67% aproximadamente.

library(caTools)
colAUC(Pred, Pred_real, plotROC = TRUE)

##              [,1]
## 0 vs. 1 0.6791238

De acuerdo al área comprendida entre la curva ROC y el AUC (0.6791238), se puede considerar que el modelo de predicción tiene un ajuste aceptable.