CIENCIA DE DATOS/Modelos Generales Lineales/ PROGRAMACIÓN R
Dr. Roberto Chang López/ Certificado en Machine Learning por MIT
13/12/2020
##Haga Click Aqui para ver Certificado Machine Learning MIT https://www.credential.net/4dd365ea-ea5a-46a2-a72e-539e70545c6e
##Haga Click Aqui para ver Certificado Columbia Python for Managers https://certificates.emeritus.org/0a2e1de7-add2-4710-ad49-417d1dadfb61#gs.4a92hv ##Contacto: rchang@unah.edu.hn
Algunos Dashboards elaborados son:
Para Bolsa de Valores https://rchang.shinyapps.io/rchang-stock-exchange/
Para el Estado del Clima https://rchang.shinyapps.io/rchang-app_clima_ho/
Para Machine Learning https://rchang.shinyapps.io/rchang-app/
Para Empresariales e Industriales https://rchang.shinyapps.io/rchang-app_final_emp/
Para Dashboards con log in https://rchang.shinyapps.io/clase_3-shiny-2/_w_ae4e775f/_w_f249a9a1/?page=sign_in
y para Sistemas de Información Geográfica
##Este documento presenta unos de los principales modelos generales de regresión lineal para la programación en R y que se utilizan en Machine Learning
#install.packages(“datarium”) #install.packages(“openintro”)
library(datarium)## Warning: package 'datarium' was built under R version 4.0.3library(openintro)## Warning: package 'openintro' was built under R version 4.0.5## Loading required package: airports## Warning: package 'airports' was built under R version 4.0.3## Loading required package: cherryblossom## Warning: package 'cherryblossom' was built under R version 4.0.3## Loading required package: usdata## Warning: package 'usdata' was built under R version 4.0.5y nota del examen
x nota de la tarea
y<-c(95,80,0,0,79,77,72,66,98,90,0,95,35,50,72,55,75,66)
x<-c(96,77,0,0,78,64,89,47,90,93,18,86,0,30,59,77,74,67)
n<-18Queremos explicar la nota del examen en terminos de la nota de la tarea
cor(y,x) # coeficiente de correlacion de pearson## [1] 0.91041modelos lineales con la función lm
modelo<-lm(y ~ x)
summary(modelo)##
## Call:
## lm(formula = y ~ x)
##
## Residuals:
## Min 1Q Median 3Q Max
## -26.4345 -8.8437 0.3528 9.6466 24.2731
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 10.72691 6.61733 1.621 0.125
## x 0.87265 0.09914 8.802 1.57e-07 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 13.85 on 16 degrees of freedom
## Multiple R-squared: 0.8288, Adjusted R-squared: 0.8181
## F-statistic: 77.48 on 1 and 16 DF, p-value: 1.571e-07modelo2<-lm(y ~ 0 + x)#Y = Beta X #Y = 1.01242 X
summary(modelo2)##
## Call:
## lm(formula = y ~ 0 + x)
##
## Residuals:
## Min 1Q Median 3Q Max
## -22.956 -2.102 0.056 11.137 35.000
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## x 1.01242 0.05121 19.77 3.62e-13 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 14.5 on 17 degrees of freedom
## Multiple R-squared: 0.9583, Adjusted R-squared: 0.9559
## F-statistic: 390.8 on 1 and 17 DF, p-value: 3.617e-13modelo<-lm(y ~ x)
summary(modelo)##
## Call:
## lm(formula = y ~ x)
##
## Residuals:
## Min 1Q Median 3Q Max
## -26.4345 -8.8437 0.3528 9.6466 24.2731
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 10.72691 6.61733 1.621 0.125
## x 0.87265 0.09914 8.802 1.57e-07 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 13.85 on 16 degrees of freedom
## Multiple R-squared: 0.8288, Adjusted R-squared: 0.8181
## F-statistic: 77.48 on 1 and 16 DF, p-value: 1.571e-07Ho: Beta_i=0: H1: Beta_i=0:
plot(x,y)
abline(a=modelo$coefficients[1],b=modelo$coefficients[2])
confint(modelo)## 2.5 % 97.5 %
## (Intercept) -3.3012022 24.755021
## x 0.6624861 1.082807Evaluación del modelo
res <- residuals( modelo ) # residuos
pre <- predict(modelo) #predicciones
BIC(modelo)## [1] 152.2632AIC(modelo)## [1] 149.5921como saber cual modelo se ajusta mejor
R cuadrado y Rcuadrado ajustado - mas grande mejor (>70)
AIC y BIC - mas pequeño mejor
diagnóstico del modelo
una vez tenemos el modelo ajustado procedemos con su
#diagnostico, que se realiza a traves de analisis de residuos
homogeneidad de varianzas: homocedasticidad
##install.packages(“lmtest”) ##library(“lmtest”)
#H0:Existe homogeneidad en las varianzas #H1:No existe homogeneidad en las varianzas
Test de Breusch-Pagan
library("lmtest")## Warning: package 'lmtest' was built under R version 4.0.3## Loading required package: zoo## Warning: package 'zoo' was built under R version 4.0.3##
## Attaching package: 'zoo'## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numericbptest(modelo)##
## studentized Breusch-Pagan test
##
## data: modelo
## BP = 3.9853, df = 1, p-value = 0.0459no existe homogeneidad en las varianzas
test de normalidad en los residuos
residuos<-residuals(modelo)
hist(residuos) # histograma de los residuos estandarizados 
boxplot(residuos) # diagrama de cajas de los residuos estandarizados 
qqnorm(residuos) # gráfico de cuantiles de los residuos estandarizados
qqline(residuos) 
shapiro.test(residuos)##
## Shapiro-Wilk normality test
##
## data: residuos
## W = 0.96484, p-value = 0.697Autocorrelacion o independecia en los residuos
#supuesto de no correlacion # test de Durbin-Watson
#H0: No hay autocorrelacion #H1: Si hay autocorrelacion
dwtest(modelo, alternative = "two.sided")##
## Durbin-Watson test
##
## data: modelo
## DW = 1.9597, p-value = 0.9112
## alternative hypothesis: true autocorrelation is not 0Ejercicio
Suponga que queremos saber si existe una relación entre la resistencia
de una soldadura con respecto a la antiguedad de la misma
soldadura<-read.csv("soldadura.csv")Edad en semanas
Resistencia en psi
interprete los coeficientes de regresión
valide el modelo
modelo3<-lm(soldadura$Resistencia ~ soldadura$Edad)
summary(modelo3)##
## Call:
## lm(formula = soldadura$Resistencia ~ soldadura$Edad)
##
## Residuals:
## Min 1Q Median 3Q Max
## -215.98 -50.68 28.74 66.61 106.76
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 2627.822 44.184 59.48 < 2e-16 ***
## soldadura$Edad -37.154 2.889 -12.86 1.64e-10 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 96.11 on 18 degrees of freedom
## Multiple R-squared: 0.9018, Adjusted R-squared: 0.8964
## F-statistic: 165.4 on 1 and 18 DF, p-value: 1.643e-10regresion lineal multiple/ modelo saturado
marketing<-datarium::marketing
modelo <- lm(sales ~ youtube + facebook + newspaper, data = marketing)
summary(modelo)##
## Call:
## lm(formula = sales ~ youtube + facebook + newspaper, data = marketing)
##
## Residuals:
## Min 1Q Median 3Q Max
## -10.5932 -1.0690 0.2902 1.4272 3.3951
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 3.526667 0.374290 9.422 <2e-16 ***
## youtube 0.045765 0.001395 32.809 <2e-16 ***
## facebook 0.188530 0.008611 21.893 <2e-16 ***
## newspaper -0.001037 0.005871 -0.177 0.86
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.023 on 196 degrees of freedom
## Multiple R-squared: 0.8972, Adjusted R-squared: 0.8956
## F-statistic: 570.3 on 3 and 196 DF, p-value: < 2.2e-16cor(marketing)## youtube facebook newspaper sales
## youtube 1.00000000 0.05480866 0.05664787 0.7822244
## facebook 0.05480866 1.00000000 0.35410375 0.5762226
## newspaper 0.05664787 0.35410375 1.00000000 0.2282990
## sales 0.78222442 0.57622257 0.22829903 1.0000000plot(marketing)
modelo2 <- lm(sales ~ youtube + facebook, data = marketing)
summary(modelo2)##
## Call:
## lm(formula = sales ~ youtube + facebook, data = marketing)
##
## Residuals:
## Min 1Q Median 3Q Max
## -10.5572 -1.0502 0.2906 1.4049 3.3994
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 3.50532 0.35339 9.919 <2e-16 ***
## youtube 0.04575 0.00139 32.909 <2e-16 ***
## facebook 0.18799 0.00804 23.382 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.018 on 197 degrees of freedom
## Multiple R-squared: 0.8972, Adjusted R-squared: 0.8962
## F-statistic: 859.6 on 2 and 197 DF, p-value: < 2.2e-16confint(modelo2)## 2.5 % 97.5 %
## (Intercept) 2.80841159 4.20222820
## youtube 0.04301292 0.04849671
## facebook 0.17213877 0.20384969ejercicio: validar el modelo anterior
Regresion logistica simple
#El modelo logit es un modelo de regresión tÃpico, Y=f(X+ε) #en el que la variable respuesta (variable aleatoria Y) es dicotómica o #binaria (toma dos valores: 0 y 1), habitualmente sobre si el individuo tiene #una caracterÃstica (1) o no (0), y las variables predictivas (vector aleatorio X) #son continuas. El modelo logit es un caso particular de los llamados modelos lineales #generalizados (GLMs, Generalized Linear Model).
#Un estudio quiere establecer un modelo que permita calcular la probabilidad de obtener una mencion #de honor al final del bachillerato en función de la nota que se ha obtenido en matemáticas. #La variable matrÃcula está codificada como 0 si no se tiene mencion y 1 si se tiene.
notas <- read.csv("notas.csv")
notas## X matricula matematicas
## 1 1 0 41
## 2 2 0 53
## 3 3 0 54
## 4 4 0 47
## 5 5 0 57
## 6 6 0 51
## 7 7 0 42
## 8 8 0 45
## 9 9 0 54
## 10 10 0 52
## 11 11 0 51
## 12 12 1 51
## 13 13 0 71
## 14 14 1 57
## 15 15 0 50
## 16 16 0 43
## 17 17 0 51
## 18 18 0 60
## 19 19 1 62
## 20 20 0 57
## 21 21 0 35
## 22 22 1 75
## 23 23 0 45
## 24 24 0 57
## 25 25 0 45
## 26 26 0 46
## 27 27 1 66
## 28 28 0 57
## 29 29 0 49
## 30 30 0 49
## 31 31 0 57
## 32 32 0 64
## 33 33 1 63
## 34 34 0 57
## 35 35 0 50
## 36 36 1 58
## 37 37 0 75
## 38 38 1 68
## 39 39 0 44
## 40 40 0 40
## 41 41 0 41
## 42 42 0 62
## 43 43 0 57
## 44 44 0 43
## 45 45 1 48
## 46 46 0 63
## 47 47 0 39
## 48 48 0 70
## 49 49 0 63
## 50 50 0 59
## 51 51 1 61
## 52 52 0 38
## 53 53 0 61
## 54 54 0 49
## 55 55 1 73
## 56 56 0 44
## 57 57 0 42
## 58 58 0 39
## 59 59 0 55
## 60 60 0 52
## 61 61 0 45
## 62 62 1 61
## 63 63 0 39
## 64 64 0 41
## 65 65 0 50
## 66 66 0 40
## 67 67 0 60
## 68 68 0 47
## 69 69 0 59
## 70 70 0 49
## 71 71 0 46
## 72 72 0 58
## 73 73 1 71
## 74 74 0 58
## 75 75 0 46
## 76 76 0 43
## 77 77 1 54
## 78 78 0 56
## 79 79 0 46
## 80 80 0 54
## 81 81 0 57
## 82 82 0 54
## 83 83 0 71
## 84 84 1 48
## 85 85 0 40
## 86 86 1 64
## 87 87 0 51
## 88 88 0 39
## 89 89 0 40
## 90 90 0 61
## 91 91 1 66
## 92 92 0 49
## 93 93 1 65
## 94 94 0 52
## 95 95 0 46
## 96 96 1 61
## 97 97 1 72
## 98 98 1 71
## 99 99 0 40
## 100 100 1 69
## 101 101 0 64
## 102 102 0 56
## 103 103 0 49
## 104 104 0 54
## 105 105 0 53
## 106 106 0 66
## 107 107 1 67
## 108 108 0 40
## 109 109 0 46
## 110 110 1 69
## 111 111 0 40
## 112 112 0 41
## 113 113 0 57
## 114 114 1 58
## 115 115 1 57
## 116 116 0 37
## 117 117 0 55
## 118 118 1 62
## 119 119 0 64
## 120 120 0 40
## 121 121 0 50
## 122 122 0 46
## 123 123 0 53
## 124 124 0 52
## 125 125 1 45
## 126 126 0 56
## 127 127 0 45
## 128 128 0 54
## 129 129 0 56
## 130 130 0 41
## 131 131 0 54
## 132 132 1 72
## 133 133 1 56
## 134 134 0 47
## 135 135 0 49
## 136 136 1 60
## 137 137 0 54
## 138 138 0 55
## 139 139 0 33
## 140 140 0 49
## 141 141 0 43
## 142 142 0 50
## 143 143 0 52
## 144 144 0 48
## 145 145 0 58
## 146 146 0 43
## 147 147 1 41
## 148 148 0 43
## 149 149 0 46
## 150 150 0 44
## 151 151 0 43
## 152 152 0 61
## 153 153 0 40
## 154 154 0 49
## 155 155 1 56
## 156 156 0 61
## 157 157 0 50
## 158 158 0 51
## 159 159 0 42
## 160 160 1 67
## 161 161 1 53
## 162 162 0 50
## 163 163 1 51
## 164 164 1 72
## 165 165 0 48
## 166 166 0 40
## 167 167 0 53
## 168 168 0 39
## 169 169 1 63
## 170 170 0 51
## 171 171 0 45
## 172 172 0 39
## 173 173 0 42
## 174 174 0 62
## 175 175 0 44
## 176 176 0 65
## 177 177 1 63
## 178 178 0 54
## 179 179 0 45
## 180 180 1 60
## 181 181 1 49
## 182 182 0 48
## 183 183 1 57
## 184 184 1 55
## 185 185 1 66
## 186 186 1 64
## 187 187 0 55
## 188 188 0 42
## 189 189 1 56
## 190 190 0 53
## 191 191 0 41
## 192 192 0 42
## 193 193 0 53
## 194 194 0 42
## 195 195 1 60
## 196 196 0 52
## 197 197 0 38
## 198 198 0 57
## 199 199 1 58
## 200 200 1 65table(notas$matricula)##
## 0 1
## 151 49boxplot(matematicas~matricula,notas)
modelo <- glm(matricula ~ matematicas, data = notas, family = "binomial")
summary(modelo)##
## Call:
## glm(formula = matricula ~ matematicas, family = "binomial", data = notas)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.0332 -0.6785 -0.3506 -0.1565 2.6143
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -9.79394 1.48174 -6.610 3.85e-11 ***
## matematicas 0.15634 0.02561 6.105 1.03e-09 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 222.71 on 199 degrees of freedom
## Residual deviance: 167.07 on 198 degrees of freedom
## AIC: 171.07
##
## Number of Fisher Scoring iterations: 5confint(object = modelo, level = 0.95 )## Waiting for profiling to be done...## 2.5 % 97.5 %
## (Intercept) -12.9375208 -7.0938806
## matematicas 0.1093783 0.2103937plot(matricula ~ matematicas, notas, col = "darkblue",
main = "Modelo regresión logÃstica",
ylab = "P(matrÃcula=1|matemáticas)",
xlab = "matemáticas", pch = "I")
curve(predict(modelo, data.frame(matematicas = x), type = "response"),
col = "blue", lwd = 2.5, add = TRUE)
#si alguien tiene una nota en matematica de 40, cual es la #probabilidad de tener una meción honorifica
notaMat<-70
exp(-9.79394+0.15634*(notaMat))/(1+exp(-9.79394+0.15634*(notaMat)))*100## [1] 75.94853#regresion logistica multiple
#Un estudio considera que existe relación entre el hecho de que un estudiante asista a clases de repaso de lectura (sà = 1, no = 0), #la nota que obtiene en un examen de lectura estándar (realizado antes de iniciar las clases de repaso) #y el sexo (hombre = 1, mujer = 0). Se quiere generar un modelo en el que a partir de las variables puntuación del examen y sexo, #prediga la probabilidad de que el estudiante tenga que asistir a clases de repaso.
clases<-read.csv("clases.csv")
clases## X sexo examen_lectura clases_repaso
## 1 1 hombre 91.0 0
## 2 2 hombre 77.5 0
## 3 3 mujer 52.5 0
## 4 4 mujer 54.0 0
## 5 5 mujer 53.5 0
## 6 6 hombre 62.0 0
## 7 7 mujer 59.0 0
## 8 8 hombre 51.5 0
## 9 9 mujer 61.5 0
## 10 10 mujer 56.5 0
## 11 11 hombre 47.5 0
## 12 12 hombre 75.0 0
## 13 13 hombre 47.5 0
## 14 14 hombre 53.5 0
## 15 15 mujer 50.0 0
## 16 16 mujer 50.0 0
## 17 17 hombre 49.0 0
## 18 18 mujer 59.0 0
## 19 19 hombre 60.0 0
## 20 20 mujer 60.0 0
## 21 21 hombre 60.5 0
## 22 22 mujer 50.0 0
## 23 23 mujer 101.0 0
## 24 24 hombre 60.0 0
## 25 25 hombre 60.0 0
## 26 26 mujer 83.5 0
## 27 27 mujer 61.0 0
## 28 28 mujer 75.0 0
## 29 29 hombre 84.0 0
## 30 30 hombre 56.5 0
## 31 31 hombre 56.5 0
## 32 32 mujer 45.0 0
## 33 33 hombre 60.5 0
## 34 34 mujer 77.5 0
## 35 35 hombre 62.5 0
## 36 36 mujer 70.0 0
## 37 37 mujer 69.0 0
## 38 38 mujer 62.0 0
## 39 39 mujer 107.5 0
## 40 40 mujer 54.5 0
## 41 41 hombre 92.5 0
## 42 42 mujer 94.5 0
## 43 43 hombre 65.0 0
## 44 44 mujer 80.0 0
## 45 45 mujer 45.0 0
## 46 46 mujer 45.0 0
## 47 47 mujer 66.0 0
## 48 48 hombre 66.0 0
## 49 49 mujer 57.5 0
## 50 50 hombre 42.5 0
## 51 51 mujer 60.0 0
## 52 52 hombre 64.0 0
## 53 53 mujer 65.0 0
## 54 54 mujer 47.5 0
## 55 55 hombre 57.5 0
## 56 56 hombre 55.0 0
## 57 57 hombre 55.0 0
## 58 58 hombre 76.5 0
## 59 59 hombre 51.5 0
## 60 60 hombre 59.5 0
## 61 61 hombre 59.5 0
## 62 62 hombre 59.5 0
## 63 63 hombre 55.0 0
## 64 64 mujer 70.0 0
## 65 65 hombre 66.5 0
## 66 66 hombre 84.5 0
## 67 67 hombre 57.5 0
## 68 68 hombre 125.0 0
## 69 69 mujer 70.5 0
## 70 70 hombre 79.0 0
## 71 71 mujer 56.0 0
## 72 72 hombre 75.0 0
## 73 73 hombre 57.5 0
## 74 74 hombre 56.0 0
## 75 75 mujer 67.5 0
## 76 76 hombre 114.5 0
## 77 77 mujer 70.0 0
## 78 78 mujer 67.0 0
## 79 79 hombre 60.5 0
## 80 80 mujer 95.0 0
## 81 81 mujer 65.5 0
## 82 82 mujer 85.0 0
## 83 83 hombre 55.0 0
## 84 84 hombre 63.5 0
## 85 85 hombre 61.5 0
## 86 86 hombre 60.0 0
## 87 87 hombre 52.5 0
## 88 88 mujer 65.0 0
## 89 89 mujer 87.5 0
## 90 90 mujer 62.5 0
## 91 91 mujer 66.5 0
## 92 92 hombre 67.0 0
## 93 93 mujer 117.5 0
## 94 94 mujer 47.5 0
## 95 95 mujer 67.5 0
## 96 96 mujer 67.5 0
## 97 97 mujer 77.0 0
## 98 98 mujer 73.5 0
## 99 99 mujer 73.5 0
## 100 100 mujer 68.5 0
## 101 101 mujer 55.0 0
## 102 102 mujer 92.0 0
## 103 103 hombre 55.0 0
## 104 104 mujer 55.0 0
## 105 105 hombre 60.0 0
## 106 106 hombre 120.5 0
## 107 107 mujer 56.0 0
## 108 108 mujer 84.5 0
## 109 109 mujer 60.0 0
## 110 110 hombre 85.0 0
## 111 111 mujer 93.0 0
## 112 112 hombre 60.0 0
## 113 113 mujer 65.0 0
## 114 114 mujer 58.5 0
## 115 115 mujer 85.0 0
## 116 116 hombre 67.0 0
## 117 117 mujer 67.5 0
## 118 118 hombre 65.0 0
## 119 119 mujer 60.0 0
## 120 120 hombre 47.5 0
## 121 121 mujer 79.0 0
## 122 122 hombre 80.0 0
## 123 123 mujer 57.5 0
## 124 124 mujer 64.5 0
## 125 125 mujer 65.0 0
## 126 126 mujer 60.0 0
## 127 127 mujer 85.0 0
## 128 128 mujer 60.0 0
## 129 129 mujer 58.0 0
## 130 130 mujer 61.5 0
## 131 131 hombre 60.0 1
## 132 132 mujer 65.0 1
## 133 133 hombre 93.5 1
## 134 134 hombre 52.5 1
## 135 135 hombre 42.5 1
## 136 136 hombre 75.0 1
## 137 137 hombre 48.5 1
## 138 138 hombre 64.0 1
## 139 139 hombre 66.0 1
## 140 140 mujer 82.5 1
## 141 141 mujer 52.5 1
## 142 142 mujer 45.5 1
## 143 143 hombre 57.5 1
## 144 144 hombre 65.0 1
## 145 145 mujer 46.0 1
## 146 146 mujer 75.0 1
## 147 147 hombre 100.0 1
## 148 148 mujer 77.5 1
## 149 149 hombre 51.5 1
## 150 150 hombre 62.5 1
## 151 151 hombre 44.5 1
## 152 152 mujer 51.0 1
## 153 153 mujer 56.0 1
## 154 154 mujer 58.5 1
## 155 155 mujer 69.0 1
## 156 156 hombre 65.0 1
## 157 157 hombre 60.0 1
## 158 158 mujer 65.0 1
## 159 159 hombre 65.0 1
## 160 160 hombre 40.0 1
## 161 161 mujer 55.0 1
## 162 162 hombre 52.5 1
## 163 163 hombre 54.5 1
## 164 164 hombre 74.0 1
## 165 165 hombre 55.0 1
## 166 166 mujer 60.5 1
## 167 167 hombre 50.0 1
## 168 168 hombre 48.0 1
## 169 169 mujer 51.0 1
## 170 170 mujer 55.0 1
## 171 171 hombre 93.5 1
## 172 172 hombre 61.0 1
## 173 173 hombre 52.5 1
## 174 174 hombre 57.5 1
## 175 175 hombre 60.0 1
## 176 176 mujer 71.0 1
## 177 177 mujer 65.0 1
## 178 178 mujer 60.0 1
## 179 179 mujer 55.0 1
## 180 180 hombre 60.0 1
## 181 181 hombre 77.0 1
## 182 182 hombre 52.5 1
## 183 183 mujer 95.0 1
## 184 184 hombre 50.0 1
## 185 185 mujer 47.5 1
## 186 186 hombre 50.0 1
## 187 187 hombre 47.0 1
## 188 188 hombre 71.0 1
## 189 189 mujer 65.0 1#Las tablas de frecuencia asà como representaciones gráficas de las observaciones son útiles para intuir #si las variables independientes escogidas están relacionadas con la variable respuesta y por lo tanto #ser buenos predictores.
tabla <- table(clases$clases_repaso, clases$sexo,
dnn = c("clases de repaso","sexo"))addmargins(tabla)## sexo
## clases de repaso hombre mujer Sum
## 0 57 73 130
## 1 36 23 59
## Sum 93 96 189addmargins(prop.table(tabla))## sexo
## clases de repaso hombre mujer Sum
## 0 0.3015873 0.3862434 0.6878307
## 1 0.1904762 0.1216931 0.3121693
## Sum 0.4920635 0.5079365 1.0000000mosaicplot(tabla)
library("ggplot2")## Warning: package 'ggplot2' was built under R version 4.0.5ggplot(clases, aes(x=factor(clases_repaso),y= examen_lectura, fill=factor(sexo))) +
geom_boxplot()
modelo <- glm(clases_repaso ~ examen_lectura + sexo, data = clases,
family = "binomial")
summary(modelo)##
## Call:
## glm(formula = clases_repaso ~ examen_lectura + sexo, family = "binomial",
## data = clases)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.2079 -0.8954 -0.7243 1.2592 2.0412
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.18365 0.78559 1.507 0.1319
## examen_lectura -0.02617 0.01223 -2.139 0.0324 *
## sexomujer -0.64749 0.32484 -1.993 0.0462 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 234.67 on 188 degrees of freedom
## Residual deviance: 224.64 on 186 degrees of freedom
## AIC: 230.64
##
## Number of Fisher Scoring iterations: 4Comparación de las predicciones con las observaciones
#Para este estudio se va a emplear un umbral de 0.5. Si la probabilidad predicha de asistir a #clases de repaso es superior a 0.5 se asigna al nivel 1 (sà asiste), si es menor se asigna al #nivel 0 (no clases de repaso).
predicciones <- ifelse(modelo$fitted.values > 0.5, 1, 0)
matriz_confusion <- table(modelo$model$clases_repaso, predicciones,
dnn = c("observaciones", "predicciones"))
addmargins(matriz_confusion)## predicciones
## observaciones 0 1 Sum
## 0 129 1 130
## 1 56 3 59
## Sum 185 4 189mosaicplot(matriz_confusion)
Ccorrecta<-(129+3)/189*100
Ccorrecta## [1] 69.84127ejercicio
#Se dispone de un registro que contiene cientos de emails con información de cada uno de ellos. #El objetivo de estudio es intentar crear un modelo que permita filtrar qué emails son âspamâ #y cuáles no, en función de determinadas caracterÃsticas.
#En este caso se van a emplear únicamente como posibles predictores variables categóricas. #En particular, las variables que se van a estudiar como posibles predictores son:
#spam: si el email es spam (1) si no lo es (0). #to_multiple: si hay más de una persona en la lista de distribución. #format: si está en formato HTLM. #cc: si hay otras direcciones en copia. #attach: si hay archivos adjuntos. #dollar: si el email contiene la palabra dollar o el sÃmbolo $. #inherit: si contiene la palabra inherit. #winner: si el email contiene la palabra winner. #password: si el email contiene la palabra password. #re_subj: si la palabra âRe:â está escrita en el asunto del email. #exclaim_subj: si se incluye algún signo de exclamación en el email.
email<-openintro::email
email## # A tibble: 3,921 x 21
## spam to_multiple from cc sent_email time image attach
## <fct> <fct> <fct> <int> <fct> <dttm> <dbl> <dbl>
## 1 0 0 1 0 0 2012-01-01 00:16:41 0 0
## 2 0 0 1 0 0 2012-01-01 01:03:59 0 0
## 3 0 0 1 0 0 2012-01-01 10:00:32 0 0
## 4 0 0 1 0 0 2012-01-01 03:09:49 0 0
## 5 0 0 1 0 0 2012-01-01 04:00:01 0 0
## 6 0 0 1 0 0 2012-01-01 04:04:46 0 0
## 7 0 1 1 0 1 2012-01-01 11:55:06 0 0
## 8 0 1 1 1 1 2012-01-01 12:45:21 1 1
## 9 0 0 1 0 0 2012-01-01 15:08:59 0 0
## 10 0 0 1 0 0 2012-01-01 12:12:00 0 0
## # ... with 3,911 more rows, and 13 more variables: dollar <dbl>, winner <fct>,
## # inherit <dbl>, viagra <dbl>, password <dbl>, num_char <dbl>,
## # line_breaks <int>, format <fct>, re_subj <fct>, exclaim_subj <dbl>,
## # urgent_subj <fct>, exclaim_mess <dbl>, number <fct>modelo_spam <- glm(spam ~ to_multiple + format+cc+attach + dollar+inherit+winner+ password+re_subj+exclaim_subj, data = email,
family = "binomial")
summary(modelo_spam)##
## Call:
## glm(formula = spam ~ to_multiple + format + cc + attach + dollar +
## inherit + winner + password + re_subj + exclaim_subj, family = "binomial",
## data = email)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.6348 -0.4325 -0.2566 -0.0945 3.8846
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.79976 0.08935 -8.950 < 2e-16 ***
## to_multiple1 -2.84097 0.31158 -9.118 < 2e-16 ***
## format1 -1.52284 0.12270 -12.411 < 2e-16 ***
## cc 0.03134 0.01895 1.654 0.098058 .
## attach 0.20351 0.05851 3.478 0.000505 ***
## dollar -0.07304 0.02306 -3.168 0.001535 **
## inherit 0.32999 0.15223 2.168 0.030184 *
## winneryes 1.83103 0.33641 5.443 5.24e-08 ***
## password -0.75953 0.29597 -2.566 0.010280 *
## re_subj1 -3.11857 0.36522 -8.539 < 2e-16 ***
## exclaim_subj 0.24399 0.22502 1.084 0.278221
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2437.2 on 3920 degrees of freedom
## Residual deviance: 1936.2 on 3910 degrees of freedom
## AIC: 1958.2
##
## Number of Fisher Scoring iterations: 7modelo_spam1 <- glm(spam ~ to_multiple + format+attach + dollar+inherit+winner+ password+re_subj+exclaim_subj, data = email,
family = "binomial")
summary(modelo_spam1)##
## Call:
## glm(formula = spam ~ to_multiple + format + attach + dollar +
## inherit + winner + password + re_subj + exclaim_subj, family = "binomial",
## data = email)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.6445 -0.4337 -0.2587 -0.0938 3.8838
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.79079 0.08910 -8.875 < 2e-16 ***
## to_multiple1 -2.79514 0.30808 -9.073 < 2e-16 ***
## format1 -1.52592 0.12263 -12.443 < 2e-16 ***
## attach 0.20509 0.05798 3.537 0.000404 ***
## dollar -0.07378 0.02310 -3.194 0.001404 **
## inherit 0.33499 0.15258 2.196 0.028122 *
## winneryes 1.84356 0.33755 5.462 4.72e-08 ***
## password -0.76351 0.29641 -2.576 0.009999 **
## re_subj1 -3.10746 0.36537 -8.505 < 2e-16 ***
## exclaim_subj 0.24100 0.22486 1.072 0.283830
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2437.2 on 3920 degrees of freedom
## Residual deviance: 1938.5 on 3911 degrees of freedom
## AIC: 1958.5
##
## Number of Fisher Scoring iterations: 7modelo_spam2 <- glm(spam ~ to_multiple + format+attach + dollar+inherit+winner+ password+re_subj, data = email,
family = "binomial")
summary(modelo_spam2)##
## Call:
## glm(formula = spam ~ to_multiple + format + attach + dollar +
## inherit + winner + password + re_subj, family = "binomial",
## data = email)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.6591 -0.4373 -0.2544 -0.0944 3.8707
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.78138 0.08860 -8.820 < 2e-16 ***
## to_multiple1 -2.77682 0.30752 -9.030 < 2e-16 ***
## format1 -1.51770 0.12226 -12.414 < 2e-16 ***
## attach 0.20419 0.05789 3.527 0.00042 ***
## dollar -0.06970 0.02239 -3.113 0.00185 **
## inherit 0.33614 0.15073 2.230 0.02575 *
## winneryes 1.86675 0.33652 5.547 2.9e-08 ***
## password -0.76035 0.29680 -2.562 0.01041 *
## re_subj1 -3.11329 0.36519 -8.525 < 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: 2437.2 on 3920 degrees of freedom
## Residual deviance: 1939.6 on 3912 degrees of freedom
## AIC: 1957.6
##
## Number of Fisher Scoring iterations: 7tabla1 <- table(email$spam, email$winner,
dnn = c("Spam","Ganador"))
addmargins(tabla1)## Ganador
## Spam no yes Sum
## 0 3510 44 3554
## 1 347 20 367
## Sum 3857 64 3921addmargins(prop.table(tabla1))## Ganador
## Spam no yes Sum
## 0 0.89517980 0.01122163 0.90640143
## 1 0.08849783 0.00510074 0.09359857
## Sum 0.98367763 0.01632237 1.00000000mosaicplot(tabla1)
ggplot(email, aes(x=factor(spam),y= winner, fill=factor(attach))) +
geom_boxplot()
# Comparación de las predicciones con las observaciones
#Para este estudio se va a emplear un umbral de 0.5. Si la probabilidad predicha de que recibamos un spam #es superior a 0.5 se asigna al nivel 1 (Alerta de Spam), si es menor se asigna al #nivel 0 (No es Spam).
predicciones1 <- ifelse(modelo_spam2$fitted.values > 0.5, 1, 0)
matriz_confusion1 <- table(modelo_spam2$model$spam, predicciones1,
dnn = c("observaciones", "predicciones"))
addmargins(matriz_confusion1)## predicciones
## observaciones 0 1 Sum
## 0 3551 3 3554
## 1 355 12 367
## Sum 3906 15 3921mosaicplot(matriz_confusion1)
##Cómo explica el modelo en que porcentaje
Ccorrecta<-(3551+12)/3921*100
Ccorrecta## [1] 90.86968