Modelo de Machine Learning para predecir la calidad de sueño mediante parámetros cognitivos, conductuales y fisiologicos
Trabajo de Final de Curso
Tony Estrella
2024-02-26
Descripcion de las columnas:
Person ID: An identifier for each individual.
Gender: The gender of the person (Male/Female).
Age: The age of the person in years.
Occupation: The occupation or profession of the person.
Sleep Duration (hours): The number of hours the person sleeps per day.
Quality of Sleep (scale: 1-10): A subjective rating of the quality of sleep, ranging from 1 to 10.
Physical Activity Level (minutes/day): The number of minutes the person engages in physical activity daily.
Stress Level (scale: 1-10): A subjective rating of the stress level experienced by the person, ranging from 1 to 10.
BMI Category: The BMI category of the person (e.g., Underweight, Normal, Overweight).
Blood Pressure (systolic/diastolic): The blood pressure measurement of the person, indicated as systolic pressure over diastolic pressure.
Heart Rate (bpm): The resting heart rate of the person in beats per minute.
Daily Steps: The number of steps the person takes per day.
Sleep Disorder: The presence or absence of a sleep disorder in the person (None, Insomnia, Sleep Apnea).
Objetivo:
- Analizar la relación de las variables del dataset con la presencia de problemas de sueño.
- Crear un modelo que permita predecir los problemas de sueño.
Colores utilizados:
#a2c8cc azul;
#ff6961 rojo;
#009E73 verde
Directorio de trabajo
getwd()## [1] "C:/Users/1494617/Dropbox/Doctorat/Colaboracion/formacionR"setwd("C:/Users/1494617/Dropbox/R/Curso R salamanca/trabajo final") #trabajo
#setwd("C:/Users/estre/Dropbox/R/Curso R salamanca/trabajo final") #casaLibrerias utilizadas
library(tidyverse)
library(corrplot) #corrplot
library(Hmisc) #rcorr
library(ggthemes) #temas
library(gtsummary) #tablas descriptivas
library(compareGroups) #tablas comparativas
#install.packages("")
#Configuramos el theme para que todos los graficos tengan el mismo estilo
theme_set(theme_tufte())
theme_update(axis.line = element_line())Datos del repositorio publico Kaggle
df <- read.csv("C:/Users/1494617/Dropbox/R/Curso R salamanca/trabajo final/data/Sleep_health_and_lifestyle_dataset.csv")#trabajo
#df <- read.csv("C:/Users/estre/Dropbox/R/Curso R salamanca/trabajo final/data/Sleep_health_and_lifestyle_dataset.csv")#casaProcesado de datos y limpieza
Genero
df$Gender <- as.factor(df$Gender)
df %>%
group_by(Gender) %>%
count()%>%
knitr::kable()| Gender | n |
|---|---|
| Female | 185 |
| Male | 189 |
BMI
df %>%
group_by(BMI.Category) %>%
count()%>%
knitr::kable()| BMI.Category | n |
|---|---|
| Normal | 195 |
| Normal Weight | 21 |
| Obese | 10 |
| Overweight | 148 |
Tenemos una categoria mal codificada, Nomal y Normal weight.
Con el siguiente codigo unificamos las dos:
df <- df %>%
mutate(BMI.Category = as.factor(ifelse(BMI.Category== "Normal Weight", "Normal", BMI.Category)))
df %>%
group_by(BMI.Category) %>%
count() %>%
knitr::kable()| BMI.Category | n |
|---|---|
| Normal | 216 |
| Obese | 10 |
| Overweight | 148 |
Profesion
df %>%
count(Occupation)## Occupation n
## 1 Accountant 37
## 2 Doctor 71
## 3 Engineer 63
## 4 Lawyer 47
## 5 Manager 1
## 6 Nurse 73
## 7 Sales Representative 2
## 8 Salesperson 32
## 9 Scientist 4
## 10 Software Engineer 4
## 11 Teacher 40Hay diferentes categorias laborales que pueden ser agrupadas para eliminar las profesiones infrarepresentadas de la muestra. Unificamos las profesiones de ventas y enginieria.
df <- df %>%
mutate(Occupation = ifelse(Occupation == "Sales Representative"| Occupation== "Salesperson", "Sales", Occupation))
df <- df %>%
mutate(Occupation = ifelse(Occupation == "Software Engineer", "Engineer", Occupation))
df$Occupation <- as.factor(df$Occupation)
df %>%
count(Occupation)## Occupation n
## 1 Accountant 37
## 2 Doctor 71
## 3 Engineer 67
## 4 Lawyer 47
## 5 Manager 1
## 6 Nurse 73
## 7 Sales 34
## 8 Scientist 4
## 9 Teacher 40Problema de sueño
df$Sleep.Disorder <- as.factor(df$Sleep.Disorder)
df %>%
group_by(Sleep.Disorder) %>%
count()%>%
knitr::kable()| Sleep.Disorder | n |
|---|---|
| Insomnia | 77 |
| None | 219 |
| Sleep Apnea | 78 |
Esta es nuestra variable de interés, vemos que hay una categoria de personas sanas (sin problemas de sueño) y dos categorias con problemas relacionados con el sueño (Insomnio y apneas durante el sueño).
Creamos la variable resultado o dependiente (OUTPUT) con dos categorias:
0 = No tiene ningun problema relacionado con el sueño
1 = Tiene problemas de sueño
df <- df %>%
mutate(output = as.factor(ifelse(df$Sleep.Disorder == "None", 0, 1)))
levels(df$output)<- c("Sin problemas", "Con problemas")
df %>%
group_by(output) %>%
count()%>%
knitr::kable()| output | n |
|---|---|
| Sin problemas | 219 |
| Con problemas | 155 |
Blood Pressure
Esta variable esta mal codificada por lo que debemos cambiarla. Vamos a empezar separando entre presion arterial sistolica y diastolica. Posteriormente agruparemos en:
Normal = menos de 120 y 80
Elevada = entre 120-129 y menos de 80
Hipertension = más de 130 y 80
df$sistolica <- as.numeric(sub("/.+", "", df$Blood.Pressure))
df$diastolica <- as.numeric(sub(".+/", "", df$Blood.Pressure))
df <- df %>%
mutate(tension = as.factor(ifelse(df$sistolica <= 120 & df$diastolica <= 80, "normal",
ifelse(df$sistolica > 120 & df$sistolica <= 129 & df$diastolica <= 80, "elevada", "hipertension"))))
df %>%
group_by(tension) %>%
count() %>%
knitr::kable()| tension | n |
|---|---|
| elevada | 67 |
| hipertension | 221 |
| normal | 86 |
Estres
df$Stress.Level <- as.numeric(df$Stress.Level)Calidad de sueño
df$Quality.of.Sleep <- as.numeric(df$Quality.of.Sleep)Exploracion de los datos (EDA)
df %>%
select(-Blood.Pressure) %>%
skimr::skim()| Name | Piped data |
| Number of rows | 374 |
| Number of columns | 16 |
| _______________________ | |
| Column type frequency: | |
| factor | 6 |
| numeric | 10 |
| ________________________ | |
| Group variables | None |
Variable type: factor
| skim_variable | n_missing | complete_rate | ordered | n_unique | top_counts |
|---|---|---|---|---|---|
| Gender | 0 | 1 | FALSE | 2 | Mal: 189, Fem: 185 |
| Occupation | 0 | 1 | FALSE | 9 | Nur: 73, Doc: 71, Eng: 67, Law: 47 |
| BMI.Category | 0 | 1 | FALSE | 3 | Nor: 216, Ove: 148, Obe: 10 |
| Sleep.Disorder | 0 | 1 | FALSE | 3 | Non: 219, Sle: 78, Ins: 77 |
| output | 0 | 1 | FALSE | 2 | Sin: 219, Con: 155 |
| tension | 0 | 1 | FALSE | 3 | hip: 221, nor: 86, ele: 67 |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| Person.ID | 0 | 1 | 187.50 | 108.11 | 1.0 | 94.25 | 187.5 | 280.75 | 374.0 | ▇▇▇▇▇ |
| Age | 0 | 1 | 42.18 | 8.67 | 27.0 | 35.25 | 43.0 | 50.00 | 59.0 | ▆▆▇▃▅ |
| Sleep.Duration | 0 | 1 | 7.13 | 0.80 | 5.8 | 6.40 | 7.2 | 7.80 | 8.5 | ▇▆▇▇▆ |
| Quality.of.Sleep | 0 | 1 | 7.31 | 1.20 | 4.0 | 6.00 | 7.0 | 8.00 | 9.0 | ▁▇▆▇▅ |
| Physical.Activity.Level | 0 | 1 | 59.17 | 20.83 | 30.0 | 45.00 | 60.0 | 75.00 | 90.0 | ▇▇▇▇▇ |
| Stress.Level | 0 | 1 | 5.39 | 1.77 | 3.0 | 4.00 | 5.0 | 7.00 | 8.0 | ▇▃▂▃▃ |
| Heart.Rate | 0 | 1 | 70.17 | 4.14 | 65.0 | 68.00 | 70.0 | 72.00 | 86.0 | ▇▇▂▁▁ |
| Daily.Steps | 0 | 1 | 6816.84 | 1617.92 | 3000.0 | 5600.00 | 7000.0 | 8000.00 | 10000.0 | ▁▅▇▆▂ |
| sistolica | 0 | 1 | 128.55 | 7.75 | 115.0 | 125.00 | 130.0 | 135.00 | 142.0 | ▆▅▇▂▅ |
| diastolica | 0 | 1 | 84.65 | 6.16 | 75.0 | 80.00 | 85.0 | 90.00 | 95.0 | ▃▇▇▂▅ |
Tabla descriptiva 1.1
df %>%
select(-c(Person.ID, Occupation, Blood.Pressure, Sleep.Disorder)) %>% # conserva sólo las columnas de interés
tbl_summary(
by = output, # estratifica toda la tabla por resultado
statistic = list(all_continuous() ~ "{mean} ({sd})",#estadísticas y formato de las columnas continuas
all_categorical() ~ "{n} / {N} ({p}%)"), #estadísticas y formato para columnas categóricas
digits = all_continuous() ~ 2,# redondeo para columnas continuas
type = all_categorical() ~ "categorical",# fuerza la visualización de todos los niveles categóricos
label = list( # muestra las etiquetas de las columnas
output ~ "OUTPUT",
Gender ~ "Género",
Sleep.Duration ~ "Duración Sueño",
Quality.of.Sleep ~ "Calidad de Sueño",
Physical.Activity.Level ~ "Actividad Física",
Stress.Level ~ "Nivel de estrés",
BMI.Category ~ "BMI",
Heart.Rate ~ "Frecuencia Cardíaca",
Daily.Steps ~ "Pasos diarios",
sistolica ~ "PA sistolica",
diastolica ~ "PA diastolica",
tension ~ "Tensión arterial"
),
missing_text = "Missing" # cómo deben mostrarse los valores perdidos
) %>%
add_p() %>%
modify_header(label ~ "**Variable**") %>%
modify_spanning_header(c("stat_1", "stat_2") ~ "**Problemas de Sueño**") %>%
bold_labels()| Variable | Problemas de Sueño | p-value2 | |
|---|---|---|---|
| Sin problemas, N = 2191 | Con problemas, N = 1551 | ||
| Género | <0.001 | ||
| Female | 82 / 219 (37%) | 103 / 155 (66%) | |
| Male | 137 / 219 (63%) | 52 / 155 (34%) | |
| Age | 39.04 (7.83) | 46.63 (7.84) | <0.001 |
| Duración Sueño | 7.36 (0.73) | 6.81 (0.77) | <0.001 |
| Calidad de Sueño | |||
| 4 | 0 / 219 (0%) | 5 / 155 (3.2%) | |
| 5 | 0 / 219 (0%) | 7 / 155 (4.5%) | |
| 6 | 40 / 219 (18%) | 65 / 155 (42%) | |
| 7 | 40 / 219 (18%) | 37 / 155 (24%) | |
| 8 | 101 / 219 (46%) | 8 / 155 (5.2%) | |
| 9 | 38 / 219 (17%) | 33 / 155 (21%) | |
| Actividad Física | 57.95 (20.93) | 60.90 (20.63) | 0.2 |
| Nivel de estrés | <0.001 | ||
| 3 | 40 / 219 (18%) | 31 / 155 (20%) | |
| 4 | 43 / 219 (20%) | 27 / 155 (17%) | |
| 5 | 57 / 219 (26%) | 10 / 155 (6.5%) | |
| 6 | 43 / 219 (20%) | 3 / 155 (1.9%) | |
| 7 | 3 / 219 (1.4%) | 47 / 155 (30%) | |
| 8 | 33 / 219 (15%) | 37 / 155 (24%) | |
| BMI | <0.001 | ||
| Normal | 200 / 219 (91%) | 16 / 155 (10%) | |
| Obese | 0 / 219 (0%) | 10 / 155 (6.5%) | |
| Overweight | 19 / 219 (8.7%) | 129 / 155 (83%) | |
| Frecuencia Cardíaca | 69.02 (2.66) | 71.79 (5.19) | <0.001 |
| Pasos diarios | 6,852.97 (1,393.47) | 6,765.81 (1,893.92) | 0.2 |
| PA sistolica | 124.05 (5.73) | 134.92 (5.40) | <0.001 |
| PA diastolica | 81.00 (3.99) | 89.81 (4.87) | <0.001 |
| Tensión arterial | <0.001 | ||
| elevada | 65 / 219 (30%) | 2 / 155 (1.3%) | |
| hipertension | 72 / 219 (33%) | 149 / 155 (96%) | |
| normal | 82 / 219 (37%) | 4 / 155 (2.6%) | |
| 1 n / N (%); Mean (SD) | |||
| 2 Pearson’s Chi-squared test; Wilcoxon rank sum test; Fisher’s exact test | |||
Tabla descriptiva 1.2
tdescrip <- compareGroups(output ~ . - Person.ID-Sleep.Disorder, data = df)createTable(tdescrip)##
## --------Summary descriptives table by 'output'---------
##
## _____________________________________________________________
## Sin problemas Con problemas p.overall
## N=219 N=155
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
## Gender: <0.001
## Female 82 (37.4%) 103 (66.5%)
## Male 137 (62.6%) 52 (33.5%)
## Age 39.0 (7.83) 46.6 (7.84) <0.001
## Occupation: .
## Accountant 30 (13.7%) 7 (4.52%)
## Doctor 64 (29.2%) 7 (4.52%)
## Engineer 60 (27.4%) 7 (4.52%)
## Lawyer 42 (19.2%) 5 (3.23%)
## Manager 1 (0.46%) 0 (0.00%)
## Nurse 9 (4.11%) 64 (41.3%)
## Sales 2 (0.91%) 32 (20.6%)
## Scientist 2 (0.91%) 2 (1.29%)
## Teacher 9 (4.11%) 31 (20.0%)
## Sleep.Duration 7.36 (0.73) 6.81 (0.77) <0.001
## Quality.of.Sleep 7.63 (0.98) 6.87 (1.34) <0.001
## Physical.Activity.Level 57.9 (20.9) 60.9 (20.6) 0.177
## Stress.Level 5.11 (1.59) 5.77 (1.95) 0.001
## BMI.Category: <0.001
## Normal 200 (91.3%) 16 (10.3%)
## Obese 0 (0.00%) 10 (6.45%)
## Overweight 19 (8.68%) 129 (83.2%)
## Heart.Rate 69.0 (2.66) 71.8 (5.19) <0.001
## Daily.Steps 6853 (1393) 6766 (1894) 0.627
## sistolica 124 (5.73) 135 (5.40) <0.001
## diastolica 81.0 (3.99) 89.8 (4.87) <0.001
## tension: <0.001
## elevada 65 (29.7%) 2 (1.29%)
## hipertension 72 (32.9%) 149 (96.1%)
## normal 82 (37.4%) 4 (2.58%)
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯NOTA: Los porcentajes reflejan el acomulado por columna
Las tablas descriptivas con las pruebas de significacion nos permite extraer conclusiones de las variables del estudio.
Hay diferencias significativas en las variables de:
Genero: En esta muestra las mujeres reportan tener significativamente mas problemas que los hombres.
Edad: Las personas con mayor edad tienen significativamente mas problemas.
Duración de sueño: Las personas que tienen problemas reportan dormir significativamente menos horas.
Calidad del sueño: Las personas con problemas reportan significativamente una puntuacion menor en la calidad del sueño.
Nivel de estres: Las personas con problemas reportan significativamente mayor nivel de estres.
BMI: Las personas fuera del rango normal de BMI tienen significativamente mas problemas de sueño.
Frecuencia cardiaca: Las personas con problemas tienen significativamente mas frecuencia cardiaca.
Presion arterial: Las personas con hipertension tienen significativamente mas problemas de sueño.
Graficacion
Tension Arterial
df %>%
count(output, tension)## output tension n
## 1 Sin problemas elevada 65
## 2 Sin problemas hipertension 72
## 3 Sin problemas normal 82
## 4 Con problemas elevada 2
## 5 Con problemas hipertension 149
## 6 Con problemas normal 4tens <- table(df$tension, df$output)
round(prop.table(tens)*100,2) %>%
knitr::kable()| Sin problemas | Con problemas | |
|---|---|---|
| elevada | 17.38 | 0.53 |
| hipertension | 19.25 | 39.84 |
| normal | 21.93 | 1.07 |
df %>%
ggplot(aes(tension, fill= output))+
geom_bar(position= "dodge")+
geom_text(aes(label = after_stat(count)),
stat = "count",
vjust = -.2,
position = position_dodge(.9),
color= "black")+
scale_fill_manual(values = c("#a2c8cc", "#ff6961"))+
scale_x_discrete(limits = c("normal", "elevada", "hipertension"))+
labs(y = NULL,
x = "
Tensión arterial",
fill = NULL)
Aquí vemos que dentro de las personas con hipertensión, 149 tienen problemas del sueño, mientras que 72 no. La mayoria de las personas con tension normal o elevada no tienen problemas de sueño.
Hipertensión como factor de riesgo en problemas de sueño.
Profesion
df %>%
count(output, Occupation)## output Occupation n
## 1 Sin problemas Accountant 30
## 2 Sin problemas Doctor 64
## 3 Sin problemas Engineer 60
## 4 Sin problemas Lawyer 42
## 5 Sin problemas Manager 1
## 6 Sin problemas Nurse 9
## 7 Sin problemas Sales 2
## 8 Sin problemas Scientist 2
## 9 Sin problemas Teacher 9
## 10 Con problemas Accountant 7
## 11 Con problemas Doctor 7
## 12 Con problemas Engineer 7
## 13 Con problemas Lawyer 5
## 14 Con problemas Nurse 64
## 15 Con problemas Sales 32
## 16 Con problemas Scientist 2
## 17 Con problemas Teacher 31occ<- table(df$Occupation, df$output)
round(prop.table(occ)*100,2)##
## Sin problemas Con problemas
## Accountant 8.02 1.87
## Doctor 17.11 1.87
## Engineer 16.04 1.87
## Lawyer 11.23 1.34
## Manager 0.27 0.00
## Nurse 2.41 17.11
## Sales 0.53 8.56
## Scientist 0.53 0.53
## Teacher 2.41 8.29df %>%
ggplot(aes(Occupation, fill= output))+
geom_bar(position= "dodge")+
geom_text(aes(label = after_stat(count)),
stat = "count",
vjust = -.2,
position = position_dodge(.9),
color= "black")+
scale_fill_manual(values = c("#a2c8cc", "#ff6961"))+
labs(y = NULL,
x = "
Profesión",
fill = NULL)
Aquí vemos como hay 3 profesiones que destacan más sobre las otras Nurse, Teacher, Salesperson. Son de las profesiones más representadas en el dataset pero aun asi si comparamos con otras muy representadas vemos que estas tres profesiones pueden ser propensas a problemas de sueño.
Tiene sentido que las enfermeras tenga problemas de sueño al ser una profesión donde puede haber turnos nocturnos y turnos rotatorios.
BMI
df %>%
count(output, BMI.Category)## output BMI.Category n
## 1 Sin problemas Normal 200
## 2 Sin problemas Overweight 19
## 3 Con problemas Normal 16
## 4 Con problemas Obese 10
## 5 Con problemas Overweight 129bmi<- table(df$BMI.Category, df$output)
round(prop.table(bmi)*100,2)##
## Sin problemas Con problemas
## Normal 53.48 4.28
## Obese 0.00 2.67
## Overweight 5.08 34.49df %>%
ggplot(aes(BMI.Category, fill= output))+
geom_bar(position= "dodge")+
geom_text(aes(label = after_stat(count)),
stat = "count",
vjust = -.2,
position = position_dodge(.9),
color= "black")+
scale_fill_manual(values = c("#a2c8cc", "#ff6961"))+
scale_x_discrete(limits = c("Normal", "Overweight", "Obese"))+
labs(y = NULL,
x = "
Índice de Masa Corporal (IMC)",
fill = NULL)
Estar fuera de la normalidad en el IMC es un factor de riesgo para problemas de sueño
Genero
df %>%
count(output, Gender)## output Gender n
## 1 Sin problemas Female 82
## 2 Sin problemas Male 137
## 3 Con problemas Female 103
## 4 Con problemas Male 52gen<- table(df$Gender, df$output)
round(prop.table(gen)*100,2)##
## Sin problemas Con problemas
## Female 21.93 27.54
## Male 36.63 13.90df %>%
ggplot(aes(Gender, fill= output))+
geom_bar(position= "dodge")+
geom_text(aes(label = after_stat(count)),
stat = "count",
vjust = -.2,
position = position_dodge(.9),
color= "black")+
scale_fill_manual(values = c("#a2c8cc", "#ff6961"))+
labs(y = NULL,
x = "
Género",
fill = NULL)
Hay mas mujeres que sufren de problemas de sueño
Variables cuantitativas
Histogramas
df_cuant <- df %>%
select(-c(Blood.Pressure, Gender, Person.ID, BMI.Category,
Sleep.Disorder, tension, Occupation, output))df %>%
ggplot(aes(x = Sleep.Duration))+
geom_histogram(bins = 10, fill = "#a2c8cc", col= "black")+
facet_wrap(~output, nrow = 2)+
labs(y = NULL,
x = "
Horas de Sueño")
Se puede observar en estos dos gráficos que la distribución del total de horas de sueño es diferente para aquellas personas que tienen un problema de sueño respecto a las que no lo tienen.
La distribucion de las personas sin problemas se ve una asimetria hacia la derecha con mayor presencia en la parte alta reflejando un mayor numero de horas. En cambio, la distribucion de las personas con problemas refleja una asimetria hacia la izquierda. Parece que el numero de horas en el que pivotan es 7.
Correlaciones entre las variables
df_cuant %>%
cor(method = "pearson") %>%
corrplot(type = "lower", order = "origin", method = "number",
tl.col = "black", tl.srt = 45)
p_values <- rcorr(as.matrix(df_cuant), type= "pearson")
p_values$P %>%
knitr::kable()| Age | Sleep.Duration | Quality.of.Sleep | Physical.Activity.Level | Stress.Level | Heart.Rate | Daily.Steps | sistolica | diastolica | |
|---|---|---|---|---|---|---|---|---|---|
| Age | NA | 0.0000000 | 0.0000000 | 0.0005050 | 0.0000000 | 0.0000106 | 0.2634218 | 0.0000000 | 0.0000000 |
| Sleep.Duration | 0.0000000 | NA | 0.0000000 | 0.0000347 | 0.0000000 | 0.0000000 | 0.4459038 | 0.0004549 | 0.0012244 |
| Quality.of.Sleep | 0.0000000 | 0.0000000 | NA | 0.0001745 | 0.0000000 | 0.0000000 | 0.7461907 | 0.0186166 | 0.0332071 |
| Physical.Activity.Level | 0.0005050 | 0.0000347 | 0.0001745 | NA | 0.5104667 | 0.0079889 | 0.0000000 | 0.0000002 | 0.0000000 |
| Stress.Level | 0.0000000 | 0.0000000 | 0.0000000 | 0.5104667 | NA | 0.0000000 | 0.0002801 | 0.0469200 | 0.0761716 |
| Heart.Rate | 0.0000106 | 0.0000000 | 0.0000000 | 0.0079889 | 0.0000000 | NA | 0.5590103 | 0.0000000 | 0.0000001 |
| Daily.Steps | 0.2634218 | 0.4459038 | 0.7461907 | 0.0000000 | 0.0002801 | 0.5590103 | NA | 0.0458031 | 0.0000022 |
| sistolica | 0.0000000 | 0.0004549 | 0.0186166 | 0.0000002 | 0.0469200 | 0.0000000 | 0.0458031 | NA | 0.0000000 |
| diastolica | 0.0000000 | 0.0012244 | 0.0332071 | 0.0000000 | 0.0761716 | 0.0000001 | 0.0000022 | 0.0000000 | NA |
g1 <- df %>%
ggplot(aes(Sleep.Duration, Quality.of.Sleep))+
geom_point(aes(color = output), alpha= 0.9)+
stat_smooth(method = lm,
se = FALSE,
color = "#009E73")+
theme_bw()+
scale_color_manual(values = c("#a2c8cc", "#ff6961"))+
labs(y = "Calidad del Sueño
",
x = "
Duración del Sueño",
color = NULL)
g1## `geom_smooth()` using formula = 'y ~ x'
Vemos como los puntos azules se concentran en la esquina inferior izquierda del grafico siendo esta donde menor calidad de sueño y menor num de horas autoreportadas.
Añadimos una variable para el tamaño del punto
g1 <- df %>%
ggplot(aes(Sleep.Duration, Quality.of.Sleep))+
geom_point(aes(color = output,
size = Heart.Rate),
alpha= 0.9)+
stat_smooth(method = lm,
se = FALSE,
color = "#009E73")+
theme_bw()+
scale_color_manual(values = c("#a2c8cc", "#ff6961"))+
labs(color = "Problemas de Sueño",
size = "Frecuencia Cardíaca",
y = "Calidad del sueño
",
x = "
Duración del Sueño")
g1## `geom_smooth()` using formula = 'y ~ x'
Los puntos azules se ven con menor tamaño respecto a los rojos. Por lo tanto, las personas sin problemas tienen menor frecuencia cardiaca.
Vamos a separar los graficos por otra variable Tension
g1 +
facet_wrap(~tension)## `geom_smooth()` using formula = 'y ~ x'
Conclusion de la exploracion de los datos
Nuestra variable de interes (OUTPUT) es problemas de sueño. Las categorias de esta variable son 0 si no tiene y 1 si tiene. Como hemos visto en el analisis exploratorio de los datos, hay variables que estan muy relacionadas con los problemas de sueño, estas son:
Genero
Edad
Profesion
Duracion de sueño
Calidad de sueño
Nivel de estres
BMI
Frecuencia cardiaca
Tension Arterial
Estas son variables que podemos introducir en el modelo. Con el análisis correlacional podemos ver si merece la pena eliminar alguna de las variable para reducir la multicolinealidad y tener un modelo con menos variables. Es una decisión que no tenemos porque tomar si creemos que son variables que nos ayudan a explicar el problema. Por ejemplo la calidad del sueño es un indicador subjetivo y la cantidad de sueño es algo más objetivo. Teoricamente suele haber discrepancias entre subjetividad-objetividad. Por lo tanto, parece tener sentido mantener ambas variables en el modelo.
Modelado
Libreria tidymodels
library(tidymodels)Division del dataset (DATOS)
- Seleccionamos las variables
df_ml <- df %>%
select(Gender, Age, Occupation, Sleep.Duration, Quality.of.Sleep, Stress.Level, BMI.Category, Heart.Rate, tension, output)
head(df_ml, 10)## Gender Age Occupation Sleep.Duration Quality.of.Sleep Stress.Level
## 1 Male 27 Engineer 6.1 6 6
## 2 Male 28 Doctor 6.2 6 8
## 3 Male 28 Doctor 6.2 6 8
## 4 Male 28 Sales 5.9 4 8
## 5 Male 28 Sales 5.9 4 8
## 6 Male 28 Engineer 5.9 4 8
## 7 Male 29 Teacher 6.3 6 7
## 8 Male 29 Doctor 7.8 7 6
## 9 Male 29 Doctor 7.8 7 6
## 10 Male 29 Doctor 7.8 7 6
## BMI.Category Heart.Rate tension output
## 1 Overweight 77 hipertension Sin problemas
## 2 Normal 75 elevada Sin problemas
## 3 Normal 75 elevada Sin problemas
## 4 Obese 85 hipertension Con problemas
## 5 Obese 85 hipertension Con problemas
## 6 Obese 85 hipertension Con problemas
## 7 Obese 82 hipertension Con problemas
## 8 Normal 70 normal Sin problemas
## 9 Normal 70 normal Sin problemas
## 10 Normal 70 normal Sin problemas- Dividimos el dataset en train-validation-test
set.seed(1996)
sleep_split <- initial_split(df_ml, prop= .8, strata = output)
sleep_train <- training(sleep_split)
sleep_test <- testing(sleep_split)Como el dataset es pequeño voy a hacer muestras bootstrap de los datos de entrenamiento. Por defecto la funcion bootstraps() de la libreria rsample hace 25 muestras. Son muestras con reemplazamiento de la misma size que el dataset de origen.
set.seed(2002)
sleep_boot <- bootstraps(sleep_train) #por defecto hace 25Preprocesado (RECETA)
El output esta unbalanced en nuestro dataset, una vez divididos los datos vamos a crear una receta para equilibrarlo. Lo hacemos una vez divididos para reducir el sesgo.
Un paso en la receta es crear dummy variables que nos permitira introducir en el modelo las variables tipo factor.
library(themis) #para smote
sleep_rec <-
recipe(formula = output ~ .,
data = sleep_train) %>%
step_dummy(all_nominal_predictors()) %>%
step_smote(output, neighbors = 10)La receta no es un dataset, para que lo sea hay que cocinarla con bake(). NOTA: Si preparamos la receta con prep() podemos ver los pasos directamente en los datos. No obstante, mas adelante el propio workflow prepara la receta y sería redundante si la preparamos.
#sleep_bake <- bake(sleep_rec, new_data = NULL)
#sleep_proc_test <- bake(sleep_rec, new_data = sleep_test)#sleep_bake %>%
#count(output) %>%
#knitr::kable()Modelo
Random Forest
Voy a configurar el modelo dejando los hiperparametros en abierto con tune().
Con las muestras bootstrap voy a buscar los mejores valores para estos hiperparametros.
rf_sleep <-
rand_forest(
trees = tune(),
min_n = tune(),
mtry = tune()) %>%
set_mode("classification") %>%
set_engine("ranger", importance = "impurity")
rf_sleep## Random Forest Model Specification (classification)
##
## Main Arguments:
## mtry = tune()
## trees = tune()
## min_n = tune()
##
## Engine-Specific Arguments:
## importance = impurity
##
## Computational engine: rangerRepasamos lo que tenemos:
- Datos separados
- Datos procesados con la receta
- Modelo Random Forest configurado
Lo que nos queda es juntarlo todo. Para ello utilizamos Workflow.
Workflow
Con workflow() unimos la receta y el modelo.
sleep_wf_rf <-
workflow() %>%
add_recipe(sleep_rec) %>%
add_model(rf_sleep)
sleep_wf_rf## ══ Workflow ════════════════════════════════════════════════════════════════════
## Preprocessor: Recipe
## Model: rand_forest()
##
## ── Preprocessor ────────────────────────────────────────────────────────────────
## 2 Recipe Steps
##
## • step_dummy()
## • step_smote()
##
## ── Model ───────────────────────────────────────────────────────────────────────
## Random Forest Model Specification (classification)
##
## Main Arguments:
## mtry = tune()
## trees = tune()
## min_n = tune()
##
## Engine-Specific Arguments:
## importance = impurity
##
## Computational engine: rangerConfiguramos nuestras metricas de evaluacion:
metricas <- metric_set(accuracy, precision, sensitivity, specificity, roc_auc)Tune RF
Buscamos los hiperparametros del modelo. En el modelo Random Forest lo quevamos a buscar son el numero de predictores (mtry), Numero minimo de puntos en un nodo para ser dividido (min_n) y el numero de arboles (trees).
En este punto es donde vamos a utilizar las muestras generadas con el método bootstrap.
set.seed(123)
sleep_tune_rf <-
tune_grid(
object = sleep_wf_rf,
resamples = sleep_boot,
grid = grid_max_entropy(
mtry(range = c(2, 10)),
min_n(range = c(5, 30)),
trees(range = c(100, 500)),
size = 10),
metrics = metricas,
control = control_grid(save_pred = TRUE))
sleep_tune_rf## # Tuning results
## # Bootstrap sampling
## # A tibble: 25 × 5
## splits id .metrics .notes .predictions
## <list> <chr> <list> <list> <list>
## 1 <split [299/101]> Bootstrap01 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 2 <split [299/111]> Bootstrap02 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 3 <split [299/117]> Bootstrap03 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 4 <split [299/111]> Bootstrap04 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 5 <split [299/109]> Bootstrap05 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 6 <split [299/107]> Bootstrap06 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 7 <split [299/113]> Bootstrap07 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 8 <split [299/116]> Bootstrap08 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 9 <split [299/111]> Bootstrap09 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## 10 <split [299/110]> Bootstrap10 <tibble [50 × 7]> <tibble [0 × 3]> <tibble>
## # ℹ 15 more rowsTenemos de cada muestra bootstrap las metricas de los modelos en los que se han probado los diferentes valores de los hiperparametros. Con la siguiente funcion veremos las metricas para cada configuracion.
collect_metrics(sleep_tune_rf)## # A tibble: 50 × 9
## mtry trees min_n .metric .estimator mean n std_err .config
## <int> <int> <int> <chr> <chr> <dbl> <int> <dbl> <chr>
## 1 7 131 25 accuracy binary 0.906 25 0.00560 Preprocessor1_M…
## 2 7 131 25 precision binary 0.922 25 0.00536 Preprocessor1_M…
## 3 7 131 25 roc_auc binary 0.910 25 0.00594 Preprocessor1_M…
## 4 7 131 25 sensitivity binary 0.920 25 0.00919 Preprocessor1_M…
## 5 7 131 25 specificity binary 0.886 25 0.00839 Preprocessor1_M…
## 6 9 158 10 accuracy binary 0.902 25 0.00518 Preprocessor1_M…
## 7 9 158 10 precision binary 0.918 25 0.00664 Preprocessor1_M…
## 8 9 158 10 roc_auc binary 0.909 25 0.00585 Preprocessor1_M…
## 9 9 158 10 sensitivity binary 0.917 25 0.00866 Preprocessor1_M…
## 10 9 158 10 specificity binary 0.882 25 0.00950 Preprocessor1_M…
## # ℹ 40 more rowsGraficamos las metricas de cada configuracion:
autoplot(sleep_tune_rf)
Mejoramos el grafico con ggplot2()
sleep_tune_rf %>%
collect_metrics() %>%
pivot_longer(cols = c("mtry", "trees", "min_n"), names_to = "parametro", values_to = "valor_parametro") %>%
ggplot(aes(valor_parametro, mean, color = mean))+
geom_point()+
facet_grid(.metric~parametro, scales = "free")+
scale_color_viridis_b()+
theme_bw()+
labs(y = NULL,
x = "Valores de los parámetros",
color = "Media")
Vamos a extraer las 5 configuraciones con mejores resultados en Accuracy y AUC
sleep_tune_rf %>%
show_best(metric = "accuracy", n = 1)## # A tibble: 1 × 9
## mtry trees min_n .metric .estimator mean n std_err .config
## <int> <int> <int> <chr> <chr> <dbl> <int> <dbl> <chr>
## 1 2 284 5 accuracy binary 0.910 25 0.00485 Preprocessor1_Model…sleep_tune_rf %>%
show_best(metric = "roc_auc", n=1)## # A tibble: 1 × 9
## mtry trees min_n .metric .estimator mean n std_err .config
## <int> <int> <int> <chr> <chr> <dbl> <int> <dbl> <chr>
## 1 2 284 5 roc_auc binary 0.916 25 0.00558 Preprocessor1_Model10Me quedo con la mejor configuracion de:
Numero de variables o features; mtry = 2
Arboles; trees = 284
Numero minimo de puntos en un nodo para ser dividido min_n = 5
En el anterior WF habiamos dejado los parametros en abierto, ahora tenemos que finalizarlo con la mejor configuracion de los parametros para AUC y Accuracy (son los mismos). Con last_fit() es la primera vez que utilizamos los datos de test.
sleep_rf_fit <-
sleep_wf_rf %>%
finalize_workflow(select_best(sleep_tune_rf, metric = "roc_auc")) %>%
last_fit(sleep_split)
sleep_rf_fit## # Resampling results
## # Manual resampling
## # A tibble: 1 × 6
## splits id .metrics .notes .predictions .workflow
## <list> <chr> <list> <list> <list> <list>
## 1 <split [299/75]> train/test split <tibble> <tibble> <tibble> <workflow>collect_metrics(sleep_rf_fit) #No de los datos de test## # A tibble: 3 × 4
## .metric .estimator .estimate .config
## <chr> <chr> <dbl> <chr>
## 1 accuracy binary 0.973 Preprocessor1_Model1
## 2 roc_auc binary 0.981 Preprocessor1_Model1
## 3 brier_class binary 0.0346 Preprocessor1_Model1collect_predictions(sleep_rf_fit)## # A tibble: 75 × 7
## .pred_class `.pred_Sin problemas` `.pred_Con problemas` id .row output
## <fct> <dbl> <dbl> <chr> <int> <fct>
## 1 Sin problemas 0.866 0.134 train… 2 Sin p…
## 2 Con problemas 0.141 0.859 train… 4 Con p…
## 3 Con problemas 0.289 0.711 train… 6 Con p…
## 4 Sin problemas 0.939 0.0611 train… 12 Sin p…
## 5 Con problemas 0.0940 0.906 train… 17 Con p…
## 6 Sin problemas 0.937 0.0631 train… 20 Sin p…
## 7 Sin problemas 0.932 0.0682 train… 49 Sin p…
## 8 Sin problemas 0.934 0.0655 train… 54 Sin p…
## 9 Sin problemas 0.902 0.0979 train… 55 Sin p…
## 10 Sin problemas 0.916 0.0838 train… 63 Sin p…
## # ℹ 65 more rows
## # ℹ 1 more variable: .config <chr>Predicciones en los datos de test
sleep_rf_fit %>%
extract_workflow() %>%
predict(sleep_test)## # A tibble: 75 × 1
## .pred_class
## <fct>
## 1 Sin problemas
## 2 Con problemas
## 3 Con problemas
## 4 Sin problemas
## 5 Con problemas
## 6 Sin problemas
## 7 Sin problemas
## 8 Sin problemas
## 9 Sin problemas
## 10 Sin problemas
## # ℹ 65 more rowsEvaluamos las predicciones
sleep_rf_fit %>%
collect_metrics() %>%
select(-.estimator, -.config) %>%
mutate(metrica_redondeada = round(.estimate, 2)) %>%
knitr::kable()| .metric | .estimate | metrica_redondeada |
|---|---|---|
| accuracy | 0.9733333 | 0.97 |
| roc_auc | 0.9805718 | 0.98 |
| brier_class | 0.0345548 | 0.03 |
El modelo final tiene una excelente accuracy y una AUC roc muy alta en la detección de personas con problemas de sueño.
Importancia de las variables
library(vip)importancia <- sleep_rf_fit %>%
extract_fit_parsnip() %>%
vip(geom = "col")importancia$data[1:5,] %>%
knitr::kable()| Variable | Importance |
|---|---|
| BMI.Category_Overweight | 20.983953 |
| tension_hipertension | 19.200671 |
| Age | 16.721975 |
| Sleep.Duration | 12.096820 |
| Heart.Rate | 8.627619 |
Las 5 variables que mayor peso tienen en el modelo para predecir problemas del sueño son:
IMC –> Sobrepeso (esto es debido al numero de casos en la categoria obesidad). Yo concluiria que estar fuera de la normalidad en el IMC es el factor de riesgo.
Tensión arterial –> Hipertensión
Edad
Duracion del sueño
Frecuencia cardiaca