Abstract

Introducción: La variabilidad de la frecuencia cardíaca (HRV) se considera un indicador objetivo y no invasivo de salud y condición física (Heiss et al., 2021). Los atletas típicamente exhiben una mejor función autonómica cardíaca, caracterizada por una mayor variabilidad, en comparación con los no atletas (Souza et al., 2021).

Antecedentes y motivación del trabajo: Con el reciente crecimiento de la ciencia de datos y en concreto con los algoritmos de aprendizaje automático, es posible identificar características relacionadas con la condición física (Miah et al., 2023). El objetivo de este trabajo fue identificar y predecir la condición atlética a partir de registros de HRV utilizando algoritmos de aprendizaje automático.

Metodología: El conjunto de datos contiene 1350 registros de HRV de 5 minutos en reposo de 331 participantes. La muestra es de 141 deportistas de alto nivel y 190 estudiantes, con un rango de edad entre 18 y 30 años. Se aplicó el modelo de aprendizaje automático random forest, dividiéndose el conjunto de datos en 80% entrenamiento y 20% test. Se realizaron tres modelos. En el modelo 1 se identificó a los deportistas dentro de la totalidad de la muestra. En los modelos 2 y 3 se identificó a un caso único dentro de la muestra del estudio y dentro de la muestra de futbolistas respectivamente.

Resultados: El modelo 1 ha obtenido una precisión del 81% en la identificación de deportistas de alto nivel respecto a estudiantes, con un área bajo la curva ROC de 0.89. Los cinco principales parámetros de HRV predictores fueron mRR, HFnu, pNN50, VLFnu y HF. En el modelo 2 y 3 se ha obtenido una precisión del 93% y del 91% en la identificación de un caso, con áreas bajo la curva ROC de 0.84 y 0.96 respectivamente. Dentro de las variables más importantes en estos modelos se encuentran mRR, LFnu, HFnu, pNN50 y RMSSD.

Discusión/conclusiones: El modelo permite predecir el índice de condición atlética de una persona a partir de un test de HRV en reposo, rápido y no invasivo, realizado con tecnología mHealth. Con la identificación de un caso el modelo podría aplicarse para la detección de patrones atípicos como indicadores de fatiga y sobreesfuerzo. Por ejemplo, el índice desarrollado podría suponer una herramienta muy útil para monitorizar el proceso de esfuerzo/recuperación de los deportistas durante los entrenamientos.

Palabras clave: HRV, machine learning, random forest, sports characteristics prediction, fatigue, effort, mHealth.

Descripcion de los modelos

Modelo 1 Clasificacion de deportistas basado en las caracteristicas de los parametros de HRV. En este modelo el objetivo es diferenciar a los atletas profesionales de las personas no-atletas o estudiantes.

Modelo 2 Detectar un caso concreto dentro de la muestra del estudio. El objetivo de este modelo es identificar a un caso concreto a traves de los parametros de HRV.

Modelo 3 Detectar a un caso concreto dentro de la muestra de pertenenccia. En el modelo 3 el objetivo es idenficar a un caso dentro de su grupo. En concreto, detectar a un futbolista dentro de la muestra de futbolistas.

Librerias

library(tidyverse)
library(readxl)
library(tidymodels)
library(skimr)
library(compareGroups)
library(themis)
library(DALEXtra)
theme_set(theme_bw())

Datos

#df<- read_excel("C:/Users/estre/Dropbox/Doctorat/DA HRV/ML Analysis/data/HRV v10_Total Param UPC_130seg.xls")
df<- read_excel("C:/Users/1494617/Dropbox/Doctorat/DA HRV/ML Analysis/data/HRV v10_Total Param UPC_130seg.xls")

df$Sport<-as.factor(df$Sport)
levels(df$Sport)<- c("soccer", "hockey", "basket", "student") 

df$Sport2<-as.factor(df$Sport2)
levels(df$Sport2)<- c("Student", "Athlete")

df <- df %>% 
  select(-c(Breathing, Team_Club, Gender, Age, Weight, Height, 'Duration(s)', Semafor_3)) #Seleccionamos variables

df %>% 
  head()

## # A tibble: 6 × 19
##   Subject Sport Sport2 mRR_UPC SDNN_UPC RMSSD_UPC pNN50_UPC ti_UPC HF_UPC LF_UPC
##     <dbl> <fct> <fct>    <dbl>    <dbl>     <dbl>     <dbl>  <dbl>  <dbl>  <dbl>
## 1       1 socc… Athle…   1070.     88.2      68.7      36.4   312   1542.   718.
## 2       1 socc… Athle…    883.     63.4      40.8      19.7   298.   675.  2075.
## 3       1 socc… Athle…    977.     65.3      54.5      39.8   172.  1463.  1383.
## 4       2 socc… Athle…   1239.     70.8      60.3      47.1   243.   909.  4011.
## 5       3 socc… Athle…   1185.    123.      132.       75.2   307.  3492.  1330.
## 6       5 socc… Athle…   1021.     50.5      42.4      26.0   170.   496.   967.
## # ℹ 9 more variables: VLF_UPC <dbl>, `LF/HF_UPC` <dbl>, HFnu_UPC_2v <dbl>,
## #   HFnu_UPC_3v <dbl>, VLFnu_UPC_3v <dbl>, LFnu_UPC_3v <dbl>, SD1_UPC <dbl>,
## #   SD2_UPC <dbl>, LFnu_UPC_2v <dbl>

Tenemos el DF con las variables de interes:

Variables de agrupación:
- Sport2 = Atleta vs. estudiante (M1)
- Subject = Sujeto (M2 y M3)
Variables de HRV calculadas y filtradas

Algoritmos

Configuramos los algoritmos dejandolos en abierto con tune() para que en cada conjunto de datos podamos elegir el mejor modelo.

Random Forest

rf_spec <- 
  rand_forest(
    mtry = tune(),
    trees = tune(),
    min_n = tune()
  ) %>% 
  set_mode("classification") %>% 
  set_engine("ranger", importance = "impurity")

XGBoost

xgb_spec <- 
  boost_tree(
    mtry = tune(),
    trees = tune(),
    min_n = tune(),
    learn_rate = tune()
  ) %>% 
  set_mode("classification") %>% 
  set_engine("xgboost", importance = "impurity")

Support Vector Machine

svm_spec <-
  svm_rbf(
    cost = tune(),
    rbf_sigma = tune()
    ) %>%
  set_mode("classification") %>%
  set_engine("kernlab")

En este apartado estan los tres algoritmos de ML que vamos a utilizar en todos los modelos. Como vemos todos los hyperparametros estan abiertos para buscar la mejor configuracion en cada conjunto de datos.

Metricas

Dejamos configuradas las metricas de evaluacion que vamos a utilizar en todos los modelos.

metricas_modelo <- metric_set(accuracy, precision, sensitivity, specificity, roc_auc,recall)

Modelo 1. Atleta vs Estudiante

EDA Datos M1

at_df <- df %>% 
  select(-Sport)

at_df %>% count(Sport2)

## # A tibble: 2 × 2
##   Sport2      n
##   <fct>   <int>
## 1 Student   494
## 2 Athlete   856

tabla_descrip_M1 <- compareGroups(Sport2 ~ . -Subject, data= at_df)

createTable(tabla_descrip_M1)

## 
## --------Summary descriptives table by 'Sport2'---------
## 
## ______________________________________________ 
##                Student     Athlete   p.overall 
##                 N=494       N=856              
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯ 
## mRR_UPC       903 (140)  1120 (163)   <0.001   
## SDNN_UPC     72.6 (32.6) 78.1 (35.7)   0.004   
## RMSSD_UPC    73.3 (44.3) 81.6 (49.4)   0.002   
## pNN50_UPC    39.2 (22.8) 45.5 (22.3)  <0.001   
## ti_UPC       224 (97.1)   233 (115)    0.116   
## HF_UPC       3796 (4555) 2705 (4279)  <0.001   
## LF_UPC       1070 (1518) 2020 (3664)  <0.001   
## VLF_UPC      717 (1251)  1666 (2044)  <0.001   
## LF/HF_UPC    0.63 (1.25) 1.37 (1.78)  <0.001   
## HFnu_UPC_2v  72.7 (20.2) 53.7 (20.5)  <0.001   
## HFnu_UPC_3v  61.7 (22.5) 38.6 (19.3)  <0.001   
## VLFnu_UPC_3v 16.5 (14.6) 29.7 (18.3)  <0.001   
## LFnu_UPC_3v  21.7 (16.0) 31.7 (16.1)  <0.001   
## SD1_UPC      51.8 (31.3) 57.7 (34.9)   0.002   
## SD2_UPC      87.8 (35.8) 92.8 (39.8)   0.017   
## LFnu_UPC_2v  27.3 (20.2) 46.3 (20.5)  <0.001   
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯

