El conjunto de datos original tiene 55,692 observaciones. Para cada variable, el total de datos atípicos y su respectiva proporción del total de observaciones es:
Ninguna columna numérica tiene distribución normal:
Code
no_norm(fum_eda)
[1] TRUE
Code
no_norm(fum_eda, fun = ad.test)
[1] TRUE
Code
no_norm(fum_eda, fun = cvm.test)
[1] TRUE
Entonces la prueba de Grubbs no es aplicable para detectar observaciones atípicas; a pesar de esto el comportamiento de los datos extremos es tan fuerte que la prueba rechaza la posibilidad que sean observaciones comunes
Code
outliers::grubbs.test(fum_eda$colesterol_bueno)
Grubbs test for one outlier
data: fum_eda$colesterol_bueno
G = 38.04268, U = 0.97401, p-value < 2.2e-16
alternative hypothesis: highest value 618 is an outlier
2 KNN
Una primera aproximación a la detección de los valores atípicos se realiza a través del puntaje dado por el algoritmo de k vecinos más cercanos.
Para hallar las observaciones anómalas se utiliza el algoritmo de bosque de aislamiento.
Code
# remotes::install_github("Zelazny7/isofor")aislamiento <- isofor::iForest(fum_eda, nt =3,phi =1e3) %>%predict(fum_eda)length(aislamiento)## [1] 55692summary(aislamiento)## Min. 1st Qu. Median Mean 3rd Qu. Max. ## 0.3531 0.3787 0.4015 0.4155 0.4376 0.8075
El algoritmo asigna a cada observación un puntaje entre 0 y 1 que indica qué tan fácil resulta separarla del resto de observaciones. Entre mayor sea el puntaje, más sencillo fue aislar a la observación y por tanto es verosímil creer que es atípica.
La estrategia es eliminar las observaciones con los puntajes más altos. Para esto se muestra la distribución de los puntajes:
Se aprecia que la gran mayoría de los datos tienen un puntaje bajo, lo que indica que no son observaciones atípicas. Un diagrama de caja y brazos permite apreciar los valores extremos de manera sencilla:
Entonces se eliminará todas aquellas variables que cuyo puntaje supere un umbral determinado, el cual debe ser grande pero no tanto como para eliminar más del 50% de los datos. Tras prueba y error se propone que el umbral sea el tercer cuantil de la distribución de puntajes más 1.1 vecese el rango intercuantil de la misma distribución. Esto garantiza que solo se elimine el 4.98% de los datos.
# saveRDS(object = fum_imp, file = "output/fum_imp.RDS")tablero %>%pin_write(fum_imp,"fum_imp",title ="Datos tras imputar",description ="Se imputó con bosques aleatorios")
Source Code
---title: "Atípicos"author: "Mauricio Prieto Palacios"format: html: toc: true number-sections: true---# Resumen atípicos```{r source}#| include = FALSEsource("codigo/3_funciones.R",local = knitr::knit_global())fum_eda <- tablero %>%pin_read("fum_eda")```---date: "Última edición el `r fecha_documento`."---{style="float:right;" width="200"}El conjunto de datos original tiene `r comma(nrow(fum_eda))` observaciones. Para cada variable, el total de datos atípicos y su respectiva proporción del total de observaciones es:```{r tbl-atip}#| label: tbl-atip#| tbl-cap: "Observaciones atípicas por variables"fum_eda %>%resumen_atipicos() %>%gt() %>%fmt_percent(columns = prop,decimals =2) %>%fmt_integer(columns = total,sep_mark =",")```Por ejemplo, la variable `colesterol_bueno` presenta muchas observaciones extremas```{r g1}fum_eda %>%ggplot(aes(colesterol_bueno)) +geom_boxplot(fill = pint["azulc"]) +scale_x_continuous(breaks =breaks_width(100))```Un caso incluso peor ocurren para `transpeptidasa`:```{r g2}fum_eda %>%ggplot(aes(transpeptidasa)) +geom_boxplot(fill = pint["azulc"]) ```Ninguna columna numérica tiene distribución normal:```{r dist-norm}#| warning: falseno_norm(fum_eda)no_norm(fum_eda, fun = ad.test)no_norm(fum_eda, fun = cvm.test)```Entonces la prueba de *Grubbs* no es aplicable para detectar observaciones atípicas; a pesar de esto el comportamiento de los datos extremos es tan fuerte que la prueba rechaza la posibilidad que sean observaciones comunes```{r grubbs}outliers::grubbs.test(fum_eda$colesterol_bueno)```# KNNUna primera aproximación a la detección de los valores atípicos se realiza a través del puntaje dado por el algoritmo de *k vecinos más cercanos*.```{r knn}#| cache: trueknn_distancia <- fum_eda %>%select_if(is.numeric) %>%scale() %>% FNN::get.knn(k =3) %>%pluck("nn.dist") %>%rowMeans()``````{r knn-distancia}#| collapse: truemax(knn_distancia)which.max(knn_distancia)``````{r gknn}fum_knn <- fum_eda %>%mutate(knn_distancia = knn_distancia)fum_knn %>%ggplot(aes(knn_distancia)) +geom_boxplot()``````{r gknn2}fum_knn %>%ggplot(aes(colesterol_malo, creatinina, size = knn_distancia)) +geom_point(alpha =0.1)```# AislamientoPara hallar las observaciones anómalas se utiliza el algoritmo de *bosque de aislamiento*.```{r aislar}#| cache: true#| collapse: true# remotes::install_github("Zelazny7/isofor")aislamiento <- isofor::iForest(fum_eda, nt =3,phi =1e3) %>%predict(fum_eda)length(aislamiento)summary(aislamiento)```El algoritmo asigna a cada observación un puntaje entre 0 y 1 que indica qué tan fácil resulta separarla del resto de observaciones. Entre mayor sea el puntaje, más sencillo fue aislar a la observación y por tanto es verosímil creer que es atípica.La estrategia es eliminar las observaciones con los puntajes más altos. Para esto se muestra la distribución de los puntajes:```{r g-aislamiento}aislamiento %>%as_tibble() %>%ggplot(aes(value)) +geom_histogram(fill = pint["azulc"],colour ="white",bins =30) +labs(x ="Puntaje aislamiento",y ="Conteo") +scale_x_continuous(labels =label_percent()) +theme(panel.grid.major.y =element_blank(),panel.grid.minor.y =element_blank())# ggsave(filename = "output/imagenes/aislamiento.pdf")```Se aprecia que la gran mayoría de los datos tienen un puntaje bajo, lo que indica que no son observaciones atípicas. Un diagrama de caja y brazos permite apreciar los valores extremos de manera sencilla:```{r}aislamiento %>%as_tibble() %>%ggplot(aes(value)) +geom_boxplot(fill = pint["azulc"],outlier.colour = pint["azulc"]) +labs(x ="Puntaje aislamiento") +scale_x_continuous(labels =label_percent(),breaks =breaks_width(0.05)) +theme(panel.grid.major.y =element_blank(),panel.grid.minor.y =element_blank(),panel.grid.minor.x =element_blank(),axis.ticks.y =element_blank(),axis.text.y =element_blank())```Entonces se eliminará todas aquellas variables que cuyo puntaje supere un umbral determinado, el cual debe ser grande pero no tanto como para eliminar más del 50% de los datos. Tras prueba y error se propone que el umbral sea el tercer cuantil de la distribución de puntajes más 1.1 vecese el rango intercuantil de la misma distribución. Esto garantiza que solo se elimine el 4.98% de los datos.```{r umbral}umbral <-quantile(aislamiento, 0.75, names =FALSE) +1.1*IQR(aislamiento)umbraltotal_anomalos <-length(aislamiento[aislamiento >= umbral])total_anomalostotal_anomalos /nrow(fum_eda)anomalo <-which(aislamiento >= umbral)```Incluso dentro de los datos anómalos hay observaciones extremas en algunas variables como `colesterol_bueno`:```{r ganomalo}fum_eda %>%slice(anomalo) %>%ggplot(aes(colesterol_bueno)) +geom_boxplot(fill = pint["azulc"])```# Sin atípicosAhora se elimina los datos anómalos.```{r sinatipico}fum_sinatipico <- fum_eda %>%slice(setdiff(1:nrow(fum_eda), anomalo))```Se conservó poco más del 95% de los datos```{r prop-atipico}nrow(fum_sinatipico) /nrow(fum_eda)```De los datos filtrados, ahora se muestra el total de datos atípicos y su proporción para cada variable```{r}fum_sinatipico %>%resumen_atipicos() %>%gt() %>%fmt_percent(columns = prop,decimals =2) %>%fmt_integer(columns = total,sep_mark =",")```Hay una reducción ligera en las proporciones, pero aún hay comportamientos extremos en alguas variables como `azucar`.```{r gsinatipico}fum_sinatipico %>%ggplot(aes(azucar)) +geom_histogram()``````{r resumen-sinatipico}est_atip <- fum_eda %>%group_by(fumador, sexo) %>%summarise(across(.cols =c(transpeptidasa, azucar),.fns = est_res,.names ="{.col}-{.fn}")) %>%pivot_longer(cols =-c(fumador, sexo),names_to =c("var", ".value"),values_to ="a",names_sep ="-") %>%pivot_longer(cols =-c(fumador, sexo, var),names_to ="estadistica",values_to ="estimacion") %>%mutate(estadistica =as_factor(estadistica),estadistica =fct_inorder(estadistica),var =as_factor(var)) %>%ungroup()``````{r resumen-sinatipico2}#| eval: falseest_atip %>%# filter(estadistica == "min") %>% ggplot(aes(estimacion, var, fill = fumador)) +geom_col(position =position_dodge()) +facet_wrap(~ estadistica, scales ="free") +scale_fill_pint("calido") +theme(legend.position ="bottom")``````{r gtrans}fum_eda %>%ggplot(aes(colesterol_malo, fill = fumador)) +geom_histogram()``````{r res}fum_eda %>%summarise(across(where(is.numeric),.fns = est_res,.names ="{.col}-{.fn}")) %>%pivot_longer(everything(),names_to =c("variable", ".value"),values_to ="calc",names_sep ="-" )```# Imputar atípicos```{r}q3trans <-quantile(fum_sinatipico$transpeptidasa, probs =0.75)summary(fum_sinatipico$transpeptidasa)``````{r ignorar}# fum_imputar <- fum_sinatipico %>% # mutate(transpeptidasa = ifelse(transpeptidasa > quantile(transpeptidasa, probs = 0.75), # NA, # transpeptidasa)) %>% # as.data.frame()# # nimp <- fum_imputar %>% # filter(is.na(transpeptidasa)) %>% # nrow() ``````{r}fum_imputar <- fum_sinatipico %>%mutate(across(.cols =c(transpeptidasa, azucar, aspartato, trigliceridos, creatinina, colesterol_malo),.fns =~ifelse(.x >quantile(.x, probs =0.75),NA, .x) ) ) %>%as.data.frame()fum_imputar %>% naniar::miss_var_summary()``````{r}#| cache: trueimp <- missForest::missForest(fum_imputar,ntree =10)``````{r}class(imp)str(imp)naniar::miss_var_summary(imp$ximp)``````{r}fum_imp <- imp$ximp %>%as_tibble() %>%mutate(across(.cols =c(azucar, colesterol_malo, aspartato, transpeptidasa, trigliceridos),.fns = as.integer) )``````{r}resumen_atipicos(fum_imp)``````{r}gg_double(fum_imp, creatinina, num_bins =10, ancho =0.1)``````{r}# saveRDS(object = fum_imp, file = "output/fum_imp.RDS")tablero %>%pin_write(fum_imp,"fum_imp",title ="Datos tras imputar",description ="Se imputó con bosques aleatorios")```
El conjunto de datos original tiene 55,692 observaciones. Para cada variable, el total de datos atípicos y su respectiva proporción del total de observaciones es:
