Examen:Modelos de Regresion
Juarez Castillo Jorge Abraham
2024-10-07
Base de datos
library(readxl)
GPA_Mexico <- read_excel("C:/Users/hogar/Downloads/GPA_Mexico.xlsx")
View(GPA_Mexico)
names(GPA_Mexico)## [1] "Prom_Licenciatura" "Edad"
## [3] "Genero" "Tiempo_Traslado"
## [5] "Prom_Prepa" "Actividades_Extras"
## [7] "Horas_Menos_19" "Horas_Mas_20"
## [9] "Llega_Coche" "Llega_Bicicleta"
## [11] "Llega_Caminando" "Llega_Transporte_Publico"
## [13] "Tiene_PC" "Tiene_Novia"
## [15] "Horas_Perdidas" "Consume_Alcohol"
## [17] "Padre_Licenciatura" "Madre_Licenciatura"Promedio de licenciatura
m_bach<-mean(GPA_Mexico$Prom_Licenciatura)
m_bach## [1] 7.97712sd_bach<-sd(GPA_Mexico$Prom_Licenciatura)
sd_bach## [1] 1.18345max_bach<-max(GPA_Mexico$Prom_Licenciatura)
min_bach<-min(GPA_Mexico$Prom_Licenciatura)
max_bach## [1] 9.99min_bach## [1] 6par(mar = c(5, 4, 4, 2)) # Márgenes más pequeños
GPA_grouped <-cut(GPA_Mexico$Prom_Licenciatura,breaks=seq(min(GPA_Mexico$Prom_Licenciatura),max(GPA_Mexico$Prom_Licenciatura), by = 0.5), include.lowest = TRUE)
barplot(table(GPA_grouped), las = 2, cex.names = 0.8, col = "skyblue", main = "Promedios de Licenciatura")
#Desviación estandar
sd_prom<-sd(GPA_Mexico$Prom_Licenciatura)
sd_prom## [1] 1.18345Los estudiantes de esta universidad: media muestral de 7.977, con una desviación estandar de 1.183, un valor máximo de 9.99 y valor mínimo de 6.00. La moda se encuentra entre 6 y 6.5.
GENERO
table(GPA_Mexico$Genero)##
## 0 1
## 243 257tabla_1<-round(table(GPA_Mexico$Genero)/length(GPA_Mexico$Genero)*100,2)
knitr::kable(tabla_1)| Var1 | Freq |
|---|---|
| 0 | 48.6 |
| 1 | 51.4 |
barplot(tabla_1)
Padre licenciatura
table(GPA_Mexico$Padre_Licenciatura)##
## 0 1
## 348 152tabla_9<-round(table(GPA_Mexico$Padre_Licenciatura)/length(GPA_Mexico$Padre_Licenciatura)*100,2)
knitr::kable(tabla_9)| Var1 | Freq |
|---|---|
| 0 | 69.6 |
| 1 | 30.4 |
barplot(tabla_9)
Resumen descriptivo de todas las variables.
library(readxl)
summary(GPA_Mexico) ## Prom_Licenciatura Edad Genero Tiempo_Traslado
## Min. :6.000 Min. :18.00 Min. :0.000 Min. : 15.0
## 1st Qu.:6.920 1st Qu.:21.00 1st Qu.:0.000 1st Qu.: 36.0
## Median :7.970 Median :24.00 Median :1.000 Median : 65.0
## Mean :7.977 Mean :24.07 Mean :0.514 Mean : 82.8
## 3rd Qu.:8.992 3rd Qu.:27.00 3rd Qu.:1.000 3rd Qu.:127.0
## Max. :9.990 Max. :30.00 Max. :1.000 Max. :236.0
## Prom_Prepa Actividades_Extras Horas_Menos_19 Horas_Mas_20
## Min. :6.010 Min. : 0.000 Min. : 0.00 Min. : 0.000
## 1st Qu.:7.110 1st Qu.: 3.000 1st Qu.: 0.00 1st Qu.: 0.000
## Median :8.020 Median : 5.000 Median : 0.00 Median : 0.000
## Mean :8.063 Mean : 5.162 Mean : 3.41 Mean : 6.358
## 3rd Qu.:9.092 3rd Qu.: 8.000 3rd Qu.: 0.00 3rd Qu.: 0.000
## Max. :9.990 Max. :10.000 Max. :19.00 Max. :40.000
## Llega_Coche Llega_Bicicleta Llega_Caminando Llega_Transporte_Publico
## Min. :0.000 Min. :0.000 Min. :0.000 Min. :0.000
## 1st Qu.:0.000 1st Qu.:0.000 1st Qu.:0.000 1st Qu.:0.000
## Median :0.000 Median :0.000 Median :0.000 Median :0.000
## Mean :0.206 Mean :0.072 Mean :0.264 Mean :0.458
## 3rd Qu.:0.000 3rd Qu.:0.000 3rd Qu.:1.000 3rd Qu.:1.000
## Max. :1.000 Max. :1.000 Max. :1.000 Max. :1.000
## Tiene_PC Tiene_Novia Horas_Perdidas Consume_Alcohol
## Min. :0.000 Min. :0.00 Min. : 0.000 Min. :0.00
## 1st Qu.:1.000 1st Qu.:0.00 1st Qu.: 2.000 1st Qu.:0.00
## Median :1.000 Median :0.00 Median : 4.000 Median :1.00
## Mean :0.848 Mean :0.38 Mean : 3.884 Mean :0.53
## 3rd Qu.:1.000 3rd Qu.:1.00 3rd Qu.: 5.000 3rd Qu.:1.00
## Max. :1.000 Max. :1.00 Max. :12.000 Max. :1.00
## Padre_Licenciatura Madre_Licenciatura
## Min. :0.000 Min. :0.00
## 1st Qu.:0.000 1st Qu.:0.00
## Median :0.000 Median :0.00
## Mean :0.304 Mean :0.38
## 3rd Qu.:1.000 3rd Qu.:1.00
## Max. :1.000 Max. :1.00Observamos el mínimo, el primer cuartil, la mediana, la media, el tercer cuartil y el máximo para las variables.
Modelo de regresión
\[PU=\hat{beta}_1+\hat{\beta}_2Edad+\hat{\beta}_3Genero+\hat{\beta}_4Tiempo_Traslado+\hat{\beta}_5Prom_Prepa+\hat{\beta}_6Actividades_Extras+\hat{\beta}_7Horas_Menos_19+\hat{\beta}_8Horas_Mas_20+\hat{\beta}_9Llega_Coche+\hat{\beta}_10Llega_Bicicleta+\hat{\beta}_11Llega_Caminando+\hat{\beta}_12Llega_Transporte_Publico+\hat{\beta}_13Tiene_PC+\hat{\beta}_14Tiene_Novia+\hat{\beta}_15Horas_Perdidas+\hat{\beta}_16Consume_Alcohol+\hat{\beta}_17Padre_Licenciatura+\hat{\beta}_18Madre_Licenciatura\] El modelo plantea verificar las variables que impactan en la calificaión de un estudiante universitario.
Modelo 1
lm_1<-lm(Prom_Licenciatura~Edad+Genero+Tiempo_Traslado+Prom_Prepa+Actividades_Extras+Horas_Menos_19+Horas_Mas_20+Llega_Coche+Llega_Bicicleta+Llega_Caminando+Llega_Transporte_Publico+Tiene_PC+Tiene_Novia+Horas_Perdidas+Consume_Alcohol+Padre_Licenciatura+Madre_Licenciatura,data=GPA_Mexico)
modelo_1<-summary(lm_1)
modelo_1##
## Call:
## lm(formula = Prom_Licenciatura ~ Edad + Genero + Tiempo_Traslado +
## Prom_Prepa + Actividades_Extras + Horas_Menos_19 + Horas_Mas_20 +
## Llega_Coche + Llega_Bicicleta + Llega_Caminando + Llega_Transporte_Publico +
## Tiene_PC + Tiene_Novia + Horas_Perdidas + Consume_Alcohol +
## Padre_Licenciatura + Madre_Licenciatura, data = GPA_Mexico)
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.73506 -1.06518 0.02973 0.99168 2.21232
##
## Coefficients: (1 not defined because of singularities)
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 7.253672 0.547327 13.253 <2e-16 ***
## Edad 0.008367 0.014567 0.574 0.5659
## Genero -0.070840 0.107747 -0.657 0.5112
## Tiempo_Traslado 0.001862 0.001261 1.477 0.1404
## Prom_Prepa 0.061468 0.045596 1.348 0.1783
## Actividades_Extras 0.001793 0.016735 0.107 0.9147
## Horas_Menos_19 -0.004716 0.008948 -0.527 0.5984
## Horas_Mas_20 -0.007199 0.004395 -1.638 0.1021
## Llega_Coche -0.149146 0.144439 -1.033 0.3023
## Llega_Bicicleta 0.165042 0.228035 0.724 0.4696
## Llega_Caminando 0.216805 0.157464 1.377 0.1692
## Llega_Transporte_Publico NA NA NA NA
## Tiene_PC -0.272879 0.148890 -1.833 0.0675 .
## Tiene_Novia -0.170048 0.109456 -1.554 0.1209
## Horas_Perdidas 0.003819 0.026984 0.142 0.8875
## Consume_Alcohol 0.155111 0.106194 1.461 0.1448
## Padre_Licenciatura 0.186831 0.115417 1.619 0.1062
## Madre_Licenciatura 0.171333 0.109854 1.560 0.1195
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.176 on 483 degrees of freedom
## Multiple R-squared: 0.04447, Adjusted R-squared: 0.01281
## F-statistic: 1.405 on 16 and 483 DF, p-value: 0.1342Pruebas de hipotesis
Demostrar que los errores suman cero
mean(modelo_1$residuals)## [1] 8.35429e-17#Prueba de no autocorrelación de los errores (Durbi-Watson)
##H0:Los errores no están autocorrelacionados
##HA:Los errores están autocorrelacionados
library(lmtest)## Cargando paquete requerido: zoo##
## Adjuntando el paquete: 'zoo'## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numericlm_1dw<-dwtest(lm_1)
lm_1dw##
## Durbin-Watson test
##
## data: lm_1
## DW = 2.0431, p-value = 0.7609
## alternative hypothesis: true autocorrelation is greater than 0El valor obtenido es p=0.7609, no existe suficiente evidencia para rechazar la hipotesis de no autocorrelación
Prueba de homocedaticidad (Breusch-Pagan)
##H0:Los errores son homocedásticos
##HA:Los errores son no homocedásticos
lm_1bp<-bptest(lm_1)
lm_1bp##
## studentized Breusch-Pagan test
##
## data: lm_1
## BP = 15.876, df = 16, p-value = 0.4616p=0.4616, por tanto no existe suficiente evidencia para rechazar la hipótesis de homocedasticidad.
Prueba de Normalidad(Jarque-Bera)
##H0:Los errores se distribuyen de forma normal
##HA:Los errores no se distribuyen de forma normal
library(tseries)## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoolm_1jb<-jarque.bera.test(modelo_1$residuals)
lm_1jb$p.value## [1] 7.483868e-07p=0.000000748, existe suficiente evidencia para rechazar la hipotesis nula.
Modelo 2
lm_2<-lm(Prom_Licenciatura~Tiempo_Traslado+Prom_Prepa+Horas_Mas_20+Llega_Coche+Llega_Caminando+Tiene_PC+Tiene_Novia+Consume_Alcohol+Padre_Licenciatura+Madre_Licenciatura,data=GPA_Mexico)
modelo_2<-summary(lm_2)
modelo_2##
## Call:
## lm(formula = Prom_Licenciatura ~ Tiempo_Traslado + Prom_Prepa +
## Horas_Mas_20 + Llega_Coche + Llega_Caminando + Tiene_PC +
## Tiene_Novia + Consume_Alcohol + Padre_Licenciatura + Madre_Licenciatura,
## data = GPA_Mexico)
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.66138 -1.05898 0.01119 0.98851 2.22914
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 7.469621 0.407268 18.341 <2e-16 ***
## Tiempo_Traslado 0.001494 0.001170 1.276 0.2024
## Prom_Prepa 0.062484 0.045297 1.379 0.1684
## Horas_Mas_20 -0.006641 0.004171 -1.592 0.1120
## Llega_Coche -0.164439 0.142108 -1.157 0.2478
## Llega_Caminando 0.172937 0.144807 1.194 0.2330
## Tiene_PC -0.278014 0.147208 -1.889 0.0595 .
## Tiene_Novia -0.162941 0.108223 -1.506 0.1328
## Consume_Alcohol 0.158025 0.105164 1.503 0.1336
## Padre_Licenciatura 0.200532 0.114180 1.756 0.0797 .
## Madre_Licenciatura 0.166878 0.108583 1.537 0.1250
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.171 on 489 degrees of freedom
## Multiple R-squared: 0.04121, Adjusted R-squared: 0.02161
## F-statistic: 2.102 on 10 and 489 DF, p-value: 0.02292dwtest(lm_2)##
## Durbin-Watson test
##
## data: lm_2
## DW = 2.0428, p-value = 0.6879
## alternative hypothesis: true autocorrelation is greater than 0bptest(lm_2)##
## studentized Breusch-Pagan test
##
## data: lm_2
## BP = 9.263, df = 10, p-value = 0.5073jarque.bera.test(modelo_2$residuals)##
## Jarque Bera Test
##
## data: modelo_2$residuals
## X-squared = 28.307, df = 2, p-value = 7.133e-07#Modelo 3
lm_3<-lm(Prom_Licenciatura~Tiene_PC+Padre_Licenciatura,data=GPA_Mexico)
modelo_3<-summary(lm_3)
modelo_3##
## Call:
## lm(formula = Prom_Licenciatura ~ Tiene_PC + Padre_Licenciatura,
## data = GPA_Mexico)
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.28076 -1.06161 0.00931 1.03703 2.08089
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 8.1376 0.1396 58.294 <2e-16 ***
## Tiene_PC -0.2585 0.1468 -1.760 0.0790 .
## Padre_Licenciatura 0.1932 0.1146 1.685 0.0925 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.179 on 497 degrees of freedom
## Multiple R-squared: 0.01179, Adjusted R-squared: 0.007818
## F-statistic: 2.966 on 2 and 497 DF, p-value: 0.05243dwtest(lm_3)##
## Durbin-Watson test
##
## data: lm_3
## DW = 2.0589, p-value = 0.7467
## alternative hypothesis: true autocorrelation is greater than 0bptest(lm_3)##
## studentized Breusch-Pagan test
##
## data: lm_3
## BP = 1.813, df = 2, p-value = 0.4039Interpretación del R cuadrado ajustado
r2_ajustado <- modelo_3$adj.r.squared
cat("El R cuadrado ajustado es:", r2_ajustado, "\n")## El R cuadrado ajustado es: 0.007817787cat("Esto indica que aproximadamente", round(r2_ajustado * 100, 2),
"% de la variabilidad en la calificación de los estudiantes es explicada por el modelo.\n")## Esto indica que aproximadamente 0.78 % de la variabilidad en la calificación de los estudiantes es explicada por el modelo.Pronósticos (mínimo, máximo y promedio)
pronosticos <- predict(lm_3)
min_pronostico <- min(pronosticos)
max_pronostico <- max(pronosticos)
mean_pronostico <- mean(pronosticos)
cat("Pronósticos:\n")## Pronósticos:cat("Mínimo pronóstico:", min_pronostico, "\n")## Mínimo pronóstico: 7.87911cat("Máximo pronóstico:", max_pronostico, "\n")## Máximo pronóstico: 8.330755cat("Promedio de pronósticos:", mean_pronostico, "\n")## Promedio de pronósticos: 7.97712Intervalo de confianza para las betas
conf_interval_betas <- confint(lm_3)
cat("Intervalos de confianza para las betas:\n")## Intervalos de confianza para las betas:print(conf_interval_betas)## 2.5 % 97.5 %
## (Intercept) 7.86332413 8.41186931
## Tiene_PC -0.54698847 0.03001453
## Padre_Licenciatura -0.03201955 0.41833690Intervalo de confianza pronóstico
Pronosticar el promedio de licenciatura utilizando el modelo
new_data <- data.frame(
Tiene_PC = 1,
Padre_Licenciatura = 1
)
prediccion <- predict(lm_3, newdata = new_data, interval = "prediction")
prediccion_media <- predict(lm_3, newdata = new_data, interval = "confidence")
prediccion## fit lwr upr
## 1 8.072268 5.748178 10.39636prediccion_media## fit lwr upr
## 1 8.072268 7.879404 8.265132Intervalo de confianza del pronóstico
predicciones <- predict(lm_3, newdata = new_data, interval = "prediction")
cat("Intervalo de confianza del pronóstico:\n")## Intervalo de confianza del pronóstico:print(predicciones)## fit lwr upr
## 1 8.072268 5.748178 10.39636Intervalo de confianza de las medias
intervalo_media <- predict(lm_3, newdata = new_data, interval = "confidence")
cat("Intervalo de confianza de la media:\n")## Intervalo de confianza de la media:print(intervalo_media)## fit lwr upr
## 1 8.072268 7.879404 8.265132