at_df %>% 
  ggplot(aes(mRR_UPC, fill = Sport2))+
  geom_density(alpha = 0.5)+
  labs(title= "mRR",
       fill = "")

Division Datos M1

set.seed(1996)
at_split <- group_initial_split(at_df, Subject, prop= 0.8, strata = Sport2)
at_training <- training(at_split)
at_test <- testing(at_split)

at_split

## <Training/Testing/Total>
## <1086/264/1350>

Del dataframe original 1086 observaciones son para entrenamiento y 264 para test. Hay que tener en cuenta que esta divison se ha hecho por sujeto, las observaciones de un sujeto unico estan en la misma division para evitar overfitting.

Creamos muestras bootstrap de los datos de entrenamiento que sera donde vamos a ir a buscar los hiperparametros de los modelos.

set.seed(2024)
at_boot <- bootstraps(at_training, strata = Sport2)
at_boot

## # Bootstrap sampling using stratification 
## # A tibble: 25 × 2
##    splits             id         
##    <list>             <chr>      
##  1 <split [1086/395]> Bootstrap01
##  2 <split [1086/388]> Bootstrap02
##  3 <split [1086/401]> Bootstrap03
##  4 <split [1086/389]> Bootstrap04
##  5 <split [1086/405]> Bootstrap05
##  6 <split [1086/396]> Bootstrap06
##  7 <split [1086/399]> Bootstrap07
##  8 <split [1086/405]> Bootstrap08
##  9 <split [1086/364]> Bootstrap09
## 10 <split [1086/385]> Bootstrap10
## # ℹ 15 more rows

Se han creado 25 muestras de los datos de entrenamiento manteniendo la estratificación/estructura de la variable Sport2.

Receta M1

En esta receta prepramos los pasos de preprocesamiento para los modelos.

at_rec<- 
  recipe(formula = Sport2 ~  ., 
         data = at_training) %>% #datos de entrenamiento
  step_rm(Subject) %>% 
  step_smote(Sport2, neighbors = 10)

Hemos eliminado en esta receta la variable sujeto que nos servia para evitar que cayeran casos del mismo sujeto en los dos conjuntos de datos.
Con SMOTE corregimos que el dataset este desequilibrado.
Hemos escalado previamente las variables y los resultados de los modelos no han cambiado. Para facilitar la posterior interpretabilidad de los modelos las dejamos en sus valores originales.

Workflow M1

Random Forest

at_wf_rf <- 
  workflow() %>% 
  add_recipe(at_rec) %>% 
  add_model(rf_spec)

XGBoost

at_wf_xgb <- workflow() %>% 
  add_recipe(at_rec) %>% 
  add_model(xgb_spec)

Support Vector Machine

at_wf_svm <- workflow() %>% 
  add_recipe(at_rec) %>% 
  add_model(svm_spec)

Hyperparametros M1

Ranfom Forest

doParallel::registerDoParallel()

set.seed(1234)

at_hyperparametros_rf <-
  tune_grid(
  object = at_wf_rf,
  resamples = at_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_modelo,
  control = control_grid(save_pred = TRUE)
  )

Evaluacion hyperparametros M1

at_hyperparametros_metricas_rf <- 
  at_hyperparametros_rf %>% 
  collect_metrics()

at_hyperparametros_metricas_rf

## # A tibble: 60 × 9
##     mtry trees min_n .metric     .estimator  mean     n std_err .config         
##    <int> <int> <int> <chr>       <chr>      <dbl> <int>   <dbl> <chr>           
##  1    10   485     8 accuracy    binary     0.849    25 0.00321 Preprocessor1_M…
##  2    10   485     8 precision   binary     0.781    25 0.00669 Preprocessor1_M…
##  3    10   485     8 recall      binary     0.808    25 0.00568 Preprocessor1_M…
##  4    10   485     8 roc_auc     binary     0.911    25 0.00281 Preprocessor1_M…
##  5    10   485     8 sensitivity binary     0.808    25 0.00568 Preprocessor1_M…
##  6    10   485     8 specificity binary     0.872    25 0.00438 Preprocessor1_M…
##  7     9   206    16 accuracy    binary     0.850    25 0.00334 Preprocessor1_M…
##  8     9   206    16 precision   binary     0.781    25 0.00730 Preprocessor1_M…
##  9     9   206    16 recall      binary     0.810    25 0.00592 Preprocessor1_M…
## 10     9   206    16 roc_auc     binary     0.912    25 0.00288 Preprocessor1_M…
## # ℹ 50 more rows

autoplot(at_hyperparametros_rf)

at_hyperparametros_rf %>% 
  collect_metrics() %>% 
  pivot_longer(cols = c('mtry','trees','min_n'), names_to = 'hyperparametro', values_to = 'valor_hyperparametro') %>% 
  ggplot(aes(valor_hyperparametro, mean, color=mean)) +
  geom_point() +
  facet_grid(.metric~hyperparametro, scales = 'free') +
  scale_color_viridis_b()

Vamos a ver ahora los mejores modelos en funcion de las metricas accuracy y auc roc:

at_hyperparametros_rf %>% show_best(metric = "accuracy")

## # A tibble: 5 × 9
##    mtry trees min_n .metric  .estimator  mean     n std_err .config             
##   <int> <int> <int> <chr>    <chr>      <dbl> <int>   <dbl> <chr>               
## 1     3   462    30 accuracy binary     0.858    25 0.00300 Preprocessor1_Model…
## 2     4   307     7 accuracy binary     0.857    25 0.00299 Preprocessor1_Model…
## 3     3   279    26 accuracy binary     0.857    25 0.00317 Preprocessor1_Model…
## 4     4   127    17 accuracy binary     0.855    25 0.00327 Preprocessor1_Model…
## 5     5   429    16 accuracy binary     0.855    25 0.00302 Preprocessor1_Model…

at_hyperparametros_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     5   429    16 roc_auc binary     0.915    25 0.00269 Preprocessor1_Model06

Me quedo con el modelo con mejor auc_roc

at_mejor_auc_rf <- at_hyperparametros_rf %>% show_best(metric = "roc_auc", n=1)

XGBoost

extract_parameter_set_dials(xgb_spec)

## Collection of 4 parameters for tuning
## 
##  identifier       type    object
##        mtry       mtry nparam[?]
##       trees      trees nparam[+]
##       min_n      min_n nparam[+]
##  learn_rate learn_rate nparam[+]
## 
## Model parameters needing finalization:
##    # Randomly Selected Predictors ('mtry')
## 
## See `?dials::finalize` or `?dials::update.parameters` for more information.

extract_parameter_set_dials(xgb_spec) %>% extract_parameter_dials("learn_rate")

## Learning Rate (quantitative)
## Transformer: log-10 [1e-100, Inf]
## Range (transformed scale): [-3, -0.5]

doParallel::registerDoParallel()

set.seed(1234)

at_hyperparametros_xgb <-
  tune_grid(
  object = at_wf_xgb,
  resamples = at_boot,
  grid = grid_max_entropy(
  mtry(range  = c(2, 10)),
  min_n(range = c(5, 30)),
  trees(range = c(100, 500)),
  learn_rate(),
  size = 10
  ),
  metrics = metricas_modelo,
  control = control_grid(save_pred = TRUE)
  )

at_hyperparametros_metricas_xgb <- 
  at_hyperparametros_xgb %>% 
  collect_metrics()

at_hyperparametros_metricas_xgb

