Utiliza los datos de LOANAPP para este ejercicio.
1. Estima un modelo con approve como variable dependiente y white como variable explicativa. Calcula la probabilidad de que concedan una hipoteca a un blanco y a alguien de color. ¿Son estos resultados similares a los obtenidos mediante el modelo lineal de probabilidad?
Calculamos el modelo mediante un probit:
probit <- glm(approve ~ white, family = binomial(link="probit"))
summary(probit)
Call:
glm(formula = approve ~ white, family = binomial(link = "probit"))
Deviance Residuals:
Min 1Q Median 3Q Max
-2.1864 0.4384 0.4384 0.4384 0.8314
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) 0.54695 0.07544 7.251 4.15e-13 ***
white 0.78395 0.08671 9.041 < 2e-16 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 1480.7 on 1988 degrees of freedom
Residual deviance: 1401.8 on 1987 degrees of freedom
AIC: 1405.8
Number of Fisher Scoring iterations: 4Tanto la constante como la variable white son significativas en el modelo.
Las probabilidades de que concedan una hipoteca con el modelo probit son:
Persona blanca: 0.9083879
Persona de color: 0.7077922Hacemos lo mismo pero ahora con un MLP:
mlp <- lm(approve ~ white)
summary(mlp)
Call:
lm(formula = approve ~ white)
Residuals:
Min 1Q Median 3Q Max
-0.90839 0.09161 0.09161 0.09161 0.29221
Coefficients:
Estimate Std. Error t value Pr(>|t|)
(Intercept) 0.70779 0.01824 38.81 <2e-16 ***
white 0.20060 0.01984 10.11 <2e-16 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
Residual standard error: 0.3201 on 1987 degrees of freedom
Multiple R-squared: 0.04893, Adjusted R-squared: 0.04845
F-statistic: 102.2 on 1 and 1987 DF, p-value: < 2.2e-16Probabilidades de conceder una hipoteca mediante MLP:
Persona blanca: 0.9083879
Persona de color: 0.7077922Como podemos ver las probabilidades en este caso son exactamente iguales, esto se debe a que solo estamos usando una variable explicativa.
2. Incluye las variable explicativas hrat, obrat, loanprc, unem, male, married, dep, sch, cosign, pubrec, mortlat1, mortlat2, y vr al modelo probit. ¿Hay evidencia estadística de discriminación de los no-blancos?
probit2 <- glm(approve ~ white + hrat + obrat + loanprc + unem + male + married + dep + sch + cosign + pubrec + mortlat1 + mortlat2 + vr, family = binomial(link="probit"))
summary(probit2)
Call:
glm(formula = approve ~ white + hrat + obrat + loanprc + unem +
male + married + dep + sch + cosign + pubrec + mortlat1 +
mortlat2 + vr, family = binomial(link = "probit"))
Deviance Residuals:
Min 1Q Median 3Q Max
-2.9826 0.2642 0.3673 0.4838 1.8536
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) 2.467391 0.306604 8.047 8.45e-16 ***
white 0.570011 0.095110 5.993 2.06e-09 ***
hrat 0.010469 0.006898 1.518 0.1291
obrat -0.029881 0.006035 -4.951 7.37e-07 ***
loanprc -1.005723 0.239389 -4.201 2.65e-05 ***
unem -0.031173 0.017472 -1.784 0.0744 .
male -0.037751 0.108366 -0.348 0.7276
married 0.229066 0.093089 2.461 0.0139 *
dep -0.037247 0.038513 -0.967 0.3335
sch 0.041582 0.093806 0.443 0.6576
cosign 0.044068 0.234173 0.188 0.8507
pubrec -0.965282 0.121759 -7.928 2.23e-15 ***
mortlat1 -0.256219 0.255706 -1.002 0.3163
mortlat2 -0.584431 0.317975 -1.838 0.0661 .
vr -0.187485 0.080409 -2.332 0.0197 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 1476.0 on 1970 degrees of freedom
Residual deviance: 1236.5 on 1956 degrees of freedom
(18 observations deleted due to missingness)
AIC: 1266.5
Number of Fisher Scoring iterations: 5La variable white en este modelo es significativa por lo que influye en la variable approve, el signo del coeficiente estimado es positivo lo que nos indica que en caso de ser una persona blanca la probabilidad de que te aprueben la hipoteca aumenta, por tanto hay evidencia estadística de discriminación de los no-blancos en este modelo.
3. Estima el modelo del apartado anterior como un logit y compara los coeficientes con los del probit.
logit <- glm(approve ~ white + hrat + obrat + loanprc + unem + male + married + dep + sch + cosign + pubrec + mortlat1 + mortlat2 + vr, family = binomial(link="logit"))
summary(logit)
Call:
glm(formula = approve ~ white + hrat + obrat + loanprc + unem +
male + married + dep + sch + cosign + pubrec + mortlat1 +
mortlat2 + vr, family = binomial(link = "logit"))
Deviance Residuals:
Min 1Q Median 3Q Max
-2.8649 0.2774 0.3685 0.4753 1.9361
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) 4.52976 0.57986 7.812 5.63e-15 ***
white 1.03621 0.16878 6.139 8.29e-10 ***
hrat 0.01852 0.01261 1.468 0.1420
obrat -0.05715 0.01103 -5.181 2.21e-07 ***
loanprc -1.89846 0.45981 -4.129 3.65e-05 ***
unem -0.05610 0.03235 -1.734 0.0829 .
male -0.06646 0.20289 -0.328 0.7432
married 0.42606 0.17465 2.439 0.0147 *
dep -0.06529 0.07202 -0.906 0.3647
sch 0.07918 0.17546 0.451 0.6518
cosign 0.09046 0.43311 0.209 0.8345
pubrec -1.66816 0.20667 -8.072 6.94e-16 ***
mortlat1 -0.41786 0.46528 -0.898 0.3691
mortlat2 -1.07987 0.54908 -1.967 0.0492 *
vr -0.33328 0.15167 -2.197 0.0280 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 1476.0 on 1970 degrees of freedom
Residual deviance: 1237.3 on 1956 degrees of freedom
(18 observations deleted due to missingness)
AIC: 1267.3
Number of Fisher Scoring iterations: 5mtable(probit2, logit)
Calls:
probit2: glm(formula = approve ~ white + hrat + obrat + loanprc + unem +
male + married + dep + sch + cosign + pubrec + mortlat1 +
mortlat2 + vr, family = binomial(link = "probit"))
logit: glm(formula = approve ~ white + hrat + obrat + loanprc + unem +
male + married + dep + sch + cosign + pubrec + mortlat1 +
mortlat2 + vr, family = binomial(link = "logit"))
==============================================
probit2 logit
----------------------------------------------
(Intercept) 2.467*** 4.530***
(0.307) (0.580)
white 0.570*** 1.036***
(0.095) (0.169)
hrat 0.010 0.019
(0.007) (0.013)
obrat -0.030*** -0.057***
(0.006) (0.011)
loanprc -1.006*** -1.898***
(0.239) (0.460)
unem -0.031 -0.056
(0.017) (0.032)
male -0.038 -0.066
(0.108) (0.203)
married 0.229* 0.426*
(0.093) (0.175)
dep -0.037 -0.065
(0.039) (0.072)
sch 0.042 0.079
(0.094) (0.175)
cosign 0.044 0.090
(0.234) (0.433)
pubrec -0.965*** -1.668***
(0.122) (0.207)
mortlat1 -0.256 -0.418
(0.256) (0.465)
mortlat2 -0.584 -1.080*
(0.318) (0.549)
vr -0.187* -0.333*
(0.080) (0.152)
----------------------------------------------
Aldrich-Nelson R-sq. 0.1 0.1
McFadden R-sq. 0.2 0.2
Cox-Snell R-sq. 0.1 0.1
Nagelkerke R-sq. 0.2 0.2
phi 1.0 1.0
Likelihood-ratio 239.5 238.7
p 0.0 0.0
Log-likelihood -618.2 -618.7
Deviance 1236.5 1237.3
AIC 1266.5 1267.3
BIC 1350.3 1351.1
N 1971 1971
==============================================Vemos como los coeficientes son prácticamente iguales excepto por la escala, los del modelo logit son casi el doble que los del modelo probit.
Una gran ventaja de las estimacions del modelo logit es que nos sirven para obtener los odds ratio de las variables, la variable white tiene un odd ratio de e1.036 = 2.818, que quiere decir que es 2.818 veces más probable que a una persona blanca le aprueben la hipoteca que a una persona no-blanca.
4. Utiliza la siguiente ecuación para estimar el efecto parcial medio de una variable discreta (ck = 0, 1) \[ n^{-1}\sum_{i=1}^{n} (G[\beta_0 + \beta_1x_{1i} +...+ \beta_{k-1}x_{k-1,i} +\beta_k]-G[\beta_0 + \beta_1x_{1i} +...+ \beta_{k-1}x_{k-1,i}]) \]
dat <- cbind(1,1, hrat, obrat, loanprc, unem, male, married, dep, sch, cosign, pubrec, mortlat1, mortlat2, vr)
dat2 <- dat
dat2[,2] <- 0
epm <- mean(pnorm(colSums(t(dat)*probit2$coefficients))-pnorm(colSums(t(dat2)*probit2$coefficients)),na.rm = T)
cat("Efecto Parcial Medio:", epm)Efecto Parcial Medio: 0.1197566El efecto parcial medio de la variable white es de 0.1198, esto quiere decir que de media hay un 11.98% más de posibilidades de que a una persona blanca le concedan su hipoteca respecto a una persona no-blanca.
EXTRA
La variable white es significativa en el modelo anterior pero ese modelo tiene varias variables no significativas y no se incluyen variables que pueden ser muy relevantes a la hora de determinar si se aprueba una hipoteca o no, por ejemplo, el ingreso de la persona, poder verificar la información del solicitante o que el historial de crédito cumpla con los requisitos.
Por este motivo he creado otro modelo que incluye otras variables de la base de datos para poder ver si realmente hay un problema de discriminación de los no-blancos.
probit3 <- glm(approve ~ white + self +unver + gdlin + unit + occ + appinc + obrat + loanprc + unem + married + pubrec + vr, family = binomial(link="probit"))
summary(probit3)
Call:
glm(formula = approve ~ white + self + unver + gdlin + unit +
occ + appinc + obrat + loanprc + unem + married + pubrec +
vr, family = binomial(link = "probit"))
Deviance Residuals:
Min 1Q Median 3Q Max
-2.9347 0.1711 0.2412 0.3486 2.9440
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) 1.5038051 0.4306665 3.492 0.000480 ***
white 0.4053171 0.1150080 3.524 0.000425 ***
self -0.3145065 0.1325273 -2.373 0.017637 *
unver -1.4829111 0.1846080 -8.033 9.53e-16 ***
gdlin 1.9567561 0.1392716 14.050 < 2e-16 ***
unit -0.1753078 0.0889967 -1.970 0.048859 *
occ -0.3274222 0.2002519 -1.635 0.102038
appinc -0.0007689 0.0007373 -1.043 0.297006
obrat -0.0206990 0.0056301 -3.676 0.000236 ***
loanprc -0.8460874 0.2745578 -3.082 0.002059 **
unem -0.0299231 0.0199632 -1.499 0.133896
married 0.2626258 0.0976951 2.688 0.007183 **
pubrec -0.2968444 0.1626660 -1.825 0.068021 .
vr -0.3143704 0.0971048 -3.237 0.001206 **
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 1441.79 on 1960 degrees of freedom
Residual deviance: 840.11 on 1947 degrees of freedom
(28 observations deleted due to missingness)
AIC: 868.11
Number of Fisher Scoring iterations: 6En este modelo podemos considerar que todas las variables son significativas, white sigue siendo significativa pero esta vez con un nivel de significación considerablemente más bajo, pasó de 2.06e-09 a 0.000425, además el coeficiente estimado ahora es de 0.405 en lugar de 0.570 lo que nos indica que el efecto es mucho menor que antes, el error estándar solo aumento un poco de 0.095 a 0.115.
Hay que tener en cuenta también que el AIC de este nuevo modelo es de 868.11, mucho más bajo que los 1266.5 del modelo anterior, lo cual es muy buena señal.
Las conclusiones siguen siendo las mismas en cuanto a que hay discriminación de los no-blancos, sin embargo, si estimamos su efecto parcial medio en este modelo obtenemos:
dat <- cbind(1,1,self,unver,gdlin,unit,occ,appinc,obrat,loanprc,unem,married,pubrec,vr)
dat2 <- dat
dat2[,2] <- 0
epm2 <- mean(pnorm(colSums(t(dat)*probit3$coefficients))-pnorm(colSums(t(dat2)*probit3$coefficients)),na.rm = T)
cat("Efecto Parcial Medio:", epm2)Efecto Parcial Medio: 0.05417827Podemos ver como ahora el efecto parcial medio es solamente de 0.0542, si bien sigue habiendo discriminación en este modelo es muy distinto hablar de solo 5.42% mayor probabilidad de que te aprueben una hipoteca siendo blanco al 11.98% obtenido anteriormente.