Presentamos una breve descripción de los integrantes del grupo.

Andrea Conde

knitr::include_graphics('andre.jpg')
...

…

Me llamo Andrea Conde, tengo 21 años, estoy cursando el séptimo semestre de Ingeniería Matemática. Me gusta la investigación operativa pues sus aplicaciones en tiempo real son extraordinarias y dado que su objetivo principal es optimizar lo considero como un arte. Mi motivación más grande es mi familia, por ellos sigo luchando y dando todo de mi para poder graduarme.

Nataly Cuichán

knitr::include_graphics('Nataly.jpg')
...

…

Mi nombre es Nataly Cuichán, nací el 21 de junio de 1995 en la ciudad de Riobamba. Actualmente vivo en Quito y cruzo sexto semestre de Ingeniería Matemática en la Escuela Politécnica Nacional. Mi pasión es la matemática y sus aplicaciones, la idea de modelar, predecir y disminuir la probabilidad de cometer errores.

Alexandra Maigua

knitr::include_graphics('alexandra.jpg')
...

…

Soy Alexandra Maigua, nací el 6 de junio de 1996 en la ciudad de Quito.Estudio Ingenieía Matemática en la Escuela Politécnica Nacional. Elegí esta carrera por mi gusto a la matématica y el amplio ámbito laboral que esta ofrece.Mi objetivo es culminar mis estudios, la motivación para cumplirlo mi familia.

Cristian Solórzano

knitr::include_graphics('Cristian.png')
...

…

Soy Cristian Solórzano, nací el 4 de junio de 1995 en la ciudad de Quito. Siempre he vivido en Quito, con la excepción de que vivía por un año en el extranjero; curso sexto semestre de Ingeniería Matemática en la Escuela Politécnica Nacional. Mi pasión son las matemáticas, además tengo algunos hobbies como la natación y siempre estoy enfocado en desarrollarme tanto personal como profesionalmente.

Andrés Vinueza

knitr::include_graphics('andres.jpeg')
...

…

Soy Andrés Vinueza, cumpli 22 años el 20 de marzo. Estudio en la EPN Ingeniería Matemática, octavo semestre de mi carrera.Siempre me gustó la matemática, desde pequeño tuve curiosidad de como se obtenian los teoremas, hasta que pude aprender eso en esta carrera. También me gusta mucho programar.En el futuro me gustaría especializarme en estadística matemática y procesos estocásticos, por otro lado también trabajar en el área de la docencia, sería muy interesante y gratificante.

Librerías

Las librerías a utilizar son:

library(readr)
library(ggplot2)
library(corrplot) 
library(mlbench) 
library(Amelia) 
library(plotly) 
library(reshape2) 
library(caret)  
library(caTools) 
library(dplyr)
library(kableExtra)
library(PMCMR)

BASE DE DATOS

Presentamos la base de datos Pacientes

kable_styling(kable(pacientes),bootstrap_options = "striped", full_width = T, position = "center")
PACIENTE EDAD COLESTEROL IMC TAD GENERO
1 42 292 31.64 97 Hombre
2 64 235 30.80 90 Hombre
3 47 200 25.61 80 Hombre
4 56 200 26.17 75 Mujer
5 54 300 31.96 100 Hombre
6 48 215 23.18 67 Hombre
7 57 216 21.19 82 Mujer
8 52 254 26.95 70 Hombre
9 67 310 24.26 105 Hombre
10 46 237 21.87 70 Mujer
11 58 220 25.61 70 Hombre
12 62 233 27.92 75 Mujer
13 49 240 27.73 90 Hombre
14 56 295 22.49 95 Hombre
15 63 310 25.47 95 Hombre
16 64 268 30.04 90 Mujer
17 67 243 23.88 85 Mujer
18 49 239 21.99 75 Mujer
19 53 198 26.93 75 Mujer
20 59 218 25.47 85 Hombre
21 65 215 24.09 70 Hombre
22 67 254 28.65 105 Hombre
23 49 218 25.71 85 Hombre
24 53 221 25.33 80 Mujer
25 57 237 25.42 90 Mujer
26 47 244 23.99 85 Mujer
27 58 223 25.20 70 Mujer
28 48 198 25.81 85 Mujer
29 51 234 26.93 80 Hombre
30 49 175 27.77 80 Hombre
31 68 230 30.85 70 Mujer
32 58 248 21.61 75 Mujer
33 54 218 26.30 95 Mujer
34 59 285 31.44 100 Hombre
35 45 253 25.00 75 Hombre
36 53 187 23.31 80 Hombre
37 43 208 27.15 65 Hombre
38 57 246 21.09 80 Hombre
39 64 275 22.53 95 Hombre
40 43 218 19.83 75 Hombre
41 47 231 26.17 75 Hombre
42 58 200 25.95 90 Hombre
43 58 214 26.30 75 Mujer
44 48 230 24.89 70 Mujer
45 62 280 26.89 100 Mujer
46 54 198 21.09 65 Hombre
47 67 285 31.11 95 Hombre
48 68 201 21.60 80 Hombre
49 55 206 19.78 65 Mujer
50 50 223 22.99 75 Mujer
51 53 290 32.32 95 Mujer
52 63 315 31.14 100 Mujer
53 60 220 28.89 80 Mujer
54 46 230 20.55 75 Hombre
55 45 175 22.49 70 Hombre
56 53 213 22.53 70 Mujer
57 59 220 20.82 65 Hombre
58 62 287 32.32 95 Hombre
59 60 290 33.91 90 Hombre
60 62 209 20.76 75 Hombre
61 58 290 31.35 80 Hombre
62 57 260 31.14 95 Hombre
63 49 202 20.76 80 Mujer
64 61 214 19.59 90 Mujer
65 52 231 20.08 75 Mujer
66 59 280 31.60 100 Hombre
67 50 220 25.34 70 Hombre
68 46 233 22.86 75 Hombre
69 44 215 19.53 70 Hombre
70 60 202 19.10 65 Mujer

Esta base contiene información de una muestra de 70 pacientes con cinco caracteristícas representadas por las siguientes variables de tipo numéricas: edad, colesterol, Indice de masa corporal (IMC), tensión arterial diastólica (TAD) y por las variables de tipo caracter: paciente y género.

str(pacientes)
## Classes 'tbl_df', 'tbl' and 'data.frame':    70 obs. of  6 variables:
##  $ PACIENTE  : chr  "1" "2" "3" "4" ...
##  $ EDAD      : num  42 64 47 56 54 48 57 52 67 46 ...
##  $ COLESTEROL: num  292 235 200 200 300 215 216 254 310 237 ...
##  $ IMC       : num  31.6 30.8 25.6 26.2 32 ...
##  $ TAD       : num  97 90 80 75 100 67 82 70 105 70 ...
##  $ GENERO    : chr  "Hombre" "Hombre" "Hombre" "Mujer" ...

Para realizar una Regresión Lineal y un análisis Anova, tratamos la base de datos de la siguiente forma:

  1. Los datos vacios (NA) de cada variable han sido reemplazadas por la media respectiva.
  2. El tipo de la variable género ha sido cambiada a tipo factor con dos niveles: Hombre, Mujer.

Con esto hemos depurado nuestra base teniendo el siguiente resultado:

pacientes<-as.data.frame(pacientes)
pacientes$GENERO<-as.factor(pacientes$GENERO)
View(pacientes)

El resumen estructural :

str(pacientes)
## 'data.frame':    70 obs. of  6 variables:
##  $ PACIENTE  : chr  "1" "2" "3" "4" ...
##  $ EDAD      : num  42 64 47 56 54 48 57 52 67 46 ...
##  $ COLESTEROL: num  292 235 200 200 300 215 216 254 310 237 ...
##  $ IMC       : num  31.6 30.8 25.6 26.2 32 ...
##  $ TAD       : num  97 90 80 75 100 67 82 70 105 70 ...
##  $ GENERO    : Factor w/ 2 levels "Hombre","Mujer": 1 1 1 2 1 1 2 1 1 2 ...

El resumen estadístico :

summary(pacientes)
##    PACIENTE              EDAD         COLESTEROL         IMC       
##  Length:70          Min.   :42.00   Min.   :175.0   Min.   :19.10  
##  Class :character   1st Qu.:49.00   1st Qu.:214.2   1st Qu.:22.49  
##  Mode  :character   Median :56.00   Median :230.0   Median :25.45  
##                     Mean   :55.24   Mean   :236.8   Mean   :25.47  
##                     3rd Qu.:60.00   3rd Qu.:254.0   3rd Qu.:27.76  
##                     Max.   :68.00   Max.   :315.0   Max.   :33.91  
##       TAD            GENERO  
##  Min.   : 65.00   Hombre:41  
##  1st Qu.: 75.00   Mujer :29  
##  Median : 80.00              
##  Mean   : 81.66              
##  3rd Qu.: 90.00              
##  Max.   :105.00