## # A tibble: 60 × 10
##     mtry trees min_n   learn_rate .metric .estimator  mean     n std_err .config
##    <int> <int> <int>        <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>  
##  1     3   491     5 0.0000000699 accura… binary     0.852    25 0.00312 Prepro…
##  2     3   491     5 0.0000000699 precis… binary     0.788    25 0.00659 Prepro…
##  3     3   491     5 0.0000000699 recall  binary     0.807    25 0.00655 Prepro…
##  4     3   491     5 0.0000000699 roc_auc binary     0.910    25 0.00270 Prepro…
##  5     3   491     5 0.0000000699 sensit… binary     0.807    25 0.00655 Prepro…
##  6     3   491     5 0.0000000699 specif… binary     0.878    25 0.00456 Prepro…
##  7     3   143    20 0.000126     accura… binary     0.839    25 0.00350 Prepro…
##  8     3   143    20 0.000126     precis… binary     0.760    25 0.00636 Prepro…
##  9     3   143    20 0.000126     recall  binary     0.809    25 0.00696 Prepro…
## 10     3   143    20 0.000126     roc_auc binary     0.903    25 0.00279 Prepro…
## # ℹ 50 more rows

at_hyperparametros_xgb %>% 
  collect_metrics() %>% 
  pivot_longer(cols = c('mtry','trees','min_n', 'learn_rate'), names_to = 'hyperparametro', values_to = 'valor_hyperparametro') %>% 
  ggplot(aes(valor_hyperparametro, mean, color=mean)) +
  geom_point() +
  facet_grid(.metric~hyperparametro, scales = 'free') +
  scale_color_viridis_b()

at_hyperparametros_xgb %>% show_best(metric = "roc_auc", n=1)

## # A tibble: 1 × 10
##    mtry trees min_n learn_rate .metric .estimator  mean     n std_err .config   
##   <int> <int> <int>      <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>     
## 1     7   219    18    0.00719 roc_auc binary     0.915    25 0.00252 Preproces…

at_mejor_auc_xgb <- at_hyperparametros_xgb %>% show_best(metric = "roc_auc", n=1)

Support Vector Machine

extract_parameter_set_dials(svm_spec)

## Collection of 2 parameters for tuning
## 
##  identifier      type    object
##        cost      cost nparam[+]
##   rbf_sigma rbf_sigma nparam[+]

extract_parameter_set_dials(svm_spec) %>% extract_parameter_dials("cost")

## Cost (quantitative)
## Transformer: log-2 [1e-100, Inf]
## Range (transformed scale): [-10, 5]

set.seed(1234)

at_hyperparametros_svm <-
  tune_grid(
  object = at_wf_svm,
  resamples = at_boot,
  metrics = metricas_modelo,
  control = control_grid(save_pred = TRUE)
  )

at_hyperparametros_svm %>% show_best(metric = "roc_auc", n=1)

## # A tibble: 1 × 8
##    cost rbf_sigma .metric .estimator  mean     n std_err .config              
##   <dbl>     <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1  20.7  0.000129 roc_auc binary     0.920    25 0.00276 Preprocessor1_Model07

at_mejor_auc_svm <- at_hyperparametros_svm %>% show_best(metric = "roc_auc", n=1)

Modelo final M1

Random Forest

at_modelo_rf_final <- 
  at_wf_rf %>%
  finalize_workflow(at_mejor_auc_rf) %>% 
  last_fit(at_split, metrics = metricas_modelo)

## Warning: package 'ranger' was built under R version 4.3.3

at_modelo_rf_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits             id               .metrics .notes   .predictions .workflow 
##   <list>             <chr>            <list>   <list>   <list>       <list>    
## 1 <split [1086/264]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion RF M1

collect_predictions(at_modelo_rf_final)

## # A tibble: 264 × 7
##    .pred_class .pred_Student .pred_Athlete id                .row Sport2 .config
##    <fct>               <dbl>         <dbl> <chr>            <int> <fct>  <chr>  
##  1 Athlete            0.293          0.707 train/test split     1 Athle… Prepro…
##  2 Athlete            0.381          0.619 train/test split     2 Athle… Prepro…
##  3 Athlete            0.168          0.832 train/test split     3 Athle… Prepro…
##  4 Athlete            0.0332         0.967 train/test split     5 Athle… Prepro…
##  5 Athlete            0.108          0.892 train/test split    12 Athle… Prepro…
##  6 Athlete            0.0805         0.919 train/test split    65 Athle… Prepro…
##  7 Athlete            0.102          0.898 train/test split    67 Athle… Prepro…
##  8 Athlete            0.0829         0.917 train/test split    68 Athle… Prepro…
##  9 Athlete            0.286          0.714 train/test split    69 Athle… Prepro…
## 10 Athlete            0.476          0.524 train/test split    70 Athle… Prepro…
## # ℹ 254 more rows

at_modelo_rf_final %>% 
  extract_workflow() %>% 
  predict(at_test)

## # A tibble: 264 × 1
##    .pred_class
##    <fct>      
##  1 Athlete    
##  2 Athlete    
##  3 Athlete    
##  4 Athlete    
##  5 Athlete    
##  6 Athlete    
##  7 Athlete    
##  8 Athlete    
##  9 Athlete    
## 10 Athlete    
## # ℹ 254 more rows

at_modelo_rf_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) %>% 
  mutate(metrica_redondeada = round(.estimate, 2)) %>% 
  knitr::kable()

.metric	.estimate	metrica_redondeada
accuracy	0.8181818	0.82
precision	0.7297297	0.73
sensitivity	0.8181818	0.82
specificity	0.8181818	0.82
recall	0.8181818	0.82
roc_auc	0.8961126	0.90

results_modelo_rf<- 
  at_modelo_rf_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config)

XGBoost

at_modelo_xgb_final <- 
  at_wf_xgb %>%
  finalize_workflow(at_mejor_auc_xgb) %>% 
  last_fit(at_split, metrics = metricas_modelo)

## Warning: package 'xgboost' was built under R version 4.3.3

at_modelo_xgb_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits             id               .metrics .notes   .predictions .workflow 
##   <list>             <chr>            <list>   <list>   <list>       <list>    
## 1 <split [1086/264]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion XGB M1

at_modelo_xgb_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) %>% 
  mutate(metrica_redondeada = round(.estimate, 2)) %>% 
  knitr::kable()

.metric	.estimate	metrica_redondeada
accuracy	0.7954545	0.80
precision	0.6956522	0.70
sensitivity	0.8080808	0.81
specificity	0.7878788	0.79
recall	0.8080808	0.81
roc_auc	0.8925620	0.89

results_modelo_xgb <- 
  at_modelo_xgb_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config)

Support Vector Machine

at_modelo_svm_final <- 
  at_wf_svm %>%
  finalize_workflow(at_mejor_auc_svm) %>% 
  last_fit(at_split, metrics = metricas_modelo)

at_modelo_svm_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits             id               .metrics .notes   .predictions .workflow 
##   <list>             <chr>            <list>   <list>   <list>       <list>    
## 1 <split [1086/264]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion SVM M1

at_modelo_svm_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) %>% 
  mutate(metrica_redondeada = round(.estimate, 2)) %>% 
  knitr::kable()

.metric	.estimate	metrica_redondeada
accuracy	0.8409091	0.84
precision	0.7522124	0.75
sensitivity	0.8585859	0.86
specificity	0.8303030	0.83
recall	0.8585859	0.86
roc_auc	0.9131313	0.91

results_modelo_svm<-
  at_modelo_svm_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config)

Grafico de los resultados por modelo M1

at_results<- data.frame(
  metrica = results_modelo_rf$.metric,
  RF = results_modelo_rf$.estimate,
  XGB = results_modelo_xgb$.estimate,
  SVM = results_modelo_svm$.estimate
)

at_results <-
  at_results %>%
  pivot_longer(cols = c("RF", "XGB", "SVM"), 
               names_to = "modelo") %>%
  filter(metrica == "accuracy" |
           metrica == "precision" |
           metrica == "recall" | 
           metrica == "roc_auc")  %>%
  mutate(metrica = factor(metrica), 
         modelo = factor(modelo))
  


at_results

## # A tibble: 12 × 3
##    metrica   modelo value
##    <fct>     <fct>  <dbl>
##  1 accuracy  RF     0.818
##  2 accuracy  XGB    0.795
##  3 accuracy  SVM    0.841
##  4 precision RF     0.730
##  5 precision XGB    0.696
##  6 precision SVM    0.752
##  7 recall    RF     0.818
##  8 recall    XGB    0.808
##  9 recall    SVM    0.859
## 10 roc_auc   RF     0.896
## 11 roc_auc   XGB    0.893
## 12 roc_auc   SVM    0.913

