Examen Procesos 2
MODELO LOGIT
Enmarcando una regresión lineal normal se puede indicar que el análisis logit es, en muchos sentidos, el complemento natural de la regresión lineal ordinaria siempre que la regresión no sea una variable continua sino un estado que puede o no contener, o una categoría en una clasificación dada. Cuando tales variables discretas ocurren entre las variables independientes o regresores de una ecuación de regresión, se tratan mediante la introducción de una o varias variables ficticias (0, 1), pero cuando la variable dependiente pertenece a este tipo, el modelo de regresión se descompone y resulta un sin sentido. El análisis logit o la regresión logística (que son dos nombres para el mismo método) proporciona una alternativa lista. A primera vista, es bastante diferente del modelo familiar de regresión lineal, y ligeramente aterrador por su aparente complejidad; Sin embargo, los dos modelos tienen mucho en común.
Primero, ambos modelos pertenecen al ámbito de las relaciones causales, en oposición a la asociación estadística; existe una clara asimetría a priori entre las variables independientes con nombres extraños, los regresores o covariables, que son las variables explicativas o determinantes, y la variable dependiente o el resultado. Ambos modelos fueron diseñados inicialmente para el análisis de datos experimentales, o al menos para datos donde la dirección de la causalidad no está en duda. Al interpretar aplicaciones empíricas, a menudo es útil tener en cuenta estos orígenes.
Dentro de este contexto causal, el modelo de regresión lineal ordinario ofrece un marco burdo pero casi universal para el análisis empírico. Es cierto que a menudo no es más que una aproximación simplificada a otra cosa que presumiblemente sería mejor. Pero sirve, dentro de sus limitaciones, para la detección empírica de la evidencia. La regresión logística se puede usar de la misma manera para fenómenos categóricos.
Por supuesto, también hay diferencias. A diferencia de la regresión, el modelo logit permite una interpretación financiera específica en términos de probabilidades en situaciones de elección discreta. Entre los economistas, esto confiere un estatus más alto en el modelo que el de un dispositivo empírico conveniente, aunque hay otros de mayor complejidad y mejores, el modelo sirve para a modo introducctorio se amplie el conocimiento sobre esta familia de modelos. Ademas hay una sutil distinción en que el modelo de regresión ordinario requiere un término de perturbación que se adhiere a la parte sistemática como una molestia necesaria (el error), mientras que en el modelo logit el carácter aleatorio del resultado es una parte integral de la especificación inicial. Junto con el modelo probit, el modelo logit pertenece a la clase de modelos de probabilidad que determinan probabilidades discretas sobre un número limitado de resultados posibles, tambien es de notarse que al igual que el modelo de regresión, el modelo logit permite todo tipo de extensiones y variantes bastante sofisticadas.
Modelo Formal
Para trabajar el modelo formalmente se tiene que tener preconceptos estadisticos y de probabilidad asimilados, por ejemplo según la delimitación teórica dada anteriormente al tratar con variables discretas el modelo Logit se asociara a una distribución de datos discreta como definimos en nuestro caso (existe el modelo logit multinomial donde se puede asumir una distribución normal sin embargo seguiremos el modelo mas simple):
\[y \mid x \beta \text{ } \sim \text{ } \text{Binomial} (1-\rho)\]
Despues de operar matemáticamente la delimitación brindada (debido a que es un tema avanzado no se tratará en el curso) podemos llegar a la siguiente ecuación:
\[E(y)= \rho = \dfrac{e^{x \beta}}{1+e^{x \beta}} = \dfrac{e^{\beta_0+\beta_1 x_1+ \ldots + \beta_n x_n}}{1+e^{\beta_0+\beta_1 x_1+ \ldots + \beta_n x_n}}\]
Donde:
\[y=0 \rightarrow 1-\rho\]
\[y=1 \rightarrow \rho\]
Operando:
\[\rho = \dfrac{e^{\beta x}}{1+e^{\beta x}}\]
\[\rho + \rho e^{ \beta x} = e^{ \beta x}\]
\[\rho = e^{ \beta x} - \rho e^{ \beta x}\]
\[\rho = (1 - \rho) e^{\beta x}\]
\[\dfrac{\rho}{1 - \rho} = e^{\beta x}\]
Se llega al siguiente resultado:
\[\log(\dfrac{\rho}{1 - \rho})= \beta x = \beta_0+\beta_1 x_1+ \ldots + \beta_n x_n\]
Importación de los Datos
Los paquetes que se usaran son los siguientes:
pkges<-c("mfx","pROC","tidyverse","forecast","data.table")
#install.packages("pkges")
lapply(pkges,library,character.only=T)## [[1]]
## [1] "mfx" "betareg" "MASS" "lmtest" "zoo" "sandwich"
## [7] "stats" "graphics" "grDevices" "utils" "datasets" "methods"
## [13] "base"
##
## [[2]]
## [1] "pROC" "mfx" "betareg" "MASS" "lmtest" "zoo"
## [7] "sandwich" "stats" "graphics" "grDevices" "utils" "datasets"
## [13] "methods" "base"
##
## [[3]]
## [1] "forcats" "stringr" "dplyr" "purrr" "readr" "tidyr"
## [7] "tibble" "ggplot2" "tidyverse" "pROC" "mfx" "betareg"
## [13] "MASS" "lmtest" "zoo" "sandwich" "stats" "graphics"
## [19] "grDevices" "utils" "datasets" "methods" "base"
##
## [[4]]
## [1] "forecast" "forcats" "stringr" "dplyr" "purrr" "readr"
## [7] "tidyr" "tibble" "ggplot2" "tidyverse" "pROC" "mfx"
## [13] "betareg" "MASS" "lmtest" "zoo" "sandwich" "stats"
## [19] "graphics" "grDevices" "utils" "datasets" "methods" "base"
##
## [[5]]
## [1] "data.table" "forecast" "forcats" "stringr" "dplyr"
## [6] "purrr" "readr" "tidyr" "tibble" "ggplot2"
## [11] "tidyverse" "pROC" "mfx" "betareg" "MASS"
## [16] "lmtest" "zoo" "sandwich" "stats" "graphics"
## [21] "grDevices" "utils" "datasets" "methods" "base"Para el desarrollo de la Practica 2 se tiene que usar la data brindada en clase por ello procedemos a importarla:
options(scipen=999) #Esta parte del código permite que los valores que aparezcan posteriormente ya no se muestren con notacion cienfitica
#importando datos
datos <- read.csv("C:/Users/usuario/Desktop/Tareas de riesgos/Modelo Logit/UCI_Credit_Card.csv", header=TRUE)
#usando solo los datos completos
datos <- datos[complete.cases(datos),]
#preparamos la data para modelar quitando el id
cred <- datos[,-1]
#definimos las variables categóricas
cred$SEX <- as.factor(cred$SEX)
cred$MARRIAGE <- as.factor(cred$MARRIAGE)
cred$EDUCATION <- as.factor(cred$EDUCATION)
cred$PAY_0 <- as.factor(cred$PAY_0)
cred$PAY_2 <- as.factor(cred$PAY_2)
cred$PAY_3 <- as.factor(cred$PAY_3)
cred$PAY_4 <- as.factor(cred$PAY_4)
cred$PAY_5 <- as.factor(cred$PAY_5)
cred$PAY_6 <- as.factor(cred$PAY_6)La data importada brinda información de clientes poseedores de tarjetas de crédito, por ello se hara una breve descripción de cada variable:
• ID: ID del cliente
• LIMIT_BAL: Hace referencia a la linea de credito que tiene cada TC
• SEX: Hace referencia al genero del cliente (1=masculino, 2=femenino)
• EDUCATION: Hace referencia al nivel educativo del cliente (1=Posgrado, 2=Universitario, 3=Secundaria completa, 4=otras, 5=desconocido, 6=desconocido)
• MARRIAGE: Hace referencia al Estado Civil (1=casado, 2=soltero, 3=otros)
• AGE: Edad en Años
• PAY_(i): Estado del repago a septiembre(Abril, Mayo, Junio, Julio y Agosto), 2005
-1=pago debidamente,
1=pago con un mes de retraso,
2=pago con dos meses de retraso,
8=pago con ocho meses de retraso,
9=pago con nueve meses de retraso y mas
• BILL_AMT(i): Importe del estado de cuenta en Septiembre, 2005 (Abril, Mayo, Junio, Julio y Agosto)
• PAY_AMT(i): Importe del pago anterior en Septiembre, 2005 (Abril, Mayo, Junio, Julio y Agosto)
• default.payment.next.month: Incumplimiento de Pago (1=si, 0=no)
Análisis de los Datos
La finalidad del presente documento es generar un modelo Logit factible con 5 variables, para este fin es necesario tener un análisis de los datos para tener una noción sobre que variables incluir en el modelo.
• LIMIT_BAL
La linea de crédito asociada a una tarjeta de crédito juega un papel teórico importante en el desempeño de la morosidad, este resultado es medianamente ambiguo en dos aspectos, en primera instancia ante un aumento de la linea de crédito los clientes tienen el incentivo a endeudarse más, lo que en efectos prácticos implica una mayor posibilidad de impago; por otro lado se tiene que las lineas de crédito no solo se otorgan por el poder adquisitivo del cliente, hay otros factores por los cuales los bancos deciden hacer un “Upgrate” (aumento de la linea de crédito), tales como el cumplimiento de la deuda y el historial crediticio completo. Ahora procederemos a analizar la data:
boxplot(datos$LIMIT_BAL ~ datos$default.payment.next.month, col = "gray",
main = "Monto de la Linea de Crédito vs La Probabilidad de Impago")
Al tener una variable cuantitativa discreta y una variable categórica procedemos a realizar un gráfico “box” que compara estas dos variables, como se observa en el gráfico, los valores del monto de linea crediticia asociada al cumplimiento o incumplimiento son poco distantes entre si, aunque como se puede notar, las personas con mayor linea crediticia tienen menos incumplimiento.
• SEX
La variable sexo en multiples estudios del crédito se asocia con el nivel de incumplimiento teniendo un sesgo por el cumplimiento hacia el genero femenino, a continuación se graficará la relación:
plot1 <- ggplot(data = datos, aes(x=factor(SEX), fill =factor(default.payment.next.month))) +
geom_bar() +
ylab("Observations count") +
scale_x_discrete(labels = c('Male','Female')) +
xlab("")
plot1
Como se puede notar en la gráfica, se otorgan mayores linea de credito a las mujeres, también es de notar que las mujeres tienen más tendencia al incumplimiento lo que resulta una atipicidad.
• EDUCATION
El nivel educativo se relaciona directamente con el nivel de ingresos que se pueda tener y puede ser “una proxy cualitativa de ello”, esto trae como consecuencia directa que a un mayor nivel educativo se tenga menos probabilidad de incumplir un crédito, a continuación graficaremos que relación se tiene entre el nivel educativo y el incumplimiento:
plot2 <- ggplot(data = datos, aes(x=factor(EDUCATION), fill =factor(default.payment.next.month))) +
geom_bar() +
ylab("Observations count") +
xlab("(1=graduate school, 2=university, 3=high school, 4=others, 5=unknown, 6=unknown)")
plot2
Como se puede observar en la gráfica a pesar de variaciones en el monto máximo de los créditos la proporción no parece variar mucho en las 3 categorías que engloban la mayoría de los datos, lo que podría indicar, por ejemplo, que la brecha salarial no es muy amplia entre los niveles de educación, entre otros factores más.
• AGE
La edad como variable se asocia teóricamente al incumplimiento inversamente, mientras más edad tienes menos probabilidad de incumplimiento, esta característica tiene explicaciones de múltiple nivel, de sociológicas hasta económicas, donde se enmarca desde la madurez de la población hasta los ingresos asociados por edades.
boxplot(datos$AGE ~ datos$default.payment.next.month, col = "gray",
main = "Edad vs La Probabilidad de Impago")
como se observa en el gráfico no hay gran diferencia entre el nivel de incumplimiento por edades, los datos de ambos se agrupan al rededor de los 34 años ademas varían similarmente en los máximos y los mínimos lo que implica que la relación no sea significativa al momento de estimar un modelo.
• MARRIAGE
El estado civil de una persona tiene características y fundamentos parecidos al de la edad, donde se asocia a los casados con una menor probabilidad de incumplimiento, veamos la siguiente gráfica:
plot4 <- ggplot(data = datos, aes(x=factor(MARRIAGE), fill =factor(default.payment.next.month))) +
geom_bar() +
ylab("Observations count") +
xlab("1=married 2=single 3=others")
plot4
Se puede observar como en el caso del género otra atipicidad, pues los solteros tienen menos probabilidad de impago, lo que hace referencia a que sea data reducida tal vez de una ciudad específica y no a un genérico conglomerado.
• PAY_(i)
El estado del repago hace referencia al atraso en el pago de los montos del estado de cuenta y se asocia de manera positiva a la probabilidad de incumplimiento pues, mientras mas retrasos tengas te acercas al incumplimiento.
plot5 <- ggplot(data = datos, aes(x=factor(PAY_0), fill =factor(default.payment.next.month))) +
geom_bar() +
ylab("Observations count") +
xlab("(-1=pay duly, 1=payment delay for 1 month, 2=payment delay for 2 months, 3=payment delay for 3 months, 4=payment delay 4 months, 5=payment delay for 5 months, 6=payment delay for 6 months, 7=payment delay for 7 months, 8=payment delay for 8 months, 9=payment delay for 8 months and above))")
plot5
Según la gráfica, y tras una revisión de la data y su fuente el numero 0 puede significar ausencia de datos o en su defecto que también absorbe probabilidades de los status 1 y 2. Para efectos prácticos al analizar la data vemos que a partir del segundo mes de retraso la probabilidad de impago se hace inminente aunque hay datos atípicos en el sexto y séptimo mes, posiblemente es cuando aprovechan una compra de deuda o algún plan similar en tarjetas de crédito.
• BILL_AMT(i)
El importe del estado de cuenta es un variable relacionada estrechamente a la linea de crédito, por lo que pueden tener una similar distribución en ciertas condiciones, en general si gastas mas de tu linea de crédito (un sobregiro) se debe tener más probabilidades de incumplimiento y si gastas menos simplemente se te facilita el pago.
boxplot(datos$BILL_AMT1 ~ datos$default.payment.next.month, col = "gray",
main = "Importe del estado de cuenta vs La Probabilidad de Impago")
Como se puede notar en el gráfico hay una gran cantidad de datos atípicos, las distribuciones entre los cuantiles índica que si hay variación respecto a la probabilidad de pago e impago por lo que puede ser una variable significativa a la hora de modelar.
• PAY_AMT(i)
El importe del pago anterior se asocia con la probabilidad de impago mediante el monto cancelado respecto a tu monto facturado, es decir, si pagas el total de la deuda correspondiente, sea revolvente o a plazos, se tiene menos probabilidad de incumplir un crédito, por el contrario si solo realizas los pagos mínimos consecutivamente tienes más probabilidad de entrar en incumplimiento.
boxplot(datos$PAY_AMT1 ~ datos$default.payment.next.month, col = "gray",
main = "Importe del pago anterior vs La Probabilidad de Impago")
Como se puede apreciar en la gráfica debido a lo pequeño de las cantidades pagadas se podría indicar que se hace un pago mínimo regularmente, se nota ademas, aunque muy pequeña, una diferencia entre los valores máximos de la cantidad asociada a la no probabilidad de impago, ademas de mayores montos atípicos, por ello puede resultar una variable a tomar en consideración a la hora de modelar.
Modelo Logit en R
Para proceder a modelar tenemos que tener en cuenta el análisis previo, pues al entender que el importe del estado de cuenta y el valor de la linea de crédito podrían estar conteniendo información similar, típicamente los modelos de crédito implican el estado de anteriores,la educación, el estado civil, el género, la linea de crédito y la edad. Como se solicitan 5 variables se incluirá las variables típicas para estos casos, que serán el pago anterior, el nivel de educación, el estado civil, linea de crédito y el género, por ello tenemos:
XB <- as.formula("default.payment.next.month ~ factor(SEX)+factor(MARRIAGE)+factor(EDUCATION)+LIMIT_BAL+factor(PAY_0)")
modelo <- glm(XB,data = cred, family = binomial(link = "logit"))
summary(modelo)##
## Call:
## glm(formula = XB, family = binomial(link = "logit"), data = cred)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.8544 -0.6037 -0.5242 -0.3647 2.8686
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -13.3730262263 84.8711009346 -0.158 0.874797
## factor(SEX)2 -0.1720945328 0.0314765159 -5.467 0.0000000457
## factor(MARRIAGE)1 1.3152480227 0.5021476880 2.619 0.008812
## factor(MARRIAGE)2 1.1197658938 0.5023351616 2.229 0.025806
## factor(MARRIAGE)3 1.3050745480 0.5209376529 2.505 0.012237
## factor(EDUCATION)1 10.9610635410 84.8695965699 0.129 0.897238
## factor(EDUCATION)2 11.0013671125 84.8695969629 0.130 0.896862
## factor(EDUCATION)3 10.9570880126 84.8696030275 0.129 0.897275
## factor(EDUCATION)4 9.7356222004 84.8705452465 0.115 0.908674
## factor(EDUCATION)5 9.5524374096 84.8699940222 0.113 0.910384
## factor(EDUCATION)6 10.6100611303 84.8706440026 0.125 0.900512
## LIMIT_BAL -0.0000023751 0.0000001437 -16.533 < 0.0000000000000002
## factor(PAY_0)-1 0.1557798504 0.0672024967 2.318 0.020446
## factor(PAY_0)0 -0.2864451740 0.0634194273 -4.517 0.0000062817
## factor(PAY_0)1 0.9642210375 0.0678009715 14.221 < 0.0000000000000002
## factor(PAY_0)2 2.3740177338 0.0723131282 32.830 < 0.0000000000000002
## factor(PAY_0)3 2.6259908783 0.1440917010 18.224 < 0.0000000000000002
## factor(PAY_0)4 2.2213377320 0.2564007507 8.664 < 0.0000000000000002
## factor(PAY_0)5 1.5222673370 0.4037409534 3.770 0.000163
## factor(PAY_0)6 1.6945411396 0.6117406897 2.770 0.005605
## factor(PAY_0)7 2.8291008331 0.8088415740 3.498 0.000469
## factor(PAY_0)8 1.8237823118 0.4754977120 3.836 0.000125
##
## (Intercept)
## factor(SEX)2 ***
## factor(MARRIAGE)1 **
## factor(MARRIAGE)2 *
## factor(MARRIAGE)3 *
## factor(EDUCATION)1
## factor(EDUCATION)2
## factor(EDUCATION)3
## factor(EDUCATION)4
## factor(EDUCATION)5
## factor(EDUCATION)6
## LIMIT_BAL ***
## factor(PAY_0)-1 *
## factor(PAY_0)0 ***
## factor(PAY_0)1 ***
## factor(PAY_0)2 ***
## factor(PAY_0)3 ***
## factor(PAY_0)4 ***
## factor(PAY_0)5 ***
## factor(PAY_0)6 **
## factor(PAY_0)7 ***
## factor(PAY_0)8 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 31705 on 29999 degrees of freedom
## Residual deviance: 26697 on 29978 degrees of freedom
## AIC: 26741
##
## Number of Fisher Scoring iterations: 11Como se puede observar los betas asociados al factor educación no resultan significativos, esto como se explicó anteriormente puede deberse a que existe una brecha corta entre los salarios y el acceso al crédito según el nivel de educación, por ello se empleara otra variable que también se suele incluir en estos modelos, la edad, esto con el fundamento de tener un modelo que explique el incumplimiento, y con ello tenemos:
XB1 <- as.formula("default.payment.next.month ~ factor(SEX)+factor(MARRIAGE)+factor(PAY_0)+AGE+LIMIT_BAL")
modelo1 <- glm(XB1,data = cred, family = binomial(link = "logit"))
summary(modelo1)##
## Call:
## glm(formula = XB1, family = binomial(link = "logit"), data = cred)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.8542 -0.6007 -0.5229 -0.3822 2.6178
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.5557838607 0.5096535423 -5.015 0.000000531 ***
## factor(SEX)2 -0.1640098183 0.0316783093 -5.177 0.000000225 ***
## factor(MARRIAGE)1 1.3137179600 0.5008704154 2.623 0.008719 **
## factor(MARRIAGE)2 1.1475750333 0.5009249990 2.291 0.021969 *
## factor(MARRIAGE)3 1.2800289699 0.5199734152 2.462 0.013827 *
## factor(PAY_0)-1 0.1707829911 0.0671281018 2.544 0.010955 *
## factor(PAY_0)0 -0.2716845104 0.0631980938 -4.299 0.000017162 ***
## factor(PAY_0)1 0.9819739258 0.0676945212 14.506 < 0.0000000000000002 ***
## factor(PAY_0)2 2.3876867637 0.0721052737 33.114 < 0.0000000000000002 ***
## factor(PAY_0)3 2.6427615721 0.1437645007 18.383 < 0.0000000000000002 ***
## factor(PAY_0)4 2.2509696394 0.2564252015 8.778 < 0.0000000000000002 ***
## factor(PAY_0)5 1.4966403943 0.4014377991 3.728 0.000193 ***
## factor(PAY_0)6 1.7184416162 0.6115196627 2.810 0.004952 **
## factor(PAY_0)7 2.8574025540 0.8091907275 3.531 0.000414 ***
## factor(PAY_0)8 1.8528967666 0.4754105085 3.897 0.000097204 ***
## AGE 0.0035686388 0.0018858892 1.892 0.058453 .
## LIMIT_BAL -0.0000024360 0.0000001394 -17.472 < 0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 31705 on 29999 degrees of freedom
## Residual deviance: 26757 on 29983 degrees of freedom
## AIC: 26791
##
## Number of Fisher Scoring iterations: 4Al reemplazar la variable asociada a la educación por la la variable edad subió el AIC, este aumento seria aceptado si la variable por la que se reemplazó resultara significativa, debido a esto debemos replantear y tomar en cuenta lo que se informó en el análisis cualitativo, donde se tomaran variables a tener en cuenta variables como el pago anterior y el monto del estado de cuenta, debido a que el monto de la linea de crédito y el importe del estado de cuenta pueden presentar información similar optaremos por quitar la variable edad y agregar el pago anterior, cabe resaltar que se utilizará la información mas actual es decir a los meses de septiembre, entonces el modelo se muestra a continuación:
XB2 <- as.formula("default.payment.next.month ~ factor(SEX)+factor(MARRIAGE)+factor(PAY_0)+PAY_AMT1+LIMIT_BAL")
modelo2 <- glm(XB2,data = cred, family = binomial(link = "logit"))
summary(modelo2)##
## Call:
## glm(formula = XB2, family = binomial(link = "logit"), data = cred)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.8495 -0.6053 -0.5246 -0.3675 3.5435
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.3944957030 0.5062596901 -4.730 0.000002247660 ***
## factor(SEX)2 -0.1733886722 0.0314545392 -5.512 0.000000035406 ***
## factor(MARRIAGE)1 1.3071471404 0.5026145881 2.601 0.009304 **
## factor(MARRIAGE)2 1.1129380148 0.5025446475 2.215 0.026787 *
## factor(MARRIAGE)3 1.2934727245 0.5215580904 2.480 0.013138 *
## factor(PAY_0)-1 0.1879547439 0.0672411173 2.795 0.005186 **
## factor(PAY_0)0 -0.2537881941 0.0633482979 -4.006 0.000061694163 ***
## factor(PAY_0)1 0.9666478109 0.0677371367 14.271 < 0.0000000000000002 ***
## factor(PAY_0)2 2.3949873627 0.0721996645 33.172 < 0.0000000000000002 ***
## factor(PAY_0)3 2.6247753917 0.1437397092 18.261 < 0.0000000000000002 ***
## factor(PAY_0)4 2.2284265770 0.2562036769 8.698 < 0.0000000000000002 ***
## factor(PAY_0)5 1.4805535753 0.4012057666 3.690 0.000224 ***
## factor(PAY_0)6 1.6952362640 0.6112067211 2.774 0.005544 **
## factor(PAY_0)7 2.8181540928 0.8082293756 3.487 0.000489 ***
## factor(PAY_0)8 1.8214213703 0.4746660784 3.837 0.000124 ***
## PAY_AMT1 -0.0000117789 0.0000019160 -6.148 0.000000000786 ***
## LIMIT_BAL -0.0000021996 0.0000001418 -15.514 < 0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 31705 on 29999 degrees of freedom
## Residual deviance: 26707 on 29983 degrees of freedom
## AIC: 26741
##
## Number of Fisher Scoring iterations: 5El modelo tiene menor AIC que el anterior modelo, ademas todas sus variables son representativas concordante con un modelo que intente explicar la probabilidad de default, como último paso reemplazaremos la variable asociada al importe del estado de cuenta y el monto de la linea de crédito para comprar y quedarnos con el AIC menor:
XB3 <- as.formula("default.payment.next.month ~ factor(SEX)+factor(MARRIAGE)+factor(PAY_0)+PAY_AMT1+BILL_AMT1")
modelo3 <- glm(XB3,data = cred, family = binomial(link = "logit"))
summary(modelo3)##
## Call:
## glm(formula = XB3, family = binomial(link = "logit"), data = cred)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.8270 -0.5869 -0.5309 -0.4476 3.9004
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.79783690055 0.50542207098 -5.536 0.0000000310
## factor(SEX)2 -0.17703053716 0.03129934028 -5.656 0.0000000155
## factor(MARRIAGE)1 1.19413004185 0.50232934388 2.377 0.017445
## factor(MARRIAGE)2 1.05273160984 0.50227961635 2.096 0.036090
## factor(MARRIAGE)3 1.32748028539 0.52128526104 2.547 0.010879
## factor(PAY_0)-1 0.28906022303 0.06670933567 4.333 0.0000147004
## factor(PAY_0)0 -0.03533549465 0.06381958731 -0.554 0.579799
## factor(PAY_0)1 1.15592614420 0.06676203504 17.314 < 0.0000000000000002
## factor(PAY_0)2 2.65846498156 0.07188201026 36.984 < 0.0000000000000002
## factor(PAY_0)3 2.93133435133 0.14243346559 20.580 < 0.0000000000000002
## factor(PAY_0)4 2.54427003872 0.25422692841 10.008 < 0.0000000000000002
## factor(PAY_0)5 1.80549644368 0.39956962655 4.519 0.0000062249
## factor(PAY_0)6 1.95979058945 0.60916736190 3.217 0.001295
## factor(PAY_0)7 2.99043129985 0.80545712844 3.713 0.000205
## factor(PAY_0)8 2.08522708711 0.46967961533 4.440 0.0000090093
## PAY_AMT1 -0.00001877280 0.00000220107 -8.529 < 0.0000000000000002
## BILL_AMT1 -0.00000003443 0.00000025053 -0.137 0.890703
##
## (Intercept) ***
## factor(SEX)2 ***
## factor(MARRIAGE)1 *
## factor(MARRIAGE)2 *
## factor(MARRIAGE)3 *
## factor(PAY_0)-1 ***
## factor(PAY_0)0
## factor(PAY_0)1 ***
## factor(PAY_0)2 ***
## factor(PAY_0)3 ***
## factor(PAY_0)4 ***
## factor(PAY_0)5 ***
## factor(PAY_0)6 **
## factor(PAY_0)7 ***
## factor(PAY_0)8 ***
## PAY_AMT1 ***
## BILL_AMT1
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 31705 on 29999 degrees of freedom
## Residual deviance: 26962 on 29983 degrees of freedom
## AIC: 26996
##
## Number of Fisher Scoring iterations: 5El nuevo modelo no solo tiene mayor AIC, también hace que el beta asociado a la variable se haga no significativo, por ello nos quedaremos con el modelo anterior.
Cabe resaltar que el criterio para elegir el modelo no solo fue en base al AIC, sino también tomando en cuenta un criterio lógico que intente explicar lo mejor posible la relación entre las variables y la probabilidad de incumplimiento.
Ahora definiremos al modelo elegido con los valores ajustados y lo procederemos a graficar:
RATIO DE ODDS
La razón de oportunidades o razón de probabilidades se conoce en inglés como el Ratio Odds (OR), este ratio es una medida estadística que en términos formales, define que tantas veces mayor es un posible evento frente a que no ocurra dicho evento, en un aspecto teórico puede verse como cuantas chances hay de que ocurra un evento respecto a que no lo haga, como se puede notar en la definición el ratio de odds es una medida de “tamaño de efecto”.
Matemáticamente el Ratio de Odds se mide como un conciente de “Odds” siendo estos Odds una forma alternativa de expresar la posibilidad de ocurrencia de un evento de interés.
Para calcularlo usaremos la siguiente ecuación:
\[\textit{Ratio de Odds}=\dfrac{\rho}{1 - \rho}= e^{\beta x}\]
Para obtener los datos se empleara el siguiente codigo (la formula se deriva de las ecuaciones trabajas al inicio del documento):
ratio.odds <- numeric()
for (i in 2:17) {
valores <- exp(modelo2$coef[i])
ratio.odds[i] <- valores
}
ratio.odds<-ratio.odds[-1]; ratio.odds## [1] 0.8408108 3.6956156 3.0432865 3.6454242 1.2067789 0.7758561
## [7] 2.6291164 10.9680595 13.8014739 9.2852450 4.3953782 5.4479330
## [13] 16.7459107 6.1806372 0.9999882 0.9999978Estos valores de los Ratios de Odds se interpretan de la siguiente manera:
• La posibilidad de que ocurra un “incumplimiento” teniendo el género femenino es 0.8408108 veces mayor frente a posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un estado civil casado es 3.6956156 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un estado civil soltero es 3.0432865 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un estado civil “otros” es 3.6454242 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 0 meses es 1.2067789 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 1 a 2 meses es 0.7758561 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 1 mes es 2.6291164 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 2 meses es 10.9680595 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 3 meses es 13.8014739 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 4 meses es 9.285245 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 5 meses es 4.3953782 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 6 meses es 5.447933 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 7 meses es 16.7459107 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo un retraso del pago de reembolso de 8 meses es 6.1806372 veces mayor frente a la posibilidad de que no ocurra.
• La posibilidad de que ocurra un “incumplimiento” teniendo en cuenta el monto del pago anterior frente a la posibilidad de que no ocurra es de 0.9999882 veces mayor.
• La posibilidad de que ocurra un “incumplimiento” teniendo en cuenta el importe del estado de cuenta frente a la posibilidad de que no ocurra es de 0.9999978 veces mayor.
Cuando el \(e^{\beta}\) es mayor de 1 señala que un aumento de la variable independiente, aumenta los odds que ocurra el evento (es decir, la variable dependiente). Cuando el \(e^{\beta}\) es menor de 1 indica que un aumento de la variable independiente, reduce los odds que ocurra el evento (variable dependiente).
Probabilidad de Caer en Default
Para calcular la probabilidad de Default se usará la siguiente fórmula:
\[\rho = \dfrac{e^{\beta x}}{1+e^{\beta x}}\]
En R el código que se seguirá es:
prob.factor <- numeric()
for (i in 2:17) {
valores1 <- exp(modelo2$coef[i])/(1+exp(modelo2$coef[i]))
prob.factor[i] <- valores1
}
prob.factor<-prob.factor[-1]
prob.factor<-prob.factor*100 ; prob.factor## [1] 45.67611 78.70354 75.26764 78.47344 54.68508 43.68913 72.44508 91.64443
## [9] 93.24392 90.27733 81.46562 84.49115 94.36490 86.07366 49.99971 49.99995La interpretación de estas probabilidades son:
• La probabilidad de que ocurra un “default” es de 45.6761104% cuando se pertenezca al género femenino (valor 2).
• La probabilidad de que ocurra un “default” es de 78.7035378% cuando se tenga un estado civil de casado (valor 1).
• La probabilidad de que ocurra un “default” es de 75.2676442% cuando se tenga un estado civil de soltero (valor 2).
• La probabilidad de que ocurra un “default” es de 78.4734404% cuando se tenga un estado civil de “otros” (valor 3).
• La probabilidad de que ocurra un “default” es de 54.6850842% cuando se tenga un retraso de 0 meses en el pago del reembolso (valor -1).
• La probabilidad de que ocurra un “default” es de 43.6891316% cuando se tenga un retraso de entre 1 y 2 meses en el pago del reembolso (valor 0).
• La probabilidad de que ocurra un “default” es de 72.4450831% cuando se tenga un retraso de 1 mes en el pago del reembolso (valor 1).
• La probabilidad de que ocurra un “default” es de 91.6444265% cuando se tenga un retraso de 2 meses en el pago del reembolso (valor 2).
• La probabilidad de que ocurra un “default” es de 93.2439161% cuando se tenga un retraso de 3 meses en el pago del reembolso (valor 3).
• La probabilidad de que ocurra un “default” es de 90.2773341% cuando se tenga un retraso de 4 meses en el pago del reembolso (valor 4).
• La probabilidad de que ocurra un “default” es de 81.465618% cuando se tenga un retraso de 5 meses en el pago del reembolso (valor 5).
• La probabilidad de que ocurra un “default” es de 84.4911539% cuando se tenga un retraso de 6 meses en el pago del reembolso (valor 6).
• La probabilidad de que ocurra un “default” es de 94.364899% cuando se tenga un retraso de 7 meses en el pago del reembolso (valor 7).
• La probabilidad de que ocurra un “default” es de 86.0736593% cuando se tenga un retraso de 8 meses en el pago del reembolso (valor 8).
• La probabilidad de que ocurra un “default” es de 49.9997055% cuando se analiza con la data del monto del pago anterior brindada.
• La probabilidad de que ocurra un “default” es de 49.999945% cuando se analiza con la data del importe del estado de cuenta brindada.
Capacidad Predictiva del Modelo
Para evaluar la capacidad predictiva del modelo se analizará los puntos siguientes:
Punto de Corte
c<-seq(0.01,0.3,by=0.001)
sens<-c()
spec<-c()
for (i in 1:length(c)){
y.pred<-ifelse(modelo2$fitted.values > c[i], yes = 1, no = 0)
spec[i]<-prop.table(table(cred$default.payment.next.month,y.pred),1)[1]
sens[i]<-prop.table(table(cred$default.payment.next.month,y.pred),1)[4]
}
o.cut<-mean(c[which(round(spec,1)==round(sens,1))],na.rm = T)
plot(c,sens,type="l",col=2,main=c("Especificidad vs Sensibilidad"),ylab=c("Especificidad/Sensibilidad"))
lines(c,spec,col=3)
abline(v=o.cut)
En un análisis gráfico el punto de corte se encuentra entre el cruce de los gráficos de especificidad y sensibilidad, como se observa en la gráfica el punto de corte seria:
## [1] 0.1675Especificidad/Sensibilidad
Es análisis de especificidad y sencibilidad compara la probabilidad de exito de detectar los casos de default de tus modelo estimado vs la data real, en R podemos emplear la matriz de confusión.
y.pred<-ifelse(modelo2$fitted.values > o.cut, yes = 1, no = 0)
matriz_confusion <- table(cred$default.payment.next.month, y.pred,
dnn = c("observaciones", "predicciones"))
prop.table(matriz_confusion,1)## predicciones
## observaciones 0 1
## 0 0.6799349 0.3200651
## 1 0.3169078 0.6830922Se puede observar a través de la matriz de especificidad y sensibilidad, en la sensibilidad existe un 68.00% (redondeando) de probabilidad de que el modelo detecte los casos que no caen en morosidad, si en realidad estos casos no están en morosidad; y en la sensibilidad existe un 68.30% de probabilidad de que el modelo detecte los casos morosos si en realidad estos casos están en morosidad.
Análisis de la Curva ROC
Al realizar la curva ROC nos da un probabilidad de un area de:
##
## Call:
## roc.default(response = cred$default.payment.next.month, predictor = modelo.elegido)
##
## Data: modelo.elegido in 23364 controls (cred$default.payment.next.month 0) < 6636 cases (cred$default.payment.next.month 1).
## Area under the curve: 0.7495Esto valor se interpreta en terminos porcentuales como un 74.95%, este resultado muestra que nuestro modelo es medianamente aceptable para tratar de explicar y predecir nuestra variable dependiente. Mientras el valor se acerque mas al 100% el modelo explicara mejor la variable independiente y mientras mas cercana 0% sera espureo
Aca graficamos dicha curva:
Variaciones Marginales
Las variaciones marginales indican como cambia la probabiñidad de caer en morosidad (beta) cuando una persona tiene definida una determinada variable, es decir si tiene determinado estado civil, tiene determinado género, etc.
Matemáticamente se puede apreciar de la siguiente manera:
\[\dfrac{\partial \rho}{\partial x}= [ \dfrac{e^{x \beta}}{1+e^{x \beta}} ]\textbf{´}\]
\[\dfrac{\partial \rho}{\partial x}= \dfrac{\beta e^{x \beta} (1+e^{x \beta}) - e^{x \beta} (\beta e^{x \beta})}{(1+ e^{x \beta})^{2}}\]
\[\dfrac{\partial \rho}{\partial x}= \dfrac{\beta e^{x \beta}}{(1+e^{x \beta})} - \dfrac{\beta e^{x \beta}e^{x \beta}}{(1+e^{x \beta})^{2}}\]
\[\dfrac{\partial \rho}{\partial x}= \beta (\dfrac{e^{x \beta}}{(1+e^{x \beta})}) - \beta (\dfrac{e^{x \beta}}{(1+e^{x \beta})}) (\dfrac{e^{x \beta}}{(1+e^{x \beta})})\]
Recordando:
\[\rho = \dfrac{e^{x \beta}}{1+e^{x \beta}}\]
Se obtiene:
\[\dfrac{\partial \rho}{\partial x}= \beta \rho - \beta \rho \rho\]
\[\dfrac{\partial \rho}{\partial x}= \beta \rho (1- \rho)\]
En R se ejecuta el siguiente código:
## Call:
## logitmfx(formula = XB2, data = cred)
##
## Marginal Effects:
## dF/dx Std. Err. z
## factor(SEX)2 -0.026942444163 0.004937962605 -5.4562
## factor(MARRIAGE)1 0.208598006336 0.082980586418 2.5138
## factor(MARRIAGE)2 0.167969298890 0.074764856505 2.2466
## factor(MARRIAGE)3 0.269377079949 0.128843152318 2.0907
## factor(PAY_0)-1 0.029932019286 0.011078820490 2.7017
## factor(PAY_0)0 -0.038950683710 0.009706359218 -4.0129
## factor(PAY_0)1 0.181241060005 0.014698502911 12.3306
## factor(PAY_0)2 0.515670054556 0.015245850625 33.8236
## factor(PAY_0)3 0.573104396834 0.026280197151 21.8075
## factor(PAY_0)4 0.494826898499 0.055368930173 8.9369
## factor(PAY_0)5 0.317266581304 0.100239894872 3.1651
## factor(PAY_0)6 0.370707701237 0.150557340737 2.4622
## factor(PAY_0)7 0.607052391248 0.130986869930 4.6345
## factor(PAY_0)8 0.401474447228 0.114709818509 3.4999
## PAY_AMT1 -0.000001809913 0.000000292276 -6.1925
## LIMIT_BAL -0.000000337982 0.000000021561 -15.6758
## P>|z|
## factor(SEX)2 0.0000000486469 ***
## factor(MARRIAGE)1 0.0119432 *
## factor(MARRIAGE)2 0.0246634 *
## factor(MARRIAGE)3 0.0365517 *
## factor(PAY_0)-1 0.0068979 **
## factor(PAY_0)0 0.0000599764147 ***
## factor(PAY_0)1 < 0.00000000000000022 ***
## factor(PAY_0)2 < 0.00000000000000022 ***
## factor(PAY_0)3 < 0.00000000000000022 ***
## factor(PAY_0)4 < 0.00000000000000022 ***
## factor(PAY_0)5 0.0015504 **
## factor(PAY_0)6 0.0138074 *
## factor(PAY_0)7 0.0000035788387 ***
## factor(PAY_0)8 0.0004654 ***
## PAY_AMT1 0.0000000005923 ***
## LIMIT_BAL < 0.00000000000000022 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## dF/dx is for discrete change for the following variables:
##
## [1] "factor(SEX)2" "factor(MARRIAGE)1" "factor(MARRIAGE)2"
## [4] "factor(MARRIAGE)3" "factor(PAY_0)-1" "factor(PAY_0)0"
## [7] "factor(PAY_0)1" "factor(PAY_0)2" "factor(PAY_0)3"
## [10] "factor(PAY_0)4" "factor(PAY_0)5" "factor(PAY_0)6"
## [13] "factor(PAY_0)7" "factor(PAY_0)8"Comparación con el Modelo Trabajado en Clase
El modelo trabajado en clase tiene el siguiente código:
modelox <- glm(default.payment.next.month ~ .,data = cred,
family = binomial(link = "logit"))
summary(modelox)##
## Call:
## glm(formula = default.payment.next.month ~ ., family = binomial(link = "logit"),
## data = cred)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.2866 -0.5985 -0.5070 -0.3066 3.5280
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -14.5105926855 140.7793287463 -0.103 0.917905
## LIMIT_BAL -0.0000018797 0.0000001752 -10.728 < 0.0000000000000002 ***
## SEX2 -0.1459417669 0.0323281119 -4.514 0.00000634987 ***
## EDUCATION1 11.8346874921 140.7783255878 0.084 0.933004
## EDUCATION2 11.8606222438 140.7783260129 0.084 0.932857
## EDUCATION3 11.8115784051 140.7783293022 0.084 0.933134
## EDUCATION4 10.7342493797 140.7788867931 0.076 0.939221
## EDUCATION5 10.5588633237 140.7785597052 0.075 0.940212
## EDUCATION6 11.5629058617 140.7789477409 0.082 0.934539
## MARRIAGE1 1.4793060521 0.5222163347 2.833 0.004615 **
## MARRIAGE2 1.3290950526 0.5223722418 2.544 0.010948 *
## MARRIAGE3 1.5522780617 0.5408849369 2.870 0.004106 **
## AGE 0.0037302767 0.0019709916 1.893 0.058413 .
## PAY_0-1 0.4913138012 0.1079236899 4.552 0.00000530327 ***
## PAY_00 -0.2512757899 0.1167323560 -2.153 0.031352 *
## PAY_01 0.8074625087 0.0845436521 9.551 < 0.0000000000000002 ***
## PAY_02 2.0282255072 0.1060429935 19.126 < 0.0000000000000002 ***
## PAY_03 2.0520979518 0.1694541790 12.110 < 0.0000000000000002 ***
## PAY_04 1.7217246814 0.2982170878 5.773 0.00000000777 ***
## PAY_05 1.4265543947 0.4837314023 2.949 0.003187 **
## PAY_06 0.3601321325 0.8896572480 0.405 0.685625
## PAY_07 1.5688432425 1.4871642771 1.055 0.291461
## PAY_08 -12.2934415150 535.4113802903 -0.023 0.981682
## PAY_2-1 -0.1787935423 0.1134364127 -1.576 0.114990
## PAY_20 0.0381308018 0.1387271444 0.275 0.783422
## PAY_21 -0.6679951410 0.5746725936 -1.162 0.245076
## PAY_22 0.0343735762 0.1172444332 0.293 0.769386
## PAY_23 0.0458027878 0.1795580856 0.255 0.798657
## PAY_24 -0.7228426361 0.3222606599 -2.243 0.024894 *
## PAY_25 1.0419408518 0.7405288360 1.407 0.159421
## PAY_26 0.8975462195 1.4830596725 0.605 0.545047
## PAY_27 0.9741836504 598.9930989734 0.002 0.998702
## PAY_28 13.0193268332 641.0787228720 0.020 0.983797
## PAY_3-1 -0.0010577962 0.1084891705 -0.010 0.992221
## PAY_30 0.0578492112 0.1258709057 0.460 0.645809
## PAY_31 -11.8695717939 376.2095069580 -0.032 0.974831
## PAY_32 0.3908619132 0.1274804106 3.066 0.002169 **
## PAY_33 0.4400333291 0.2220788268 1.981 0.047543 *
## PAY_34 -0.0702030136 0.4230019666 -0.166 0.868185
## PAY_35 -0.5464619503 0.8497380211 -0.643 0.520163
## PAY_36 13.9365744363 268.5668979373 0.052 0.958614
## PAY_37 0.3072057286 0.7695085204 0.399 0.689729
## PAY_38 -1.4559314426 1.8775100175 -0.775 0.438069
## PAY_4-1 -0.1343011328 0.1089347468 -1.233 0.217629
## PAY_40 -0.0837353110 0.1216170054 -0.689 0.491128
## PAY_41 13.8460336801 376.2121344288 0.037 0.970641
## PAY_42 0.2031206694 0.1301682326 1.560 0.118654
## PAY_43 0.0273969411 0.2474118847 0.111 0.911827
## PAY_44 0.3299990460 0.4455047863 0.741 0.458857
## PAY_45 -1.5788507724 0.8160239830 -1.935 0.053014 .
## PAY_46 -27.6497335725 352.5866930976 -0.078 0.937494
## PAY_47 -23.6195124509 395.5317102995 -0.060 0.952382
## PAY_48 -39.3971369436 665.6664407023 -0.059 0.952805
## PAY_5-1 -0.0924606095 0.1064359609 -0.869 0.385013
## PAY_50 0.0097664357 0.1180584465 0.083 0.934070
## PAY_52 0.2855480867 0.1322143898 2.160 0.030793 *
## PAY_53 0.0729120032 0.2426249620 0.301 0.763786
## PAY_54 -0.2067444093 0.4556418902 -0.454 0.650014
## PAY_55 1.1747351883 0.8866034409 1.325 0.185177
## PAY_56 24.8761757680 395.5284554962 0.063 0.949851
## PAY_57 24.7316823570 395.5363166993 0.063 0.950143
## PAY_58 36.6446350617 1183.7889837744 0.031 0.975305
## PAY_6-1 -0.1189057323 0.0821214250 -1.448 0.147638
## PAY_60 -0.3224917192 0.0885666498 -3.641 0.000271 ***
## PAY_62 0.0594230290 0.1030298326 0.577 0.564105
## PAY_63 0.6324793333 0.2348838147 2.693 0.007087 **
## PAY_64 0.0680332887 0.4639619732 0.147 0.883420
## PAY_65 -0.3309484230 0.7666790361 -0.432 0.665985
## PAY_66 0.6092029760 0.9469452524 0.643 0.520007
## PAY_67 -0.6558562225 1.7548228287 -0.374 0.708594
## PAY_68 16.7842023675 680.4831364066 0.025 0.980322
## BILL_AMT1 -0.0000012503 0.0000010843 -1.153 0.248844
## BILL_AMT2 0.0000022905 0.0000014388 1.592 0.111394
## BILL_AMT3 0.0000021437 0.0000012888 1.663 0.096254 .
## BILL_AMT4 -0.0000001661 0.0000013127 -0.127 0.899326
## BILL_AMT5 -0.0000002443 0.0000015018 -0.163 0.870779
## BILL_AMT6 -0.0000005384 0.0000011877 -0.453 0.650301
## PAY_AMT1 -0.0000122932 0.0000023588 -5.212 0.00000018722 ***
## PAY_AMT2 -0.0000088951 0.0000021417 -4.153 0.00003277155 ***
## PAY_AMT3 -0.0000010271 0.0000016660 -0.617 0.537555
## PAY_AMT4 -0.0000017209 0.0000017770 -0.968 0.332840
## PAY_AMT5 -0.0000027890 0.0000017833 -1.564 0.117822
## PAY_AMT6 -0.0000028341 0.0000013321 -2.128 0.033375 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 31705 on 29999 degrees of freedom
## Residual deviance: 25998 on 29917 degrees of freedom
## AIC: 26164
##
## Number of Fisher Scoring iterations: 12Se Calcula un nuevo modelo a traves del siguiente codigo
## Start: AIC=26164.34
## default.payment.next.month ~ LIMIT_BAL + SEX + EDUCATION + MARRIAGE +
## AGE + PAY_0 + PAY_2 + PAY_3 + PAY_4 + PAY_5 + PAY_6 + BILL_AMT1 +
## BILL_AMT2 + BILL_AMT3 + BILL_AMT4 + BILL_AMT5 + BILL_AMT6 +
## PAY_AMT1 + PAY_AMT2 + PAY_AMT3 + PAY_AMT4 + PAY_AMT5 + PAY_AMT6## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Df Deviance AIC
## - BILL_AMT4 1 25998 26162
## - BILL_AMT5 1 25998 26162
## - BILL_AMT6 1 25999 26163
## - PAY_AMT3 1 25999 26163
## - PAY_AMT4 1 25999 26163
## - BILL_AMT1 1 26000 26164
## <none> 25998 26164
## - PAY_2 10 26019 26165
## - BILL_AMT2 1 26001 26165
## - PAY_AMT5 1 26001 26165
## - BILL_AMT3 1 26001 26165
## - AGE 1 26002 26166
## - PAY_AMT6 1 26003 26167
## - PAY_5 9 26023 26171
## - SEX 1 26019 26183
## - PAY_AMT2 1 26019 26183
## - PAY_4 10 26038 26184
## - MARRIAGE 3 26026 26186
## - PAY_3 10 26040 26186
## - PAY_AMT1 1 26034 26198
## - EDUCATION 6 26049 26203
## - PAY_6 9 26055 26203
## - LIMIT_BAL 1 26119 26283
## - PAY_0 10 27450 27596
##
## Step: AIC=26162.36
## default.payment.next.month ~ LIMIT_BAL + SEX + EDUCATION + MARRIAGE +
## AGE + PAY_0 + PAY_2 + PAY_3 + PAY_4 + PAY_5 + PAY_6 + BILL_AMT1 +
## BILL_AMT2 + BILL_AMT3 + BILL_AMT5 + BILL_AMT6 + PAY_AMT1 +
## PAY_AMT2 + PAY_AMT3 + PAY_AMT4 + PAY_AMT5 + PAY_AMT6## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Df Deviance AIC
## - BILL_AMT5 1 25998 26160
## - BILL_AMT6 1 25999 26161
## - PAY_AMT3 1 25999 26161
## - PAY_AMT4 1 25999 26161
## - BILL_AMT1 1 26000 26162
## <none> 25998 26162
## - PAY_2 10 26019 26163
## - BILL_AMT2 1 26001 26163
## - PAY_AMT5 1 26001 26163
## - BILL_AMT3 1 26002 26164
## - AGE 1 26002 26164
## - PAY_AMT6 1 26003 26165
## - PAY_5 9 26023 26169
## - SEX 1 26019 26181
## - PAY_AMT2 1 26019 26181
## - PAY_4 10 26038 26182
## - MARRIAGE 3 26026 26184
## - PAY_3 10 26040 26184
## - PAY_AMT1 1 26034 26196
## - EDUCATION 6 26049 26201
## - PAY_6 9 26055 26201
## - LIMIT_BAL 1 26119 26281
## - PAY_0 10 27450 27594
##
## Step: AIC=26160.42
## default.payment.next.month ~ LIMIT_BAL + SEX + EDUCATION + MARRIAGE +
## AGE + PAY_0 + PAY_2 + PAY_3 + PAY_4 + PAY_5 + PAY_6 + BILL_AMT1 +
## BILL_AMT2 + BILL_AMT3 + BILL_AMT6 + PAY_AMT1 + PAY_AMT2 +
## PAY_AMT3 + PAY_AMT4 + PAY_AMT5 + PAY_AMT6## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Df Deviance AIC
## - PAY_AMT3 1 25999 26159
## - BILL_AMT6 1 26000 26160
## - PAY_AMT4 1 26000 26160
## - BILL_AMT1 1 26000 26160
## <none> 25998 26160
## - PAY_2 10 26019 26161
## - BILL_AMT2 1 26001 26161
## - PAY_AMT5 1 26001 26161
## - BILL_AMT3 1 26002 26162
## - AGE 1 26002 26162
## - PAY_AMT6 1 26004 26164
## - PAY_5 9 26023 26167
## - SEX 1 26019 26179
## - PAY_AMT2 1 26019 26179
## - PAY_4 10 26038 26180
## - MARRIAGE 3 26026 26182
## - PAY_3 10 26040 26182
## - PAY_AMT1 1 26034 26194
## - EDUCATION 6 26049 26199
## - PAY_6 9 26055 26199
## - LIMIT_BAL 1 26120 26280
## - PAY_0 10 27450 27592
##
## Step: AIC=26159.07
## default.payment.next.month ~ LIMIT_BAL + SEX + EDUCATION + MARRIAGE +
## AGE + PAY_0 + PAY_2 + PAY_3 + PAY_4 + PAY_5 + PAY_6 + BILL_AMT1 +
## BILL_AMT2 + BILL_AMT3 + BILL_AMT6 + PAY_AMT1 + PAY_AMT2 +
## PAY_AMT4 + PAY_AMT5 + PAY_AMT6## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Df Deviance AIC
## - PAY_AMT4 1 26000 26158
## - BILL_AMT1 1 26001 26159
## - BILL_AMT6 1 26001 26159
## <none> 25999 26159
## - PAY_2 10 26019 26159
## - BILL_AMT2 1 26002 26160
## - PAY_AMT5 1 26002 26160
## - AGE 1 26003 26161
## - BILL_AMT3 1 26003 26161
## - PAY_AMT6 1 26005 26163
## - PAY_5 9 26024 26166
## - SEX 1 26019 26177
## - PAY_4 10 26040 26180
## - PAY_AMT2 1 26022 26180
## - PAY_3 10 26040 26180
## - MARRIAGE 3 26027 26181
## - PAY_AMT1 1 26036 26194
## - EDUCATION 6 26050 26198
## - PAY_6 9 26056 26198
## - LIMIT_BAL 1 26122 26280
## - PAY_0 10 27451 27591
##
## Step: AIC=26158.41
## default.payment.next.month ~ LIMIT_BAL + SEX + EDUCATION + MARRIAGE +
## AGE + PAY_0 + PAY_2 + PAY_3 + PAY_4 + PAY_5 + PAY_6 + BILL_AMT1 +
## BILL_AMT2 + BILL_AMT3 + BILL_AMT6 + PAY_AMT1 + PAY_AMT2 +
## PAY_AMT5 + PAY_AMT6## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Df Deviance AIC
## - BILL_AMT1 1 26002 26158
## <none> 26000 26158
## - PAY_2 10 26021 26159
## - BILL_AMT6 1 26003 26159
## - BILL_AMT2 1 26003 26159
## - PAY_AMT5 1 26003 26159
## - AGE 1 26004 26160
## - BILL_AMT3 1 26005 26161
## - PAY_AMT6 1 26007 26163
## - PAY_5 9 26027 26167
## - SEX 1 26021 26177
## - PAY_4 10 26041 26179
## - PAY_3 10 26042 26180
## - MARRIAGE 3 26028 26180
## - PAY_AMT2 1 26025 26181
## - PAY_AMT1 1 26039 26195
## - EDUCATION 6 26051 26197
## - PAY_6 9 26058 26198
## - LIMIT_BAL 1 26125 26281
## - PAY_0 10 27456 27594
##
## Step: AIC=26158.12
## default.payment.next.month ~ LIMIT_BAL + SEX + EDUCATION + MARRIAGE +
## AGE + PAY_0 + PAY_2 + PAY_3 + PAY_4 + PAY_5 + PAY_6 + BILL_AMT2 +
## BILL_AMT3 + BILL_AMT6 + PAY_AMT1 + PAY_AMT2 + PAY_AMT5 +
## PAY_AMT6## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Df Deviance AIC
## - BILL_AMT2 1 26003 26157
## <none> 26002 26158
## - PAY_2 10 26023 26159
## - BILL_AMT6 1 26005 26159
## - PAY_AMT5 1 26005 26159
## - AGE 1 26006 26160
## - BILL_AMT3 1 26007 26161
## - PAY_AMT6 1 26009 26163
## - PAY_5 9 26029 26167
## - SEX 1 26022 26176
## - PAY_4 10 26043 26179
## - MARRIAGE 3 26030 26180
## - PAY_3 10 26044 26180
## - PAY_AMT2 1 26027 26181
## - PAY_AMT1 1 26041 26195
## - EDUCATION 6 26053 26197
## - PAY_6 9 26060 26198
## - LIMIT_BAL 1 26131 26285
## - PAY_0 10 27462 27598
##
## Step: AIC=26156.99
## default.payment.next.month ~ LIMIT_BAL + SEX + EDUCATION + MARRIAGE +
## AGE + PAY_0 + PAY_2 + PAY_3 + PAY_4 + PAY_5 + PAY_6 + BILL_AMT3 +
## BILL_AMT6 + PAY_AMT1 + PAY_AMT2 + PAY_AMT5 + PAY_AMT6## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Df Deviance AIC
## <none> 26003 26157
## - BILL_AMT6 1 26005 26157
## - PAY_2 10 26024 26158
## - PAY_AMT5 1 26006 26158
## - AGE 1 26007 26159
## - PAY_AMT6 1 26009 26161
## - PAY_5 9 26029 26165
## - SEX 1 26023 26175
## - PAY_4 10 26044 26178
## - MARRIAGE 3 26030 26178
## - PAY_3 10 26045 26179
## - BILL_AMT3 1 26031 26183
## - PAY_AMT1 1 26041 26193
## - PAY_AMT2 1 26042 26194
## - EDUCATION 6 26054 26196
## - PAY_6 9 26060 26196
## - LIMIT_BAL 1 26131 26283
## - PAY_0 10 27465 27599Se puede observar su histograma aqui:
Ahora se procede a calcular el punto de corte:
c<-seq(0.01,0.3,by=0.001)
sens<-c()
spec<-c()
for (i in 1:length(c)){
y.pred<-ifelse(model.AIC$fitted.values > c[i], yes = 1, no = 0)
spec[i]<-prop.table(table(cred$default.payment.next.month,y.pred),1)[1]
sens[i]<-prop.table(table(cred$default.payment.next.month,y.pred),1)[4]
}
o.cut<-mean(c[which(round(spec,1)==round(sens,1))],na.rm = T)
plot(c,sens,type="l",col=2,main=c("Especificidad vs Sensibilidad"),ylab=c("Especificidad/Sensibilidad"))
lines(c,spec,col=3)
abline(v=o.cut)
El punto de corte es:
## [1] 0.1695Se procede a calcular la matriz de confusión:
y.pred<-ifelse(model.AIC$fitted.values > o.cut, yes = 1, no = 0)
matriz_confusion <- table(cred$default.payment.next.month, y.pred,
dnn = c("observaciones", "predicciones"))
prop.table(matriz_confusion,1)## predicciones
## observaciones 0 1
## 0 0.7065571 0.2934429
## 1 0.3071127 0.6928873Por ultimo se ve el area bajo la curva de la gráfica ROC
## Setting levels: control = 0, case = 1## Setting direction: controls < cases##
## Call:
## roc.default(response = cred$default.payment.next.month, predictor = yhat1)
##
## Data: yhat1 in 23364 controls (cred$default.payment.next.month 0) < 6636 cases (cred$default.payment.next.month 1).
## Area under the curve: 0.7724Y se procede a graficarla:
## Setting levels: control = 0, case = 1## Setting direction: controls < cases
Comparando los dos modelos tenemos los siguiente:
• Mientras que el modelo trabajado en clase tiene un AIC de 26157, el que se desarrolló en el trabajo tiene un AIC de 26741 lo que indica que es preferible el trabajado en clase, sin embargo es de acotar que ese modelo tiene todas las variables y no trabajan con la limitante de 5 variables, ademas muchas de las variables variables resultan no significativas.
• El punto de corte es el modelo trabajado en clase es de 0.1695 y el del modelo es de 0.1675.
• El modelo trabajado en clase tiene una sensibilidad de 70.65% y el que se trabajó una de 67.99% lo que hace preferible al primero.
• El modelo trabajado en clase tiene una especificidad de 69.28% y el que se trabajó una especificidad de 68.35% lo que hace preferible al primer modelo.
• Por ultimo el valor del área bajo la curva ROC en el modelo trabajo en clase es del 77.24% y el del modelo trabajado es de 74.95% lo que hace una mejor elección al modelo trabajado en clase.
En términos tecnicos elige al modelo trabajado en clase sin embargo tambien es importante acotar otros análisis teoricos y metodologicos pues no todas las variables son significativas.