En la siguiente gráfica podemos notar que no existe valores pérdidos

missmap(pacientes ,col=c('yellow','grey'),y.at=1,y.labels='',legend=TRUE)

ANALISIS EXPLORATORIO

Diagramas de las variables

grafico1<- ggplot(data = pacientes, aes(x=GENERO, y=TAD))
grafico1+
  geom_bar(stat="identity", fill=heat.colors(nrow(pacientes)))+
  labs(title="DIAGRAMA DE BARRAS",subtitle="TAD POR GENERO")+          
  scale_fill_manual(values=c('black','lightgray'))

Con este diagrama de barras, podemos notar que de los pacientes analizados, la mayoría de ellos son hombres.

Tabla de frecuencia de la variable genero:

## 
## Hombre  Mujer 
##     41     29

Que efectivamente concuerda con lo mencionado en el gráfico anterior.

Diagramas de caja de la variable continua: IMC

boxplot(pacientes$IMC ~pacientes$GENERO, col = c("light blue", " pink"),ylab = "I.M.C",xlab="Paciente")

Diagramas de caja de la variable continua: TAD

boxplot(pacientes$TAD, col='5', main="TAD")

Para la variable TAD, dado que si se tiene una tensión mayor a 90 mm HG esta es considerada alta, con el diagrama de caja se puede notar que el 25% de los pacientes tienen una presión alta, y entre estos datos hay una gran dispersión pues hay gente que tiene una presión muy alta superior a 100.

par(mfrow=c(1,1)) #CREA UNA PANTALLA DE UNA FILA Y UNA COLUMNA PARA GREAFICAR
hist(pacientes$EDAD,breaks=seq(40.5,70.5,by=5),xaxt='n', xlab='Edad', ylab='Frecuencia', col='grey',main="Histograma Edad de los Pacientes") 
axis(side=1, at=seq(40.5,70.5,by=5), labels=seq(40.5,70.5,by=5))

Existe mayor frecuencia de pacientes con edad entre 55 y 60 años. En este intervalo de edad es donde mayor es el riesgo de sufrir problemas del corazón.

boxplot(pacientes$IMC, col='3', main="IMC")

Obtenemos algo muy parecido al gráfico de TAD, ya que el 25% de pacientes que tiene un alto IMC, presentan una gran dispersión por sus valores muy altos. Por otra parte, existe menos cantidad de pacientes con alto IMC que en la variable TAD pues la mediana se encuentra casi en el centro de la caja.

boxplot(pacientes$COLESTEROL , col='22',main="COLESTEROL")

En la variable colesterol tenemos un comportamiento “normal”. A diferencia de las otras variables la gente con colesterol alto no tiene mucha dispersión.

Además tenemos un valor atípico, que corresponde a un paciente con el colesterol más alto. Se recomienda realizar un análisis especial a este paciente.

Correlación

Representación de la correlación entre las variables:edad, colesterol,IMC,TAD.

pacientesReg$PACIENTE<- as.numeric(pacientesReg$PACIENTE)

corrplot(cor(select(pacientesReg,- c(PACIENTE,GENERO) )))

Del gráfico presentado podemos observar que la varieble TAD con:

  • COLESTEROL : tiene aproximadamente 0.8 de correlacion
  • IMC : tiene apróximadamente 0.6 de correlación
  • EDAD : tiene apróximadamente 0.4 de correlación

Gráfico de densidad

El gráfico revela que las densidades máximas de TAD están entre 70 y 80.

graf<-ggplotly(pacientes %>% 
  ggplot(aes(TAD)) +
  stat_density() + 
  theme_bw())

Efecto de las variables

Veamos el efecto de las variables en la base de datos pacientes en TAD.

pacientesReg %>%
  select(c(EDAD, COLESTEROL,IMC,TAD)) %>%
  melt(id.vars = "TAD") %>%
  ggplot(aes(x = value, y = TAD, colour = variable)) +
  geom_point(alpha = 0.7) +
  stat_smooth(aes(colour = "Tendencia")) +
  facet_wrap(~variable, scales = "free", ncol = 2) +
  labs(x = "Valor de la Variable", y = "Promedio TAD") +
  theme_minimal()