levels(at_results$metrica) <- c("Accuracy", "Precision", "Recall", "AUC ROC")


at_results %>% 
  ggplot(aes(x = metrica, y = value, fill = modelo))+
  geom_col(position = "dodge")+ 
  scale_fill_brewer(palette= "Pastel2")+
  scale_y_continuous(limits = c(0,1), expand = c(0,0))+
  labs(y = "", 
       x = "Metric",
       fill= NULL,
       title= "")

Modelo 2. Caso respecto la muestra

EDA Datos M2

df_caso <- df %>% 
  select(-c(Sport2, Sport)) %>% 
  mutate(cas_fut = as.factor(ifelse(Subject == 30, 1, 0)))
  
head(df_caso)

## # A tibble: 6 × 18
##   Subject mRR_UPC SDNN_UPC RMSSD_UPC pNN50_UPC ti_UPC HF_UPC LF_UPC VLF_UPC
##     <dbl>   <dbl>    <dbl>     <dbl>     <dbl>  <dbl>  <dbl>  <dbl>   <dbl>
## 1       1   1070.     88.2      68.7      36.4   312   1542.   718.   4294.
## 2       1    883.     63.4      40.8      19.7   298.   675.  2075.    869.
## 3       1    977.     65.3      54.5      39.8   172.  1463.  1383.   2231.
## 4       2   1239.     70.8      60.3      47.1   243.   909.  4011.   1279.
## 5       3   1185.    123.      132.       75.2   307.  3492.  1330.  10519.
## 6       5   1021.     50.5      42.4      26.0   170.   496.   967.    546.
## # ℹ 9 more variables: `LF/HF_UPC` <dbl>, HFnu_UPC_2v <dbl>, HFnu_UPC_3v <dbl>,
## #   VLFnu_UPC_3v <dbl>, LFnu_UPC_3v <dbl>, SD1_UPC <dbl>, SD2_UPC <dbl>,
## #   LFnu_UPC_2v <dbl>, cas_fut <fct>

La variable de interes es:

cas_fut, el caso con más observaciones es el 30 con 105.

df_caso %>% 
  group_by(cas_fut) %>% 
  count()

## # A tibble: 2 × 2
## # Groups:   cas_fut [2]
##   cas_fut     n
##   <fct>   <int>
## 1 0        1245
## 2 1         105

tabla_descrip_M2 <- compareGroups(cas_fut ~ . -Subject, data= df_caso)

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

createTable(tabla_descrip_M2)

## 
## --------Summary descriptives table by 'cas_fut'---------
## 
## ______________________________________________ 
##                   0           1      p.overall 
##                N=1245       N=105              
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯ 
## mRR_UPC      1039 (193)  1061 (98.5)   0.046   
## SDNN_UPC     75.8 (35.9) 79.5 (13.4)   0.028   
## RMSSD_UPC    78.0 (49.4) 85.2 (17.8)   0.001   
## pNN50_UPC    41.8 (22.9) 60.2 (10.4)  <0.001   
## ti_UPC        226 (110)  269 (81.8)   <0.001   
## HF_UPC       3093 (4575) 3243 (1446)   0.432   
## LF_UPC       1723 (3211) 1070 (538)   <0.001   
## VLF_UPC      1298 (1889) 1570 (1317)   0.053   
## LF/HF_UPC    1.16 (1.70) 0.40 (0.29)  <0.001   
## HFnu_UPC_2v  59.5 (22.7) 73.6 (12.1)  <0.001   
## HFnu_UPC_3v  46.4 (23.8) 55.5 (14.8)  <0.001   
## VLFnu_UPC_3v 24.8 (18.5) 25.0 (13.5)   0.906   
## LFnu_UPC_3v  28.8 (17.0) 19.5 (9.51)  <0.001   
## SD1_UPC      55.1 (34.9) 60.3 (12.6)   0.001   
## SD2_UPC      90.7 (39.7) 94.4 (16.4)   0.058   
## LFnu_UPC_2v  40.5 (22.7) 26.4 (12.1)  <0.001   
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯

df_caso %>% 
  filter(RMSSD_UPC<200) %>% 
  ggplot(aes(RMSSD_UPC, fill = cas_fut))+
  geom_density(alpha = 0.5)+
  labs(title= "RMSSD",
       fill = "")

Division Datos M2

set.seed(1245) 

caso_split <- initial_split(df_caso, prop= 0.8, strata = cas_fut)

caso_training <- training(caso_split) 
caso_test <- testing(caso_split)  

caso_split

## <Training/Testing/Total>
## <1080/270/1350>

Del dataframe original (1350 observaciones) 1080 observaciones son para entrenamiento y 270 para test. Como vamos a buscar un caso utilizo todos los sujetos simplemente diferenciandolos del que me interesa identificar.

set.seed(2023) 
caso_boot <- bootstraps(caso_training) 
caso_boot

## # Bootstrap sampling 
## # A tibble: 25 × 2
##    splits             id         
##    <list>             <chr>      
##  1 <split [1080/400]> Bootstrap01
##  2 <split [1080/406]> Bootstrap02
##  3 <split [1080/412]> Bootstrap03
##  4 <split [1080/382]> Bootstrap04
##  5 <split [1080/411]> Bootstrap05
##  6 <split [1080/394]> Bootstrap06
##  7 <split [1080/393]> Bootstrap07
##  8 <split [1080/394]> Bootstrap08
##  9 <split [1080/389]> Bootstrap09
## 10 <split [1080/390]> Bootstrap10
## # ℹ 15 more rows

Receta M2

caso_rec <-
  recipe(formula = cas_fut ~  .,
         data = caso_training) %>% 
  step_rm(Subject) %>%
  step_smote(cas_fut, neighbors = 10)

Workflow M2

Random Forest

caso_wf_rf <-    
  workflow() %>%
  add_recipe(caso_rec) %>% 
  add_model(rf_spec)

XGBoost

caso_wf_xgb <-    
  workflow() %>%
  add_recipe(caso_rec) %>% 
  add_model(xgb_spec)

Support Vector Machine

caso_wf_svm <- 
  workflow() %>% 
  add_recipe(caso_rec) %>%
  add_model(svm_spec)

Hyperparametros M2

Random Forest

doParallel::registerDoParallel()

set.seed(1234)

caso_hyperparametros_rf <-
  tune_grid(
    object = caso_wf_rf,
    resamples = caso_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_modelo,
    control = control_grid(save_pred = TRUE))

Evaluacion hyperparametros RF M2

caso_hyperparametros_metricas_rf <-
  caso_hyperparametros_rf %>%
  collect_metrics()

caso_hyperparametros_metricas_rf

## # A tibble: 60 × 9
##     mtry trees min_n .metric     .estimator  mean     n std_err .config         
##    <int> <int> <int> <chr>       <chr>      <dbl> <int>   <dbl> <chr>           
##  1    10   485     8 accuracy    binary     0.914    25 0.00233 Preprocessor1_M…
##  2    10   485     8 precision   binary     0.962    25 0.00182 Preprocessor1_M…
##  3    10   485     8 recall      binary     0.945    25 0.00291 Preprocessor1_M…
##  4    10   485     8 roc_auc     binary     0.894    25 0.00580 Preprocessor1_M…
##  5    10   485     8 sensitivity binary     0.945    25 0.00291 Preprocessor1_M…
##  6    10   485     8 specificity binary     0.583    25 0.0140  Preprocessor1_M…
##  7     9   206    16 accuracy    binary     0.916    25 0.00198 Preprocessor1_M…
##  8     9   206    16 precision   binary     0.961    25 0.00189 Preprocessor1_M…
##  9     9   206    16 recall      binary     0.946    25 0.00266 Preprocessor1_M…
## 10     9   206    16 roc_auc     binary     0.895    25 0.00555 Preprocessor1_M…
## # ℹ 50 more rows

caso_hyperparametros_rf %>%
  collect_metrics() %>%    
  pivot_longer(cols = c('mtry','trees','min_n'), 
               names_to = 'tipo_parametro', 
               values_to = 'valor_parametro') %>%    
  ggplot(aes(valor_parametro, mean, color=mean)) +   
  geom_point() +   
  facet_grid(.metric~tipo_parametro, scales = 'free' ) +   
  scale_color_viridis_b()

