Dependencia Alcohólica En Estudiantes Universitarios
Bartolo Alberto Flores Guzman; Miguel Eduardo Acosta Xacan; Angel Ariel Solís Mata
2022-06-03
Análisis Clúster
Comparar el comportamiento dependiente para la integración de grupos estudiantiles mediante la prueba AUDIT de la Organización Mundial de la Salud (OMS) aplicando análisis clúster y análisis de correspondencia múltiple, más detalles en el siguiente link: https://proyectocaweluus.blogspot.com/2022/05/dependencia-alcoholica-en-estudiantes.html
Instrumento de la OMS: https://es.m.wikipedia.org/wiki/AUDIT
Bases de datos: https://drive.google.com/drive/folders/1wdoKzIv8xOqmY2YLyoME5FLuI3QDd8Lw?usp=sharing
Primero se carga la base de datos que se llama “PROYECTO”, disponible en el link:
#Cargamos la base de datos
library(readxl)
PROYECTO <- read_excel("PROYECTO.xlsx")
head(PROYECTO)## # A tibble: 6 x 14
## Edad Género SEMESTRE P1 P2 P3 P4 P5 P6 P7 P8 P9
## <dbl> <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 18 F SEGUNDO 0 0 0 0 0 0 0 0 0
## 2 18 F PRIMERO 1 0 0 0 0 0 0 0 0
## 3 20 F CUARTO 0 0 0 4 0 0 0 0 0
## 4 18 F SEGUNDO 1 1 1 0 0 0 0 0 0
## 5 18 F SEXTO 2 3 3 3 0 0 0 2 0
## 6 20 F CUARTO 0 0 0 0 0 0 0 0 0
## # ... with 2 more variables: P10 <dbl>, PUNTAJE <dbl>Procedemos a cargar las librerias siguientes
#Cargamos las librerias
library(tidyverse)## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --## v ggplot2 3.3.5 v purrr 0.3.4
## v tibble 3.1.4 v dplyr 1.0.8
## v tidyr 1.2.0 v stringr 1.4.0
## v readr 2.0.1 v forcats 0.5.1## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()library(cluster)
library(factoextra)## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBalibrary(NbClust)
library(tidyr)Eliminamos las siguientes variables para hacer el analisis:
#Eliminamos las variables categoricas
PROYECTO$Género<-NULL
PROYECTO$SEMESTRE<-NULL
PROYECTO$PUNTAJE<-NULL
PROYECTO$Edad<-NULL
df <- PROYECTO
head(df)## # A tibble: 6 x 10
## P1 P2 P3 P4 P5 P6 P7 P8 P9 P10
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0 0 0 0 0 0 0 0 0 0
## 2 1 0 0 0 0 0 0 0 0 0
## 3 0 0 0 4 0 0 0 0 0 0
## 4 1 1 1 0 0 0 0 0 0 0
## 5 2 3 3 3 0 0 0 2 0 0
## 6 0 0 0 0 0 0 0 0 0 0Se crea el dendograma para visualizar las posibles agrupaciones que se pueden formar
#Creamos el dendograma con las 3 agrupaciones
res2 <- hcut(df, k = 3, stand = FALSE)
fviz_dend(res2, rect = TRUE, cex = 0.5,
k_colors = c("#35B800","#D21E1C","#0080FF"))## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
Se procede a calcular la matriz de distancias y mediante los siguientes metodos se calcula el numero de agrupaciones adecuadas.
#calcular la matriz de distacias utilizando
m.distancia <- get_dist(df, method = "euclidean") #el método aceptado también puede ser: "maximum", "manhattan", "canberra", "binary", "minkowski", "pearson", "spearman" o "kendall"
head(m.distancia)## [1] 1.000000 4.000000 1.732051 5.916080 0.000000 1.414214#estimar el número de clústers con el método silhouette
fviz_nbclust(df, kmeans, method = "gap_stat")
Se calculan las 3 agrupaciones para despues representarlas en el grafico de K-means.
#calculamos los dos clústers
k2<-kmeans(df, centers = 3, nstart = 25)
k2## K-means clustering with 3 clusters of sizes 9, 25, 5
##
## Cluster means:
## P1 P2 P3 P4 P5 P6 P7 P8
## 1 2.00 2.111111 1.888889 0.4444444 0.4444444 0.1111111 0.6666667 1.222222
## 2 1.08 0.320000 0.280000 0.2800000 0.0400000 0.0400000 0.1200000 0.120000
## 3 1.00 0.400000 0.200000 0.0000000 0.0000000 0.0000000 0.0000000 0.000000
## P9 P10
## 1 0.4444444 0.8888889
## 2 0.0000000 0.1600000
## 3 4.0000000 0.8000000
##
## Clustering vector:
## [1] 2 2 2 2 1 2 2 2 2 1 1 2 2 2 3 1 2 2 3 2 2 3 1 2 2 2 1 3 3 2 1 2 1 2 1 2 2 2
## [39] 2
##
## Within cluster sum of squares by cluster:
## [1] 67.77778 57.92000 18.80000
## (between_SS / total_SS = 47.5 %)
##
## Available components:
##
## [1] "cluster" "centers" "totss" "withinss" "tot.withinss"
## [6] "betweenss" "size" "iter" "ifault"str(k2)## List of 9
## $ cluster : int [1:39] 2 2 2 2 1 2 2 2 2 1 ...
## $ centers : num [1:3, 1:10] 2 1.08 1 2.11 0.32 ...
## ..- attr(*, "dimnames")=List of 2
## .. ..$ : chr [1:3] "1" "2" "3"
## .. ..$ : chr [1:10] "P1" "P2" "P3" "P4" ...
## $ totss : num 275
## $ withinss : num [1:3] 67.8 57.9 18.8
## $ tot.withinss: num 144
## $ betweenss : num 131
## $ size : int [1:3] 9 25 5
## $ iter : int 3
## $ ifault : int 0
## - attr(*, "class")= chr "kmeans"#plotear los cluster
fviz_cluster(k2, data = df)
fviz_cluster(k2, data = df, ellipse.type = "euclid",repel = TRUE,star.plot = TRUE) ## Warning: ggrepel: 7 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps
Una vez que ya tenemos nuestras posibles agrupaciones lo que sigue es clasificar a los individuos en la agrupación que les corresponda de acuerdo a su puntaje obtenido.
#Volvemos a cargar la base de datos original con todas las variables
library(readxl)
PROYECTO <- read_excel("PROYECTO.xlsx")
head(PROYECTO)## # A tibble: 6 x 14
## Edad Género SEMESTRE P1 P2 P3 P4 P5 P6 P7 P8 P9
## <dbl> <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 18 F SEGUNDO 0 0 0 0 0 0 0 0 0
## 2 18 F PRIMERO 1 0 0 0 0 0 0 0 0
## 3 20 F CUARTO 0 0 0 4 0 0 0 0 0
## 4 18 F SEGUNDO 1 1 1 0 0 0 0 0 0
## 5 18 F SEXTO 2 3 3 3 0 0 0 2 0
## 6 20 F CUARTO 0 0 0 0 0 0 0 0 0
## # ... with 2 more variables: P10 <dbl>, PUNTAJE <dbl>#pasar los cluster a mi df inicial para trabajar con ellos
df %>%
mutate(Cluster = k2$cluster) %>%
group_by(Cluster) %>%
summarise_all("mean")## # A tibble: 3 x 11
## Cluster P1 P2 P3 P4 P5 P6 P7 P8 P9 P10
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2 2.11 1.89 0.444 0.444 0.111 0.667 1.22 0.444 0.889
## 2 2 1.08 0.32 0.28 0.28 0.04 0.04 0.12 0.12 0 0.16
## 3 3 1 0.4 0.2 0 0 0 0 0 4 0.8Se mete la base en un nuevo objeto.
df <- PROYECTO
head(df)## # A tibble: 6 x 14
## Edad Género SEMESTRE P1 P2 P3 P4 P5 P6 P7 P8 P9
## <dbl> <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 18 F SEGUNDO 0 0 0 0 0 0 0 0 0
## 2 18 F PRIMERO 1 0 0 0 0 0 0 0 0
## 3 20 F CUARTO 0 0 0 4 0 0 0 0 0
## 4 18 F SEGUNDO 1 1 1 0 0 0 0 0 0
## 5 18 F SEXTO 2 3 3 3 0 0 0 2 0
## 6 20 F CUARTO 0 0 0 0 0 0 0 0 0
## # ... with 2 more variables: P10 <dbl>, PUNTAJE <dbl>Añadimos una nueva variable llamada clus donde añadimos los clusters a cada individuo
df$clus<-as.factor(k2$cluster)
head(df)## # A tibble: 6 x 15
## Edad Género SEMESTRE P1 P2 P3 P4 P5 P6 P7 P8 P9
## <dbl> <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 18 F SEGUNDO 0 0 0 0 0 0 0 0 0
## 2 18 F PRIMERO 1 0 0 0 0 0 0 0 0
## 3 20 F CUARTO 0 0 0 4 0 0 0 0 0
## 4 18 F SEGUNDO 1 1 1 0 0 0 0 0 0
## 5 18 F SEXTO 2 3 3 3 0 0 0 2 0
## 6 20 F CUARTO 0 0 0 0 0 0 0 0 0
## # ... with 3 more variables: P10 <dbl>, PUNTAJE <dbl>, clus <fct>Por último, se ve el promedio de cada agrupación en cada una de las preguntas del cuestionario. Primero se crea una nueva base en donde contiene la variable característica y valor.
data_long <- gather(df, caracteristica, valor, P1:P10, factor_key=TRUE)
ggplot(data_long, aes(as.factor(x = caracteristica), y = valor,group=clus, colour = clus)) +
stat_summary(fun = mean, geom="pointrange", size = 1)+
stat_summary(geom="line")## No summary function supplied, defaulting to `mean_se()`## Warning: Removed 30 rows containing missing values (geom_segment).
Análisis de Correspondencia Múltiple (ACM)
Para realizar el análisis de correspondencia Múltiple se retoma el ejemplo trabajado con el análisis Cúster. Se realizarán dos análisis de correspondencia Múltiple, en donde se toman la variable género y semestre con cada una de las agrupaciones, una de la OMS y otra con la que se hizo en el Análisis anterior. Trabajamos con una nueva base de datos llamada “Agrupaciones”, disponible en el link de la descripción.
#Cargamos la base de datos
library(readxl)
PROYECTO <- read_excel("Agrupaciones.xlsx")
head(PROYECTO)## # A tibble: 6 x 4
## Género SEMESTRE Clus_Riesgo OMS
## <chr> <chr> <chr> <chr>
## 1 F SEGUNDO MEDIO BAJA
## 2 F PRIMERO MEDIO BAJA
## 3 F CUARTO MEDIO BAJA
## 4 F SEGUNDO MEDIO BAJA
## 5 F SEXTO ALTO PROBABLE
## 6 F CUARTO MEDIO BAJAPrimero se realiza para las agrupaciones obtenidas mediante el análisis Cluster.
Ejem<-PROYECTO[1:3]
head(Ejem)## # A tibble: 6 x 3
## Género SEMESTRE Clus_Riesgo
## <chr> <chr> <chr>
## 1 F SEGUNDO MEDIO
## 2 F PRIMERO MEDIO
## 3 F CUARTO MEDIO
## 4 F SEGUNDO MEDIO
## 5 F SEXTO ALTO
## 6 F CUARTO MEDIOSe utiliza la librería ca para realizar el análisis de correspondencia Míltiple.
library(ca)
str(Ejem)## tibble [39 x 3] (S3: tbl_df/tbl/data.frame)
## $ Género : chr [1:39] "F" "F" "F" "F" ...
## $ SEMESTRE : chr [1:39] "SEGUNDO" "PRIMERO" "CUARTO" "SEGUNDO" ...
## $ Clus_Riesgo: chr [1:39] "MEDIO" "MEDIO" "MEDIO" "MEDIO" ...mjca(Ejem)##
## Eigenvalues:
## 1 2 3 4
## Value 0.050455 0.033666 0.019419 0
## Percentage 35.22% 23.5% 13.55% 0%
##
##
## Columns:
## Género:F Género:M SEMESTRE:CUARTO SEMESTRE:PRIMERO SEMESTRE:SEGUNDO
## Mass 0.179487 0.153846 0.264957 0.034188 0.017094
## ChiDist 0.567179 0.661708 0.300108 1.722816 2.576635
## Inertia 0.057739 0.067363 0.023863 0.101473 0.113488
## Dim. 1 -0.120738 0.140861 0.038203 -1.031694 -1.342798
## Dim. 2 0.852275 -0.994321 -0.243859 -0.066403 4.085652
## SEMESTRE:SEXTO SEMESTRE:TERCERO Clus_Riesgo:ALTO Clus_Riesgo:BAJO
## Mass 0.008547 0.008547 0.076923 0.042735
## ChiDist 3.750132 3.901160 1.115318 1.657539
## Inertia 0.120201 0.130077 0.095687 0.117412
## Dim. 1 -1.262996 6.891077 -0.446656 3.216513
## Dim. 2 -2.458428 2.112364 -1.754433 -0.077110
## Clus_Riesgo:MEDIO
## Mass 0.213675
## ChiDist 0.463896
## Inertia 0.045983
## Dim. 1 -0.482506
## Dim. 2 0.647018plot(mjca(Ejem))
Ahora se realiza con las agrupaciones estipuladas según la Organización Mundial de la Salud (OMS).
Ejem<-PROYECTO[,-3]
head(Ejem)## # A tibble: 6 x 3
## Género SEMESTRE OMS
## <chr> <chr> <chr>
## 1 F SEGUNDO BAJA
## 2 F PRIMERO BAJA
## 3 F CUARTO BAJA
## 4 F SEGUNDO BAJA
## 5 F SEXTO PROBABLE
## 6 F CUARTO BAJA#Se obtiene un resumen de los datos.
str(Ejem)## tibble [39 x 3] (S3: tbl_df/tbl/data.frame)
## $ Género : chr [1:39] "F" "F" "F" "F" ...
## $ SEMESTRE: chr [1:39] "SEGUNDO" "PRIMERO" "CUARTO" "SEGUNDO" ...
## $ OMS : chr [1:39] "BAJA" "BAJA" "BAJA" "BAJA" ...#Representación gráfica
mjca(Ejem)##
## Eigenvalues:
## 1 2 3 4
## Value 0.075844 0.034366 0.022155 0
## Percentage 41.78% 18.93% 12.2% 0%
##
##
## Columns:
## Género:F Género:M SEMESTRE:CUARTO SEMESTRE:PRIMERO SEMESTRE:SEGUNDO
## Mass 0.179487 0.153846 0.264957 0.034188 0.017094
## ChiDist 0.572710 0.668162 0.314357 1.904293 2.554466
## Inertia 0.058871 0.068683 0.026183 0.123977 0.111544
## Dim. 1 0.513001 -0.598502 -0.419383 2.922039 1.156682
## Dim. 2 -0.166358 0.194085 -0.215125 1.703406 -1.954530
## SEMESTRE:SEXTO SEMESTRE:TERCERO OMS:ALTA OMS:BAJA OMS:PROBABLE
## Mass 0.008547 0.008547 0.008547 0.273504 0.051282
## ChiDist 3.845220 3.609058 3.983597 0.289566 1.486192
## Inertia 0.126374 0.111327 0.135633 0.022933 0.113270
## Dim. 1 -2.157333 1.156682 6.236506 0.124094 -1.701251
## Dim. 2 5.718829 -1.954530 4.145673 -0.558303 2.286669plot(mjca(Ejem))