Los resultados del gráfico anterior están en correlación con el corrplot.

ANOVA

Estudiaremos el efecto que tiene el Índice de masa corporal sobre hombres y mujeres.

knitr::include_graphics('colesterol.jpg')
...

…

Para ello generamos dos variables: hombres y mujeres.

str(pacientes)
## 'data.frame':    70 obs. of  6 variables:
##  $ PACIENTE  : chr  "1" "2" "3" "4" ...
##  $ EDAD      : num  42 64 47 56 54 48 57 52 67 46 ...
##  $ COLESTEROL: num  292 235 200 200 300 215 216 254 310 237 ...
##  $ IMC       : num  31.6 30.8 25.6 26.2 32 ...
##  $ TAD       : num  97 90 80 75 100 67 82 70 105 70 ...
##  $ GENERO    : Factor w/ 2 levels "Hombre","Mujer": 1 1 1 2 1 1 2 1 1 2 ...
colesterolh<<-pacientes$IMC[which(pacientes$GENERO=="Hombre")] 
colesterolm<<-pacientes$IMC[which(pacientes$GENERO=="Mujer")] 
colesterol<-c(colesterolh,colesterolm)
genero<-as.factor(c(rep("Hombre",each=length(colesterolh)),rep("Mujer",each=length(colesterolm))))
base<-data.frame(genero,colesterol)
str(base)
## 'data.frame':    70 obs. of  2 variables:
##  $ genero    : Factor w/ 2 levels "Hombre","Mujer": 1 1 1 1 1 1 1 1 1 1 ...
##  $ colesterol: num  31.6 30.8 25.6 32 23.2 ...

Creamos una nuevo data frame llamado base, en este se guarda la variable categórica para el análisis ANOVA.

colesterol<-c(colesterolh,colesterolm)
genero<-as.factor(c(rep("Hombre",each=41),rep("Mujer",each=29)))
base<-data.frame(genero,colesterol)
View(base)
str(base)
## 'data.frame':    70 obs. of  2 variables:
##  $ genero    : Factor w/ 2 levels "Hombre","Mujer": 1 1 1 1 1 1 1 1 1 1 ...
##  $ colesterol: num  31.6 30.8 25.6 32 23.2 ...

Presentamos el diagrama de caja :

boxplot(colesterol ~genero, col = c(" light blue", "pink"),ylab = "I.M.C",xlab="Pacientes")

Con la siguiente función podemos mostrar los valores atípicos.

atipicos<-function(x)
{
  N <- length(x)
  UM <- sum(is.na(x))
  n <- N - UM
  x <- x[!(is.na(x) > 0)]
  LQ1 <- (n + 1)/4
  LQ3 <- (3 * (n + 1))/4
  Sort <- sort(x)
  V1 <- floor(LQ1)
  V2 <- floor(LQ3)
  V3 <- V1 + 1
  V4 <- V2 + 1
  Q1 <- round(Sort[V1] + (LQ1 - V1) * (Sort[V3] - Sort[V1]), 
              3)
  Q3 <- round(Sort[V2] + (LQ3 - V2) * (Sort[V4] - Sort[V2]), 
              3)
  IQR <- round(Q3 - Q1, 3)
  l.out <- x[x < (Q1 - 1.5 * IQR)]
  r.out <- x[x > (Q3 + 1.5 * IQR)]
  outliers <- c(l.out, r.out)
  return(outliers)
}

Valores atípicos en hombres

atipicos(colesterolh)
## numeric(0)

Valores atípicos en mujeres

atipicos(colesterolm)
## numeric(0)

La siguiente tabla muestra la media de los niveles: hombre, mujer.

round(tapply(colesterol,genero,mean),3)
## Hombre  Mujer 
## 25.933 24.819

ANOVA y pruebas POST-HOC

Partimos del siguiente contraste: \[H_0: \mu_1=\mu_2\\H_a:\mu_1\neq\mu_2\]. Donde \(\mu_1:\) Media de los hombres, \(\mu_2:\) Media de las mujeres

Presentamos la tabla ANOVA:

pct= aov( lm( colesterol ~genero) )
pct
## Call:
##    aov(formula = lm(colesterol ~ genero))
## 
## Terms:
##                    genero Residuals
## Sum of Squares    21.0739 1030.8135
## Deg. of Freedom         1        68
## 
## Residual standard error: 3.893459
## Estimated effects may be unbalanced

Pedimos un resumen de la tabla ANOVA

summary(pct)
##             Df Sum Sq Mean Sq F value Pr(>F)
## genero       1   21.1   21.07    1.39  0.242
## Residuals   68 1030.8   15.16

El valor crítico de F 

round(summary(pct)[[1]][1,4],3)
## [1] 1.39

Los grados de libertad del factor:

round(summary(pct)[[1]][1,1],3)
## [1] 1

Los grados de libertad del residuo:

round(summary(pct)[[1]][2,1],3)
## [1] 68

El valor de P

round(summary(pct)[[1]][1,5],3)
## [1] 0.242

Bajo la Ho el estadístico de contraste F se distribuye con una F de Fisher \(F_{(I-1), (n-I)}\) grados de libertad donde I es el número de grupos que disponemos y n el tamaño total de la muestra. Así obtenemos el cuantil buscado:

round(qf(0.05, 2-1, length(colesterol)-2, lower.tail = F),3)
## [1] 3.982

Dado que los valor crítico de F es menor que el valor del estadístico no rechazamos la hipótesis nula , es decir la media del índice de masa corporal en hombres y mujeres son iguales.

Otra forma de constatar dicha aseveración es usar la prueba de Tukey:

intervalos = TukeyHSD(pct)
intervalos
##   Tukey multiple comparisons of means
##     95% family-wise confidence level
## 
## Fit: aov(formula = lm(colesterol ~ genero))
## 
## $genero
##                  diff       lwr       upr     p adj
## Mujer-Hombre -1.11386 -2.998979 0.7712581 0.2424821

Dado que p adj es mayor a 0.05, determinamos que el grupo es estadisticamente igual en media, ya que el grupo Mujer -Hombre al contener al cero prueba lo afirmado con un \(95\%\) de confianza, como se notamos en el gráfico siguiente:

plot(intervalos)

Ahora procedemos con el valor para la estimación de la varianza común de los datos, que tiene un valor de:

s<-round(summary(pct)[[1]][2,3],0)
s
## [1] 15

La tabla siguiente muestra los intervalos de confianza para los dos grupos:

valor_t <- pt(0.05/2,70-2) 
sp <- sqrt(s)

media_h <- mean(colesterol[genero =="Hombre"]) 
ee_h  <- valor_t * (sp/ sqrt(length(colesterolh)))  

media_m <- mean(colesterol[genero=="Mujer"]) 
ee_m<- valor_t * (sp/ sqrt(length(colesterolm)))
 

limite_inferior<-c(round(media_h-ee_h,3),round(media_m-ee_m,3))
limite_superior<-c(round(media_h+ee_h,3),round(media_m+ee_m,3))
a<-data.frame(limite_inferior,limite_superior)
row.names(a)<-c("Hombre","Mujer")
a
##        limite_inferior limite_superior
## Hombre          25.625          26.242
## Mujer           24.453          25.186

Validación del modelo ANOVA

Para obtener resultados confiables mediante el ANOVA, analizaremos los residuos. Estos deben cumplir tres supuestos: independencia, homocedasticidad y normalidad.

Independencia

plot(pct$residuals)

Los residuos son idependientes pues no existen patrones obvios en el gráfico y se notan dispersos.

Normalidad

Para analizar la normalidad de los residuos nos ayudaremos de gráficos y descriptivos, con los que determinaremos si basta se verifica en los grupos descritos (hombres y mujeres):

summary(pct$residuals)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
## -6.4032 -3.1753 -0.2732  0.0000  2.1007  7.9768
boxplot(pct$residuals, col="gray")

hist(pct$residuals,main="Histograma de los residuales",xlab="Residuos",ylab="Frecuencia", col="gray")

qqnorm(pct$residuals) 
qqline(pct$residuals)

El test de Shapiro-Wilk indica que tenemos evidencia suficiente para aceptar la hipótesis nula (normalidad de los residuos).

shapiro.test(pct$residuals)
## 
##  Shapiro-Wilk normality test
## 
## data:  pct$residuals
## W = 0.95669, p-value = 0.0165

Por los gráficos presentados y apoyados en el test de Shapiro-Wilk determinamos que los residuos son normales, de media cero.