caso_hyperparametros_rf %>% show_best(metric= "roc_auc")

## # A tibble: 5 × 9
##    mtry trees min_n .metric .estimator  mean     n std_err .config              
##   <int> <int> <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1     4   307     7 roc_auc binary     0.906    25 0.00493 Preprocessor1_Model04
## 2     3   279    26 roc_auc binary     0.904    25 0.00530 Preprocessor1_Model03
## 3     3   462    30 roc_auc binary     0.904    25 0.00530 Preprocessor1_Model05
## 4     5   429    16 roc_auc binary     0.904    25 0.00529 Preprocessor1_Model06
## 5     4   127    17 roc_auc binary     0.903    25 0.00536 Preprocessor1_Model10

caso_mejor_hyper_rf <- caso_hyperparametros_rf %>% show_best(metric = "roc_auc", n = 1)
caso_mejor_hyper_rf

## # 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     4   307     7 roc_auc binary     0.906    25 0.00493 Preprocessor1_Model04

Mejor modelo RF:

mtry: 4
trees: 307
min_n: 7

XGBoost

doParallel::registerDoParallel()

set.seed(1234)


caso_hyperparametros_xgb <-
  tune_grid(
  object = caso_wf_xgb,
  resamples = caso_boot,
  grid = grid_max_entropy(
  mtry(range  = c(2, 10)),
  min_n(range = c(5, 30)),
  trees(range = c(100, 500)),
  learn_rate(),
  size = 10
  ),
  metrics = metricas_modelo,
  control = control_grid(save_pred = TRUE))

Evaluacion hyperparametros XGB M2

caso_hyperparametros_metricas_xgb <-
  caso_hyperparametros_xgb %>%
  collect_metrics()

caso_hyperparametros_metricas_xgb

## # A tibble: 60 × 10
##     mtry trees min_n   learn_rate .metric .estimator  mean     n std_err .config
##    <int> <int> <int>        <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>  
##  1     3   491     5 0.0000000699 accura… binary     0.872    25 0.00354 Prepro…
##  2     3   491     5 0.0000000699 precis… binary     0.972    25 0.00197 Prepro…
##  3     3   491     5 0.0000000699 recall  binary     0.886    25 0.00449 Prepro…
##  4     3   491     5 0.0000000699 roc_auc binary     0.895    25 0.00544 Prepro…
##  5     3   491     5 0.0000000699 sensit… binary     0.886    25 0.00449 Prepro…
##  6     3   491     5 0.0000000699 specif… binary     0.719    25 0.0184  Prepro…
##  7     3   143    20 0.000126     accura… binary     0.865    25 0.00363 Prepro…
##  8     3   143    20 0.000126     precis… binary     0.971    25 0.00200 Prepro…
##  9     3   143    20 0.000126     recall  binary     0.879    25 0.00474 Prepro…
## 10     3   143    20 0.000126     roc_auc binary     0.887    25 0.00580 Prepro…
## # ℹ 50 more rows

caso_hyperparametros_xgb %>%
  collect_metrics() %>%    
  pivot_longer(cols = c('mtry','trees','min_n'), 
               names_to = 'tipo_parametro', 
               values_to = 'valor_parametro') %>%    
  ggplot(aes(valor_parametro, mean, color=mean)) +   
  geom_point() +   
  facet_grid(.metric~tipo_parametro, scales = 'free' ) +   
  scale_color_viridis_b()

caso_hyperparametros_xgb %>% show_best(metric= "roc_auc")

## # A tibble: 5 × 10
##    mtry trees min_n   learn_rate .metric .estimator  mean     n std_err .config 
##   <int> <int> <int>        <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>   
## 1     3   491     5 0.0000000699 roc_auc binary     0.895    25 0.00544 Preproc…
## 2     7   219    18 0.00719      roc_auc binary     0.895    25 0.00516 Preproc…
## 3     5   275     6 0.0000792    roc_auc binary     0.892    25 0.00560 Preproc…
## 4     3   143    20 0.000126     roc_auc binary     0.887    25 0.00580 Preproc…
## 5     9   467    14 0.00115      roc_auc binary     0.886    25 0.00582 Preproc…

caso_mejor_hyper_xgb <- caso_hyperparametros_xgb %>% show_best(metric = "roc_auc", n = 1)
caso_mejor_hyper_xgb

## # A tibble: 1 × 10
##    mtry trees min_n   learn_rate .metric .estimator  mean     n std_err .config 
##   <int> <int> <int>        <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>   
## 1     3   491     5 0.0000000699 roc_auc binary     0.895    25 0.00544 Preproc…

Mejor modelo XGB:

mtry: 3
trees: 491
min_n: 5
learning_rate: 0.0000000699 = 6.99e-8

Support Vector Machine

set.seed(1234)

caso_hyperparametros_svm <-
  tune_grid(
  object = caso_wf_svm,
  resamples = caso_boot,
  metrics = metricas_modelo,
  control = control_grid(save_pred = TRUE)
  )

caso_hyperparametros_svm %>% show_best(metric = "roc_auc", n=1)

## # A tibble: 1 × 8
##     cost rbf_sigma .metric .estimator  mean     n std_err .config              
##    <dbl>     <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1 0.0118    0.0545 roc_auc binary     0.903    25 0.00454 Preprocessor1_Model03

caso_mejor_hyper_svm <- caso_hyperparametros_svm %>% show_best(metric = "roc_auc", n=1)

Modelo final M2

Random Forest

caso_modelo_hyperparametros_rf <-
  caso_wf_rf %>%
  finalize_workflow(caso_mejor_hyper_rf) %>%
  fit(data = caso_training)

set.seed(1256)
caso_modelo_rf_final <-
  caso_wf_rf %>%
  finalize_workflow(caso_mejor_hyper_rf) %>%
  last_fit(caso_split, 
           metrics = metricas_modelo)

caso_modelo_rf_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits             id               .metrics .notes   .predictions .workflow 
##   <list>             <chr>            <list>   <list>   <list>       <list>    
## 1 <split [1080/270]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion RF M2

collect_metrics(caso_modelo_rf_final)

## # A tibble: 6 × 4
##   .metric     .estimator .estimate .config             
##   <chr>       <chr>          <dbl> <chr>               
## 1 accuracy    binary         0.930 Preprocessor1_Model1
## 2 precision   binary         0.965 Preprocessor1_Model1
## 3 sensitivity binary         0.961 Preprocessor1_Model1
## 4 specificity binary         0.357 Preprocessor1_Model1
## 5 recall      binary         0.961 Preprocessor1_Model1
## 6 roc_auc     binary         0.844 Preprocessor1_Model1

caso_modelo_rf_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) %>% 
  mutate(metrica_redondeada = round(.estimate, 2)) %>% 
  knitr::kable()

.metric	.estimate	metrica_redondeada
accuracy	0.9296296	0.93
precision	0.9647059	0.96
sensitivity	0.9609375	0.96
specificity	0.3571429	0.36
recall	0.9609375	0.96
roc_auc	0.8437500	0.84

caso_results_modelo_rf <- 
  caso_modelo_rf_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config)

XGBoost

caso_modelo_hyperparametros_xgb <-
  caso_wf_xgb %>%
  finalize_workflow(caso_mejor_hyper_xgb) %>%
  fit(data = caso_training)

## [13:16:21] WARNING: src/learner.cc:767: 
## Parameters: { "importance" } are not used.

set.seed(1256)

caso_modelo_xgb_final <-
  caso_wf_xgb %>%
  finalize_workflow(caso_mejor_hyper_xgb) %>%
  last_fit(caso_split, 
           metrics = metricas_modelo)

caso_modelo_xgb_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits             id               .metrics .notes   .predictions .workflow 
##   <list>             <chr>            <list>   <list>   <list>       <list>    
## 1 <split [1080/270]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluaciuon XGB M2

collect_metrics(caso_modelo_xgb_final)

## # A tibble: 6 × 4
##   .metric     .estimator .estimate .config             
##   <chr>       <chr>          <dbl> <chr>               
## 1 accuracy    binary         0.863 Preprocessor1_Model1
## 2 precision   binary         0.978 Preprocessor1_Model1
## 3 sensitivity binary         0.875 Preprocessor1_Model1
## 4 specificity binary         0.643 Preprocessor1_Model1
## 5 recall      binary         0.875 Preprocessor1_Model1
## 6 roc_auc     binary         0.848 Preprocessor1_Model1

caso_modelo_xgb_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) %>% 
  mutate(metrica_redondeada = round(.estimate, 2)) %>% 
  knitr::kable()

.metric	.estimate	metrica_redondeada
accuracy	0.8629630	0.86
precision	0.9781659	0.98
sensitivity	0.8750000	0.88
specificity	0.6428571	0.64
recall	0.8750000	0.88
roc_auc	0.8475167	0.85

caso_results_modelo_xgb <- 
  caso_modelo_xgb_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config)

Support Vector Machine

caso_modelo_hyperparametros_svm <-
  caso_wf_svm %>%
  finalize_workflow(caso_mejor_hyper_svm) %>%
  fit(data = caso_training)

set.seed(1256)

caso_modelo_svm_final <-
  caso_wf_svm %>%
  finalize_workflow(caso_mejor_hyper_svm) %>%
  last_fit(caso_split, 
           metrics = metricas_modelo)

caso_modelo_svm_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits             id               .metrics .notes   .predictions .workflow 
##   <list>             <chr>            <list>   <list>   <list>       <list>    
## 1 <split [1080/270]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion SVM M2

collect_metrics(caso_modelo_svm_final)

## # A tibble: 6 × 4
##   .metric     .estimator .estimate .config             
##   <chr>       <chr>          <dbl> <chr>               
## 1 accuracy    binary         0.759 Preprocessor1_Model1
## 2 precision   binary         0.985 Preprocessor1_Model1
## 3 sensitivity binary         0.758 Preprocessor1_Model1
## 4 specificity binary         0.786 Preprocessor1_Model1
## 5 recall      binary         0.758 Preprocessor1_Model1
## 6 roc_auc     binary         0.870 Preprocessor1_Model1

caso_modelo_svm_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) %>% 
  mutate(metrica_redondeada = round(.estimate, 2)) %>% 
  knitr::kable()

.metric	.estimate	metrica_redondeada
accuracy	0.7592593	0.76
precision	0.9847716	0.98
sensitivity	0.7578125	0.76
specificity	0.7857143	0.79
recall	0.7578125	0.76
roc_auc	0.8699777	0.87

caso_results_modelo_svm <- 
  caso_modelo_svm_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config)

Grafico de los resultados por modelo M2

caso_results<- data.frame(
  metrica = caso_results_modelo_rf$.metric,
  RF = caso_results_modelo_rf$.estimate,
  XGB = caso_results_modelo_xgb$.estimate,
  SVM = caso_results_modelo_svm$.estimate
)

caso_results <-
  caso_results %>%
  pivot_longer(cols = c("RF", "XGB", "SVM"), 
               names_to = "modelo") %>%
  filter(metrica == "accuracy" |
           metrica == "precision" |
           metrica == "recall" | 
           metrica == "roc_auc")  %>%
  mutate(metrica = factor(metrica), 
         modelo = factor(modelo))
  


caso_results

## # A tibble: 12 × 3
##    metrica   modelo value
##    <fct>     <fct>  <dbl>
##  1 accuracy  RF     0.930
##  2 accuracy  XGB    0.863
##  3 accuracy  SVM    0.759
##  4 precision RF     0.965
##  5 precision XGB    0.978
##  6 precision SVM    0.985
##  7 recall    RF     0.961
##  8 recall    XGB    0.875
##  9 recall    SVM    0.758
## 10 roc_auc   RF     0.844
## 11 roc_auc   XGB    0.848
## 12 roc_auc   SVM    0.870

levels(caso_results$metrica) <- c("Accuracy", "Precision", "Recall", "AUC ROC")


caso_results %>% 
  ggplot(aes(x = metrica, y = value, fill = modelo))+
  geom_col(position = "dodge")+ 
  scale_fill_brewer(palette= "Pastel2")+
  scale_y_continuous(limits = c(0,1), expand = c(0,0))+
  labs(y = "", 
       x = "Metric",
       fill= NULL,
       title= "")

Modelo 3. Caso dentro de futbolistas

EDA Datos M3

df_subfut <- df %>% 
  select(-Sport2) %>% 
  filter(Sport == "soccer") %>% 
  mutate(cas_fut = as.factor(ifelse(Subject == 30, 1, 0)))
  

head(df_subfut)

## # A tibble: 6 × 19
##   Subject Sport  mRR_UPC SDNN_UPC RMSSD_UPC pNN50_UPC ti_UPC HF_UPC LF_UPC
##     <dbl> <fct>    <dbl>    <dbl>     <dbl>     <dbl>  <dbl>  <dbl>  <dbl>
## 1       1 soccer   1070.     88.2      68.7      36.4   312   1542.   718.
## 2       1 soccer    883.     63.4      40.8      19.7   298.   675.  2075.
## 3       1 soccer    977.     65.3      54.5      39.8   172.  1463.  1383.
## 4       2 soccer   1239.     70.8      60.3      47.1   243.   909.  4011.
## 5       3 soccer   1185.    123.      132.       75.2   307.  3492.  1330.
## 6       5 soccer   1021.     50.5      42.4      26.0   170.   496.   967.
## # ℹ 10 more variables: VLF_UPC <dbl>, `LF/HF_UPC` <dbl>, HFnu_UPC_2v <dbl>,
## #   HFnu_UPC_3v <dbl>, VLFnu_UPC_3v <dbl>, LFnu_UPC_3v <dbl>, SD1_UPC <dbl>,
## #   SD2_UPC <dbl>, LFnu_UPC_2v <dbl>, cas_fut <fct>

df_subfut %>% 
  count(cas_fut)

## # A tibble: 2 × 2
##   cas_fut     n
##   <fct>   <int>
## 1 0         514
## 2 1         105

tabla_descrip_M3 <- compareGroups(cas_fut ~ . -Subject-Sport, data= df_subfut)

createTable(tabla_descrip_M3)

## 
## --------Summary descriptives table by 'cas_fut'---------
## 
## ______________________________________________ 
##                   0           1      p.overall 
##                 N=514       N=105              
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯ 
## mRR_UPC      1112 (165)  1061 (98.5)  <0.001   
## SDNN_UPC     75.0 (33.8) 79.5 (13.4)   0.025   
## RMSSD_UPC    76.9 (47.5) 85.2 (17.8)   0.002   
## pNN50_UPC    42.2 (23.0) 60.2 (10.4)  <0.001   
## ti_UPC       221 (98.0)  269 (81.8)   <0.001   
## HF_UPC       2395 (4168) 3243 (1446)  <0.001   
## LF_UPC       1880 (3615) 1070 (538)   <0.001   
## VLF_UPC      1603 (1729) 1570 (1317)   0.823   
## LF/HF_UPC    1.59 (1.99) 0.40 (0.29)  <0.001   
## HFnu_UPC_2v  50.3 (20.3) 73.6 (12.1)  <0.001   
## HFnu_UPC_3v  35.3 (18.9) 55.5 (14.8)  <0.001   
## VLFnu_UPC_3v 31.6 (19.2) 25.0 (13.5)  <0.001   
## LFnu_UPC_3v  33.1 (16.0) 19.5 (9.51)  <0.001   
## SD1_UPC      54.3 (33.6) 60.3 (12.6)   0.002   
## SD2_UPC      89.5 (37.8) 94.4 (16.4)   0.036   
## LFnu_UPC_2v  49.7 (20.3) 26.4 (12.1)  <0.001   
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯

df_subfut %>%
  ggplot(aes(mRR_UPC, fill = cas_fut))+
  geom_density(alpha = 0.5)+
  labs(title= "mRR",
       fill = "")

Division Datos M3

set.seed(1425) 

casfut_split <- initial_split(df_subfut, prop= 0.8, strata = cas_fut)

casfut_training <- training(casfut_split) 
casfut_test <- testing(casfut_split)  

casfut_split

## <Training/Testing/Total>
## <495/124/619>

set.seed(2024) 
casfut_boot <- bootstraps(casfut_training) 
casfut_boot