Homocedasticidad

Los gráficos y descriptivos nos ayudaran a determinar si se verifica la igualdad de varianzas en los grupos:

boxplot(pct$residuals~genero, col = c("light blue", "pink"))

Podemos apreciar que la dispersión de los datos en el grupo Hombre y en el grupo Mujer es similar, y lo evidenciamos en la siguente tabla:

desviaciones <- tapply(pct$residuals, genero, sd)
round(desviaciones,3)
## Hombre  Mujer 
##  4.042  3.672

Para obtener una orientación sobre la homocedasticidad, comparamos la desviación máxima con la mínima:

round(max(desviaciones) / min(desviaciones),3)
## [1] 1.101

Para verificar la homocedasticidad usaremos la prueba de Bartlett, este estadístico sigue \(\chi^2_{\alpha,I-1}\) grados de libertad.

bartlett.test(pct$residuals ~ genero)
## 
##  Bartlett test of homogeneity of variances
## 
## data:  pct$residuals by genero
## Bartlett's K-squared = 0.2953, df = 1, p-value = 0.5868

El valor crítico es:

bartlett.test(pct$residuals ~ genero)[1]
## $statistic
## Bartlett's K-squared 
##            0.2953031

El valor teórico:

qchisq(0.05, 2-1, lower.tail = F)
## [1] 3.841459

Dado que 0.29 < 3.84, concluimos que hay presencia de homocedasticidad, es decir, las varianzas son iguales entre hombres y mujeres.

Ya que es importante que estos supuestos se cumplan para obtener resultados confiables en el análisis ANOVA, podemos concluir que hay evidencia estadísticamente significativa de igualdad en media del IMC para hombres y mujeres.
Para comprobar los resultados ya obtenidos, continuamos con la prueba no parametrica Kruskal-Wallis:

Kruskal-Wallis y pruebas post-hoc

Realizamos la prueba de Kruskal-Wallis bajo el siguiente contraste:

\[ H_0: \sigma_1=\sigma_2\\ H_a:\sigma_1\neq\sigma_2\]

kruskal.test(colesterol, genero)
## 
##  Kruskal-Wallis rank sum test
## 
## data:  colesterol and genero
## Kruskal-Wallis chi-squared = 1.2165, df = 1, p-value = 0.2701

Bajo la Ho el estadístico de contraste del test de Kruskal-Wallis se distribuye como una Chi-cuadrado \(\chi_{(I-1)}\) grados de libertad (donde I es el número de grupos que disponemos). Así obtenemos el cuantil buscado:

round(qchisq(0.05, 2-1, lower.tail = F),3)
## [1] 3.841

Dado que el valor de contraste es menor que el valor del estadístico no rechazamos la hipótesis inicial, es decir los valores del estadístico > 3.841 estarán incluidos en la región de rechazo. En nuestro caso 1.2165 es menor que el valor crítico obtenido.

Si transformaramos los datos de la variable respuesta, utilizando logaritmos y después aplicaramos el test de KrusKal-Wallis al logaritmo del IMC, ¿variarian los resultados del test estadístico?

kruskal.test(log(colesterol), genero) 
## 
##  Kruskal-Wallis rank sum test
## 
## data:  log(colesterol) and genero
## Kruskal-Wallis chi-squared = 1.2165, df = 1, p-value = 0.2701

Los resultados son exactamente los mismos. No se producen variaciones porque el test de Kruskal-Wallis trabaja sobre rangos, es decir, sobre ordenaciones de los valores de la variable en cada uno de los grupos. Aunque realicemos una transformación logarítmica, el orden entre los valores de la variable se mantiene y por lo tanto la transformación no afecta a los resultados del test.

CONSTRUCCION DEL MODELO Y PREDICCION

Train Y Test Data

set.seed(123)
split <- sample.split(pacientes,SplitRatio =0.75)
train <- subset(pacientes,split==TRUE)
test <- subset(pacientes,split==FALSE)

Entrenando nuestro modelo

Procedemos a construir nuestro modelo teniendo en cuenta que EDAD,IMC,COLESTEROL Y GENERO son posibles influyentes en la variable objetivo (TAD); luego de analizar los resultados anteriores con un nivel de confianza de 0.9, obtenemos lo siguiente:

modelo <- lm(TAD ~ COLESTEROL+IMC+EDAD, data = train)
summary(modelo)
## 
## Call:
## lm(formula = TAD ~ COLESTEROL + IMC + EDAD, data = train)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -16.1825  -7.1278  -0.0631   6.2906  16.3836 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 14.02851   12.73157   1.102   0.2766    
## COLESTEROL   0.17416    0.03967   4.390 7.24e-05 ***
## IMC          0.62838    0.37114   1.693   0.0977 .  
## EDAD         0.18693    0.18145   1.030   0.3087    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 8.196 on 43 degrees of freedom
## Multiple R-squared:  0.4717, Adjusted R-squared:  0.4348 
## F-statistic:  12.8 on 3 and 43 DF,  p-value: 4.13e-06

El valor Pr(>|t|) indica si la variable es estadisticamente significativa para el modelo, mientras más pequeña sea la probabilidad más significativa es la variable. Asi tenemos una lista de variables que podemos extraer del modelo pero no debemos quitarlas todas en conjunto, si no una a una desde la menos significativa, debido a que nos puede generar un efecto en el resto de variables.

Así, procedemos a quitar la variable EDAD pues es la menos estadisticamente significativa del modelo.Entonces:

modelo <- lm(TAD ~ COLESTEROL+IMC, data = train)
summary(modelo)
## 
## Call:
## lm(formula = TAD ~ COLESTEROL + IMC, data = train)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -15.6583  -6.4140  -0.0572   6.7623  16.3962 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 21.74564   10.30178   2.111   0.0405 *  
## COLESTEROL   0.18454    0.03839   4.807 1.82e-05 ***
## IMC          0.63222    0.37138   1.702   0.0957 .  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 8.201 on 44 degrees of freedom
## Multiple R-squared:  0.4586, Adjusted R-squared:  0.434 
## F-statistic: 18.64 on 2 and 44 DF,  p-value: 1.371e-06

Visualizando nuestro modelo

Podemos visualizar nuestro modelo de regresión lineal trazando los residuos. La diferencia entre el valor observado de la variable dependiente y el valor predicho se denomina residual.

res <- residuals(modelo)
par(mfrow=c(1,1)) #CREA UNA PANTALLA DE UNA FILA Y UNA COLUMNA PARA GRAFICAR
hist(res,breaks=seq(-19.5,20.5,by=5),xaxt='n', xlab='Residuos', ylab='Frecuencia', col='skyblue',main="Histograma Residuos") 
axis(side=1, at=seq(-19.5,20.5,by=5), labels=seq(-19.5,20.5,by=5))

plot(modelo)

res <- as.data.frame(res)
a<-c()
for(i in 1:length(res[,1])){
  a[i]=res[i,]
}

 shapiro.test(as.numeric(a))
## 
##  Shapiro-Wilk normality test
## 
## data:  as.numeric(a)
## W = 0.97478, p-value = 0.3975

Como en la variable res tenemos solo 47 datos usaremos la prueba de Shapiro Wilk. Obtenemos que p-valor es mayor a 0.05, por lo tanto se acepta que los residuos (res) son normales.

Predicciones

Probemos nuestro modelo prediciendo en nuestro conjunto de datos de prueba.

test$predicted.TAD <- predict(modelo,test)
pl1 <-test %>% 
  ggplot(aes(TAD,predicted.TAD)) +
  geom_point(alpha=0.5) + 
  stat_smooth(aes(colour='black')) +
  xlab('Valor Actual de TAD') +
  ylab('Valor Predicho de la variable TAD')+
  theme_bw()
ggplotly(pl1)

Evaluemos nuestro modelo

usando Root Mean Square Error, una medida estandarizada de cuán lejos estábamos con nuestros valores predichos.

error <- test$TAD-test$predicted.TAD
rmse <- sqrt(mean(error)^2)

Nuestro modelo tiene un rmse de 0.3434974.

CONCLUSIONES Y RECOMENDACIONES

library(PMCMR)
posthoc.kruskal.nemenyi.test(colesterol, genero, method = "Chisq")
## 
##  Pairwise comparisons using Tukey and Kramer (Nemenyi) test  
##                    with Tukey-Dist approximation for independent samples 
## 
## data:  colesterol and genero 
## 
##       Hombre
## Mujer 0.27  
## 
## P value adjustment method: none

\[TAD=21.75+0.63\,IMC+0.18\,COLESTEROL+\mu\]