## # Bootstrap sampling 
## # A tibble: 25 × 2
##    splits            id         
##    <list>            <chr>      
##  1 <split [495/182]> Bootstrap01
##  2 <split [495/178]> Bootstrap02
##  3 <split [495/189]> Bootstrap03
##  4 <split [495/179]> Bootstrap04
##  5 <split [495/186]> Bootstrap05
##  6 <split [495/181]> Bootstrap06
##  7 <split [495/182]> Bootstrap07
##  8 <split [495/179]> Bootstrap08
##  9 <split [495/192]> Bootstrap09
## 10 <split [495/196]> Bootstrap10
## # ℹ 15 more rows

Receta M3

casfut_rec <-
  recipe(formula = cas_fut ~  .,
         data = casfut_training) %>% 
  step_rm(Subject, Sport) %>%
  step_smote(cas_fut, neighbors = 10)

Workflow M3

Random Forest

casfut_wf_rf <-    
  workflow() %>%
  add_recipe(casfut_rec) %>% 
  add_model(rf_spec)

XGBoost

casfut_wf_xgb <-    
  workflow() %>%
  add_recipe(casfut_rec) %>% 
  add_model(xgb_spec)

Support Vector Machine

casfut_wf_svm <- 
  workflow() %>% 
  add_recipe(casfut_rec) %>% 
  add_model(svm_spec)

Hyperparametros M3

Random Forest

set.seed(4564)
doParallel::registerDoParallel()

casfut_hyperparametros_rf <-
  tune_grid(
    object = casfut_wf_rf,
    resamples = casfut_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_modelo,
    control = control_grid(save_pred = TRUE))

Evaluacion hyperparametros M3

casfut_hyperparametros_metricas_rf <-
  casfut_hyperparametros_rf %>%
  collect_metrics()

casfut_hyperparametros_metricas_rf

## # A tibble: 60 × 9
##     mtry trees min_n .metric     .estimator  mean     n std_err .config         
##    <int> <int> <int> <chr>       <chr>      <dbl> <int>   <dbl> <chr>           
##  1     4   497    25 accuracy    binary     0.886    25 0.00330 Preprocessor1_M…
##  2     4   497    25 precision   binary     0.933    25 0.00281 Preprocessor1_M…
##  3     4   497    25 recall      binary     0.931    25 0.00492 Preprocessor1_M…
##  4     4   497    25 roc_auc     binary     0.905    25 0.00505 Preprocessor1_M…
##  5     4   497    25 sensitivity binary     0.931    25 0.00492 Preprocessor1_M…
##  6     4   497    25 specificity binary     0.664    25 0.0168  Preprocessor1_M…
##  7     9   183    17 accuracy    binary     0.885    25 0.00342 Preprocessor1_M…
##  8     9   183    17 precision   binary     0.932    25 0.00335 Preprocessor1_M…
##  9     9   183    17 recall      binary     0.930    25 0.00466 Preprocessor1_M…
## 10     9   183    17 roc_auc     binary     0.895    25 0.00541 Preprocessor1_M…
## # ℹ 50 more rows

casfut_hyperparametros_rf %>% collect_metrics() %>%    pivot_longer(cols = c('mtry','trees','min_n'), names_to = 'tipo_parametro', values_to = 'valor_parametro') %>%    ggplot(aes(valor_parametro,mean, color=mean)) +   geom_point() +   facet_grid(.metric~tipo_parametro, scales = 'free' ) +   scale_color_viridis_b()

casfut_mejor_hyper_rf <- casfut_hyperparametros_rf %>% show_best(metric = "roc_auc", n = 1)
casfut_mejor_hyper_rf

## # 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   214    10 roc_auc binary     0.910    25 0.00507 Preprocessor1_Model03

Mejor hyperparametros RF:

mtry: 2
trees: 214
min_n: 10

XGBoost

doParallel::registerDoParallel()

set.seed(5698)

casfut_hyperparametros_xgb <-
  tune_grid(
  object = casfut_wf_xgb,
  resamples = casfut_boot,
  grid = grid_max_entropy(
  mtry(range  = c(2, 10)),
  min_n(range = c(5, 30)),
  trees(range = c(100, 500)),
  learn_rate(),
  size = 10
  ),
  metrics = metricas_modelo,
  control = control_grid(save_pred = TRUE))

Evaluacion hyperparametros XGB M2

casfut_hyperparametros_metricas_xgb <-
  casfut_hyperparametros_xgb %>%
  collect_metrics()

casfut_hyperparametros_metricas_xgb

## # A tibble: 60 × 10
##     mtry trees min_n   learn_rate .metric .estimator  mean     n std_err .config
##    <int> <int> <int>        <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>  
##  1     2   434    25 0.0000627    accura… binary     0.811    25 0.00527 Prepro…
##  2     2   434    25 0.0000627    precis… binary     0.945    25 0.00404 Prepro…
##  3     2   434    25 0.0000627    recall  binary     0.822    25 0.00634 Prepro…
##  4     2   434    25 0.0000627    roc_auc binary     0.892    25 0.00646 Prepro…
##  5     2   434    25 0.0000627    sensit… binary     0.822    25 0.00634 Prepro…
##  6     2   434    25 0.0000627    specif… binary     0.762    25 0.0173  Prepro…
##  7     3   322    19 0.0000000546 accura… binary     0.842    25 0.00600 Prepro…
##  8     3   322    19 0.0000000546 precis… binary     0.946    25 0.00384 Prepro…
##  9     3   322    19 0.0000000546 recall  binary     0.861    25 0.00682 Prepro…
## 10     3   322    19 0.0000000546 roc_auc binary     0.897    25 0.00574 Prepro…
## # ℹ 50 more rows

casfut_hyperparametros_xgb %>%
  collect_metrics() %>%    
  pivot_longer(cols = c('mtry','trees','min_n'), 
               names_to = 'tipo_parametro', 
               values_to = 'valor_parametro') %>%    
  ggplot(aes(valor_parametro, mean, color=mean)) +   
  geom_point() +   
  facet_grid(.metric~tipo_parametro, scales = 'free' ) +   
  scale_color_viridis_b()

casfut_hyperparametros_xgb %>% show_best(metric= "roc_auc")

## # A tibble: 5 × 10
##    mtry trees min_n   learn_rate .metric .estimator  mean     n std_err .config 
##   <int> <int> <int>        <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>   
## 1     5   469    17 0.00126      roc_auc binary     0.898    25 0.00538 Preproc…
## 2     8   390     6 0.00265      roc_auc binary     0.897    25 0.00556 Preproc…
## 3     3   322    19 0.0000000546 roc_auc binary     0.897    25 0.00574 Preproc…
## 4     6   160     8 0.000317     roc_auc binary     0.896    25 0.00530 Preproc…
## 5     2   434    25 0.0000627    roc_auc binary     0.892    25 0.00646 Preproc…

casfut_mejor_hyper_xgb <- casfut_hyperparametros_xgb %>% show_best(metric = "roc_auc", n = 1)
casfut_mejor_hyper_xgb

## # A tibble: 1 × 10
##    mtry trees min_n learn_rate .metric .estimator  mean     n std_err .config   
##   <int> <int> <int>      <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>     
## 1     5   469    17    0.00126 roc_auc binary     0.898    25 0.00538 Preproces…

Mejor modelo XGB:

mtry: 5
trees: 469
min_n: 17
learning_rate: 0.00126

Support Vector Machine

set.seed(1234)

casfut_hyperparametros_svm <-
  tune_grid(
  object = casfut_wf_svm,
  resamples = casfut_boot,
  metrics = metricas_modelo,
  control = control_grid(save_pred = TRUE)
  )

casfut_hyperparametros_svm %>% show_best(metric = "roc_auc", n=1)

## # A tibble: 1 × 8
##     cost rbf_sigma .metric .estimator  mean     n std_err .config              
##    <dbl>     <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1 0.0118    0.0545 roc_auc binary     0.914    25 0.00526 Preprocessor1_Model03

casfut_mejor_hyper_svm <- casfut_hyperparametros_svm %>% show_best(metric = "roc_auc", n=1)

Modelo final M3

Random Forest

casfut_modelo_rf_hyperparametros <-
  casfut_wf_rf %>%
  finalize_workflow(casfut_mejor_hyper_rf) %>%
  fit(data = casfut_training)  

set.seed(1256)
casfut_modelo_rf_final <-
  casfut_wf_rf %>%
  finalize_workflow(casfut_mejor_hyper_rf) %>%
  last_fit(casfut_split, 
           metrics = metricas_modelo)

casfut_modelo_rf_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits            id               .metrics .notes   .predictions .workflow 
##   <list>            <chr>            <list>   <list>   <list>       <list>    
## 1 <split [495/124]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion RF M3

collect_metrics(casfut_modelo_rf_final)

## # A tibble: 6 × 4
##   .metric     .estimator .estimate .config             
##   <chr>       <chr>          <dbl> <chr>               
## 1 accuracy    binary         0.919 Preprocessor1_Model1
## 2 precision   binary         0.935 Preprocessor1_Model1
## 3 sensitivity binary         0.971 Preprocessor1_Model1
## 4 specificity binary         0.667 Preprocessor1_Model1
## 5 recall      binary         0.971 Preprocessor1_Model1
## 6 roc_auc     binary         0.943 Preprocessor1_Model1

casfut_modelo_rf_final %>%   
  collect_metrics() %>%
  select(-.estimator,-.config) %>%
  mutate(valor_redondeado = round(.estimate,2)) %>%    
  knitr::kable()

.metric	.estimate	valor_redondeado
accuracy	0.9193548	0.92
precision	0.9345794	0.93
sensitivity	0.9708738	0.97
specificity	0.6666667	0.67
recall	0.9708738	0.97
roc_auc	0.9431345	0.94

XGBoost

casfut_modelo_xgb_hyperparametros <-
  casfut_wf_xgb %>%
  finalize_workflow(casfut_mejor_hyper_xgb) %>%
  fit(data = casfut_training)

## [13:18:30] WARNING: src/learner.cc:767: 
## Parameters: { "importance" } are not used.

set.seed(1256)
casfut_modelo_xgb_final <-
  casfut_wf_xgb %>%
  finalize_workflow(casfut_mejor_hyper_xgb) %>%
  last_fit(casfut_split, 
           metrics = metricas_modelo)

casfut_modelo_xgb_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits            id               .metrics .notes   .predictions .workflow 
##   <list>            <chr>            <list>   <list>   <list>       <list>    
## 1 <split [495/124]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion XGB M3

collect_metrics(casfut_modelo_xgb_final)

## # A tibble: 6 × 4
##   .metric     .estimator .estimate .config             
##   <chr>       <chr>          <dbl> <chr>               
## 1 accuracy    binary         0.871 Preprocessor1_Model1
## 2 precision   binary         0.939 Preprocessor1_Model1
## 3 sensitivity binary         0.903 Preprocessor1_Model1
## 4 specificity binary         0.714 Preprocessor1_Model1
## 5 recall      binary         0.903 Preprocessor1_Model1
## 6 roc_auc     binary         0.946 Preprocessor1_Model1

casfut_modelo_xgb_final %>%   
  collect_metrics() %>%
  select(-.estimator,-.config) %>%
  mutate(valor_redondeado = round(.estimate,2)) %>%    
  knitr::kable()

.metric	.estimate	valor_redondeado
accuracy	0.8709677	0.87
precision	0.9393939	0.94
sensitivity	0.9029126	0.90
specificity	0.7142857	0.71
recall	0.9029126	0.90
roc_auc	0.9459085	0.95

Support Vector Machine

casfut_modelo_svm_hyperparametros <-
  casfut_wf_svm %>%
  finalize_workflow(casfut_mejor_hyper_svm) %>%
  fit(data = casfut_training)  

set.seed(1256)
casfut_modelo_svm_final <-
  casfut_wf_svm %>%
  finalize_workflow(casfut_mejor_hyper_svm) %>%
  last_fit(casfut_split, 
           metrics = metricas_modelo)

casfut_modelo_svm_final

## # Resampling results
## # Manual resampling 
## # A tibble: 1 × 6
##   splits            id               .metrics .notes   .predictions .workflow 
##   <list>            <chr>            <list>   <list>   <list>       <list>    
## 1 <split [495/124]> train/test split <tibble> <tibble> <tibble>     <workflow>

Evaluacion SVM M3

collect_metrics(casfut_modelo_svm_final)

## # A tibble: 6 × 4
##   .metric     .estimator .estimate .config             
##   <chr>       <chr>          <dbl> <chr>               
## 1 accuracy    binary         0.806 Preprocessor1_Model1
## 2 precision   binary         0.954 Preprocessor1_Model1
## 3 sensitivity binary         0.806 Preprocessor1_Model1
## 4 specificity binary         0.810 Preprocessor1_Model1
## 5 recall      binary         0.806 Preprocessor1_Model1
## 6 roc_auc     binary         0.921 Preprocessor1_Model1

Grafico de los resultados por modelo M3

results_modelo3_rf<-
  casfut_modelo_rf_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) 

results_modelo3_xgb<-
  casfut_modelo_xgb_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config) 

results_modelo3_svm<-
  casfut_modelo_svm_final %>% 
  collect_metrics() %>% 
  select(-.estimator, -.config)

casm3_results<- data.frame(
  metrica = results_modelo3_rf$.metric,
  RF = results_modelo3_rf$.estimate,
  XGB = results_modelo3_xgb$.estimate,
  SVM = results_modelo3_svm$.estimate
)

casm3_results <-
  casm3_results %>%
  pivot_longer(cols = c("RF", "XGB", "SVM"), 
               names_to = "modelo") %>%
  filter(metrica == "accuracy" |
           metrica == "precision" |
           metrica == "recall" | 
           metrica == "roc_auc")  %>%
  mutate(metrica = factor(metrica), 
         modelo = factor(modelo))
  


casm3_results

## # A tibble: 12 × 3
##    metrica   modelo value
##    <fct>     <fct>  <dbl>
##  1 accuracy  RF     0.919
##  2 accuracy  XGB    0.871
##  3 accuracy  SVM    0.806
##  4 precision RF     0.935
##  5 precision XGB    0.939
##  6 precision SVM    0.954
##  7 recall    RF     0.971
##  8 recall    XGB    0.903
##  9 recall    SVM    0.806
## 10 roc_auc   RF     0.943
## 11 roc_auc   XGB    0.946
## 12 roc_auc   SVM    0.921

levels(casm3_results$metrica) <- c("Accuracy", "Precision", "Recall", "AUC ROC")


casm3_results %>% 
  ggplot(aes(x = metrica, y = value, fill = modelo))+
  geom_col(position = "dodge")+ 
  scale_fill_brewer(palette= "Pastel2")+
  scale_y_continuous(limits = c(0,1), expand = c(0,0))+
  labs(y = "", 
       x = "Metric",
       fill= NULL,
       title= "")

Predicción de la condición atlética a partir de la variabilidad de la frecuencia cardíaca, una aproximación desde la inteligencia artificial

Tony Estrella

2024-05-07

Abstract

Descripcion de los modelos

Librerias

Datos

Algoritmos

Random Forest

XGBoost

Support Vector Machine

Metricas

Modelo 1. Atleta vs Estudiante

EDA Datos M1

Division Datos M1

Receta M1

Workflow M1

Hyperparametros M1

Ranfom Forest

XGBoost

Support Vector Machine

Modelo final M1

Random Forest

Evaluacion RF M1

XGBoost

Evaluacion XGB M1

Support Vector Machine

Evaluacion SVM M1

Grafico de los resultados por modelo M1

Modelo 2. Caso respecto la muestra

EDA Datos M2

Division Datos M2

Receta M2

Workflow M2

Hyperparametros M2

Random Forest

XGBoost

Support Vector Machine

Modelo final M2

Random Forest

Evaluacion RF M2

XGBoost

Evaluaciuon XGB M2

Support Vector Machine

Evaluacion SVM M2

Grafico de los resultados por modelo M2

Modelo 3. Caso dentro de futbolistas

EDA Datos M3

Division Datos M3

Receta M3

Workflow M3

Hyperparametros M3

Random Forest

XGBoost

Support Vector Machine

Modelo final M3

Random Forest

Evaluacion RF M3

XGBoost

Evaluacion XGB M3

Support Vector Machine

Evaluacion SVM M3

Grafico de los resultados por modelo M3