Clustering
2023-12-12
library(ggplot2)
library(ggdendro)
library(cluster)
library(factoextra)## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBalibrary(dplyr)##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(clustMixType)
library(dendextend) ##
## ---------------------
## Welcome to dendextend version 1.17.1
## Type citation('dendextend') for how to cite the package.
##
## Type browseVignettes(package = 'dendextend') for the package vignette.
## The github page is: https://github.com/talgalili/dendextend/
##
## Suggestions and bug-reports can be submitted at: https://github.com/talgalili/dendextend/issues
## You may ask questions at stackoverflow, use the r and dendextend tags:
## https://stackoverflow.com/questions/tagged/dendextend
##
## To suppress this message use: suppressPackageStartupMessages(library(dendextend))
## ---------------------##
## Attaching package: 'dendextend'## The following object is masked from 'package:ggdendro':
##
## theme_dendro## The following object is masked from 'package:stats':
##
## cutreelibrary(fpc)Traemos nuestro dataset para trabajar con él
data_obesidad = read.csv("/Users/macbookair/Desktop/R (MASTER)/ObesityDataSet_raw_and_data_sinthetic.csv", header = T)Truncamos valores con decimales
columnas_a_truncar = c('Age','NCP', 'FCVC','CH2O','FAF', 'TUE') # Lista de columnas a truncar
# Creamos un nuevo dataframe con valores truncados
tabla_truncada = data_obesidad
tabla_truncada[, columnas_a_truncar] = lapply(tabla_truncada[, columnas_a_truncar], trunc)Variables a factor
# Seleccionamos las variables a convertir a factor
variables_a_factor = c('FCVC', "NCP", "CH2O", 'FAF',"Gender", 'TUE','FAVC','CAEC','SMOKE','CALC','MTRANS','NObeyesdad')
# Utilizamos lapply para convertir las variables a factor
tabla_truncada[, variables_a_factor] = lapply(tabla_truncada[, variables_a_factor], as.factor)Depuramos dataset
# Depuramos el dataset eliminando algunas variables que consideramos son menos relevantes
columnas_a_eliminar= c('Height','family_history_with_overweight','NCP','CH2O','SCC','Weight', "SMOKE", "FAVC", "TUE") # eliminamos también las variable que habíamos descubierto que no tienen mucho peso y nos generan ruido
t_buena = tabla_truncada %>%
select(-one_of(columnas_a_eliminar))Exploración
Antes de iniciar con el clustering, haremos una nueva exploración de nuestros datos pues a lo largo del proceso el dataframe ha ido cambiando, así que consideramos que es una buena idea echar de nuevo un vistazo de forma breve para ver si encontramos algo interesante con esta nueva configuración de nuestros datos. Nos enfocaremos en analizar principalmente la relación entre la variable Age y el nivel de obesidad, ya que de acuerdo al índice de Gini, estas fueron las variables más estrechamente relacionadas.
str(t_buena)## 'data.frame': 2111 obs. of 8 variables:
## $ Gender : Factor w/ 2 levels "Female","Male": 1 1 2 2 2 2 1 2 2 2 ...
## $ Age : num 21 21 23 27 22 29 23 22 24 22 ...
## $ FCVC : Factor w/ 3 levels "1","2","3": 2 3 2 3 2 2 3 2 3 2 ...
## $ CAEC : Factor w/ 4 levels "Always","Frequently",..: 4 4 4 4 4 4 4 4 4 4 ...
## $ FAF : Factor w/ 4 levels "0","1","2","3": 1 4 3 3 1 1 2 4 2 2 ...
## $ CALC : Factor w/ 4 levels "Always","Frequently",..: 3 4 2 2 4 4 4 4 2 3 ...
## $ MTRANS : Factor w/ 5 levels "Automobile","Bike",..: 4 4 4 5 4 1 3 4 4 4 ...
## $ NObeyesdad: Factor w/ 7 levels "Insufficient_Weight",..: 2 2 2 6 7 2 2 2 2 2 ...# Graficamos el nivel de obesidad en relación a la edad, para esto hay que hacer una tabla nueva que agrupe a la edad en clases, pues son demasiados valores
# Definimos los límites y el número de intervalos
edades_bins = cut(t_buena$Age, breaks = c(14, 20, 30, 40, 50, 61), labels = c("14-20", "21-30", "31-40", "41-50", "51-61"), include.lowest = TRUE)
# Creamos un nuevo data frame con las edades agrupadas
t_buena_agrupado <- data.frame(Gender = t_buena$Gender, EdadesAgrupadas = edades_bins, NObeyesdad = t_buena$NObeyesdad)
# Grafica el nivel de obesidad en función de las edades agrupadas
ggplot(t_buena_agrupado, aes(x = EdadesAgrupadas, fill = NObeyesdad)) +
geom_bar(position = "dodge", stat = "count") +
ggtitle("Nivel de obesidad y Edad agrupada") +
xlab("Edades Agrupadas") +
ylab("Conteo") +
theme_minimal()
Aquí miramos las frecuencias absolutas del nivel de obesidad en relación
a las edades.(ojo, los tipos de obesidad están en orden alfabético)
Anteriormente ya habíamos notado que la edad influye significativamente
sobre el nivel de obesidad. Una gran cantidad de personas con Obesidad
tipo III se encuentran en el rango de edades de 21 a 30, mientras que la
mayoría de las personas que tienen peso insuficiente están en el rango
de edad de entre 14 y 20.
# Calcula las frecuencias relativas
frecuencias_relativas <- table(t_buena_agrupado$EdadesAgrupadas, t_buena_agrupado$NObeyesdad) / rowSums(table(t_buena_agrupado$EdadesAgrupadas, t_buena_agrupado$NObeyesdad))
# Convierte las frecuencias relativas en un data frame
df_frecuencias_relativas <- as.data.frame(frecuencias_relativas)
# Biblioteca necesaria
library(ggplot2)
# Grafica el nivel de obesidad en función de las edades agrupadas (frecuencias relativas)
ggplot(df_frecuencias_relativas, aes(x = Var1, y = Freq, fill = Var2)) +
geom_bar(stat = "identity", position = "dodge") +
ggtitle("Nivel de obesidad y Edad agrupada (Frecuencias Relativas)") +
xlab("Edades Agrupadas") +
ylab("Frecuencia Relativa") +
scale_fill_manual(values = c("Insufficient_Weight" = "lightblue", "Normal_Weight" = "blue", "Overweight_Level_I" = "red", "Overweight_Level_II" = "orange", "Obesity_Type_I" = "lightgreen", "Obesity_Type_II" = "black", "Obesity_Type_III" = "green"), name = "NObeyesdad", labels = c("no" = "No Obesidad", "yes" = "Obesidad")) + # Personaliza los colores y la leyenda
theme_minimal()
En las frecuencias relativas hay información interesante también, vemos que la mayoría de las personas en el rango de 51 a 61 tienen sobrepeso nivel II, la mayoría de las personas en el rango de edad de 41 a 50 tienen obesidad tipo II y como habíamos observado en el gráfico anterior, la mayoría de las personas de 14 a 20 tienen peso insuficiente. Otra observación es que en el rango de edad entre 51 y 61 prácticamente no tenemos personas con Obesidad tipo II o tipo III, esto puede sugerir dos cosas, o que la expectativa de vida de las personas con este tipo de obesidad es menor o que cuando alcanzan esa edad pierden peso.
# Crea un nuevo data frame con las edades agrupadas
t_buenascatter <- data.frame(Gender = t_buena$Gender, Age= t_buena$Age , NObeyesdad = t_buena$NObeyesdad)
# Grafica el nivel de obesidad en función de las edades agrupadas como puntos (clusters)
ggplot(t_buenascatter, aes(x = Age, y = Gender, color = NObeyesdad)) +
geom_jitter(position = position_jitter(width = 0.2, height = 0), size = 3) +
ggtitle("Nivel de obesidad | Edad | Género") +
xlab("Edades Agrupadas") +
ylab("Género") +
theme_minimal()
Haremos otro gráfico similar pero agrupando las edades en rangos
# Define los límites y el número de intervalos
edades <- cut(t_buena$Age, breaks = c(14, 20, 30, 40, 50, 61), labels = c("14-20", "21-30", "31-40", "41-50", "51-61"), include.lowest = TRUE)
# Crea un nuevo data frame con las edades agrupadas
t_buenascatter <- data.frame(Gender = t_buena$Gender, EdadesAgrupadas = edades, NObeyesdad = t_buena$NObeyesdad)
# Grafica el nivel de obesidad en función de las edades agrupadas como puntos (clusters)
ggplot(t_buenascatter, aes(x = EdadesAgrupadas, y = Gender, color = NObeyesdad)) +
geom_jitter(position = position_jitter(width = 0.2, height = 0), size = 3) +
ggtitle("Nivel de obesidad y Edad agrupada") +
xlab("Edades Agrupadas") +
ylab("Género") +
theme_minimal()
En general estos scatterplots no son muy buenos en términos visuales, ya
que al ser casi todas nuestras variables categóricas los puntos se
ordenan en líneas y esto dificulta el que podamos observar una
distribución de los puntos que nos permita agruparlos en posibles
clusters.
Aquí podemos ver más o menos cómo se agrupan los niveles de sobrepeso con relación a su genero y edad. Aunque no estámos muy seguros de si este gráfico sirve para interpretar pues los puntos podrían estar encimados.
Vamos a hacer un primer clustering basado en prototipos y usando las variables de mayor relevancia
Clustering
Hacemos un primer clustering con kproto y 3 clusters seleccionando las columnas que parecen ser más relevantes.
# Seleccionamos las columnas relevantes para el clustering (variables numéricas y categóricas)
t_buena_clustering = t_buena[, c("Age", "FCVC", "CAEC", "FAF", "CALC")]
# Especificamos el número de clusters
num_clusters = 3
# Realizamos el clustering con k-prototypes
resultados_clustering = kproto(t_buena_clustering, num_clusters, iter.max = 20, nstart = 10)## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## Estimated lambda: 82.66924
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.
##
## # NAs in variables:
## Age FCVC CAEC FAF CALC
## 0 0 0 0 0
## 0 observation(s) with NAs.
##
## 0 observation(s) with NAs.# Visualizamos los resultados
print(resultados_clustering)## Distance type: standard
##
## Numeric predictors: 1
## Categorical predictors: 4
## Lambda: 82.66924
##
## Number of Clusters: 3
## Cluster sizes: 399 716 996
## Within cluster error: 42461.28 68391.16 108915.3
##
## Cluster prototypes:
## Age FCVC CAEC FAF CALC
## 1 34.44110 2 Sometimes 0 Sometimes
## 2 22.83380 3 Sometimes 0 Sometimes
## 3 20.59739 2 Sometimes 1 Sometimes# Añadimos la información de los clusters al conjunto de datos original
t_buena_con_clusters = cbind(t_buena, Cluster = resultados_clustering$cluster)
# Visualiza el conjunto de datos con la asignación de clusters
head(t_buena_con_clusters)## Gender Age FCVC CAEC FAF CALC MTRANS
## 1 Female 21 2 Sometimes 0 no Public_Transportation
## 2 Female 21 3 Sometimes 3 Sometimes Public_Transportation
## 3 Male 23 2 Sometimes 2 Frequently Public_Transportation
## 4 Male 27 3 Sometimes 2 Frequently Walking
## 5 Male 22 2 Sometimes 0 Sometimes Public_Transportation
## 6 Male 29 2 Sometimes 0 Sometimes Automobile
## NObeyesdad Cluster
## 1 Normal_Weight 3
## 2 Normal_Weight 2
## 3 Normal_Weight 3
## 4 Overweight_Level_I 2
## 5 Overweight_Level_II 2
## 6 Normal_Weight 1clusplot(t_buena_con_clusters, resultados_clustering$cluster, color=T, shade=T, labels=0, lines=0, main="CLUSTERING k Prototipos")
Estos componentes explican únicamente el 42.33 % de la variabilidad
Ahora intentaremos otro modelo con K-means para variables mixtas (categóricas y numéricas)
# Calculamos la matriz de distancia de Gower
distancia_gower = daisy(t_buena, metric = "gower")
# Realizamos el clustering con k-means
k = 4 # Lo intentamos con varios pero finalmente 4 pareció la mejor opción
kmeans_result = kmeans(distancia_gower, centers = k, nstart = 20)
# Visualizamos los resultados
table(kmeans_result$cluster)##
## 1 2 3 4
## 381 885 414 431# Calculamos las métricas utilizando cluster.stats
cluster_metrics <- cluster.stats(distancia_gower, kmeans_result$cluster)
# Imprimimos las métricas
print(cluster_metrics)## $n
## [1] 2111
##
## $cluster.number
## [1] 4
##
## $cluster.size
## [1] 381 885 414 431
##
## $min.cluster.size
## [1] 381
##
## $noisen
## [1] 0
##
## $diameter
## [1] 0.9920213 0.7659574 0.8111702 0.5638298
##
## $average.distance
## [1] 0.5261678 0.3407161 0.3662156 0.1634715
##
## $median.distance
## [1] 0.5132979 0.3776596 0.3882979 0.1382979
##
## $separation
## [1] 0.007978723 0.007978723 0.125000000 0.015957447
##
## $average.toother
## [1] 0.5735146 0.5039418 0.5531966 0.5175171
##
## $separation.matrix
## [,1] [,2] [,3] [,4]
## [1,] 0.000000000 0.007978723 0.125 0.01595745
## [2,] 0.007978723 0.000000000 0.125 0.12500000
## [3,] 0.125000000 0.125000000 0.000 0.12500000
## [4,] 0.015957447 0.125000000 0.125 0.00000000
##
## $ave.between.matrix
## [,1] [,2] [,3] [,4]
## [1,] 0.0000000 0.5611551 0.6516913 0.5238001
## [2,] 0.5611551 0.0000000 0.4840711 0.4724527
## [3,] 0.6516913 0.4840711 0.0000000 0.6080682
## [4,] 0.5238001 0.4724527 0.6080682 0.0000000
##
## $average.between
## [1] 0.5324179
##
## $average.within
## [1] 0.3430001
##
## $n.between
## [1] 1585389
##
## $n.within
## [1] 641716
##
## $max.diameter
## [1] 0.9920213
##
## $min.separation
## [1] 0.007978723
##
## $within.cluster.ss
## [1] 159.4532
##
## $clus.avg.silwidths
## 1 2 3 4
## -0.07418574 0.20657420 0.23387155 0.64441072
##
## $avg.silwidth
## [1] 0.2506477
##
## $g2
## NULL
##
## $g3
## NULL
##
## $pearsongamma
## [1] 0.5032102
##
## $dunn
## [1] 0.008042895
##
## $dunn2
## [1] 0.8979127
##
## $entropy
## [1] 1.317327
##
## $wb.ratio
## [1] 0.6442309
##
## $ch
## [1] 494.3193
##
## $cwidegap
## [1] 0.3829787 0.1303191 0.2606383 0.1303191
##
## $widestgap
## [1] 0.3829787
##
## $sindex
## [1] 0.1104039
##
## $corrected.rand
## NULL
##
## $vi
## NULLCorrimos este modelo de clustering primero con 3, 8 y 5 clusters, sin embargo, con la intención de no saturar el cuaderno y ser repetitivos, dejamos aquí unicamente el de 4 clusters pues tras realizar nuestro elbow chart descubrimos que después de 4 clusters la mejoría era poco significativa y que en 8 clusters el modelo empezaba a sobreajustar.
El tamaño de cada cluster es de 605, 263, 811, y 432, respectivamente. El diámetro o distancia máxima entre dos puntos dentro de un cluster varía para cada cluster entre 0.60 y 0.88. La distancia promedio entre todos los pares de puntos en de cada cluster varía entre 0.23 y 0.46.
clusplot(t_buena, kmeans_result$cluster, color=T, shade=T, labels=0, lines=0, main="CLUSTERING K-means")
Estos componentes explican únicamente el 41.44 % de la variabilidad. Ligeramente menor que el de k prototipos. Esto puede significar que el modelo no representa a los datos con tanta consistencia.
Visualizaremos algunas matrices para ver como se agrupan algunas variables en cada uno de los 4 clusters
# Visualizamos Genero
table(kmeans_result$cluster,t_buena$Gender)##
## Female Male
## 1 268 113
## 2 230 655
## 3 114 300
## 4 431 0# Visualizamos Nivel de obesidad
table(kmeans_result$cluster,t_buena$NObeyesdad)##
## Insufficient_Weight Normal_Weight Obesity_Type_I Obesity_Type_II
## 1 127 148 21 2
## 2 67 92 200 197
## 3 41 29 110 97
## 4 37 18 20 1
##
## Obesity_Type_III Overweight_Level_I Overweight_Level_II
## 1 2 45 36
## 2 0 161 168
## 3 0 57 80
## 4 322 27 6# Visualizamos frecuencia en consumo de vegetales
table(kmeans_result$cluster,t_buena$FCVC)##
## 1 2 3
## 1 65 137 179
## 2 76 753 56
## 3 27 367 20
## 4 34 0 397Visualizamos con un scatterplot el cluster contemplando Edad y Frecuencia de actividad física
# Agregamos la asignación de cluster al dataset original
t_buena$Cluster = as.factor(kmeans_result$cluster)
# Creamos un scatterplot
ggplot(t_buena, aes(x = Age, y = FAF, color = Cluster)) +
geom_point() +
ggtitle("Clustering Scatterplot") +
xlab("Age") +
ylab("FAF") +
theme_minimal()
Aquí podemos percibir algunos agrupamientos interesantes, por ejemplo el
cluster 1 nos dice que las personas que hacen ejercicio de 0 a 2 días
por semana se concentran más bien en el rango de edad de 15 a 25 años.
El cluster 3 agrupa a personas de 25 a 35 años que hacen ejercicio de 0
a 4 días y en este mismo cluster se cuelan también algunos de edades
menores. Los clusters 2 y 4 parecen estar menos agrupados o ser menos
consistentes.
Realizamos un Elbow Chart
# Nos arrojaba un error sobre presencia de nulos, así que los eliminamos aquí
t_buena_sin_na = na.omit(t_buena[, 1:8])
# Calcular la matriz de distancia de Gower
distancia_gower = daisy(t_buena_sin_na, metric = "gower")
# Inicializamos un vector para almacenar el la suma total de cuadrados
tot.withinss = numeric(10)
# Hacemos iteraciones sobre 10 clusters
for (i in 1:10) {
# Intentaremos realizar k-means
try({
kmeans_result = kmeans(distancia_gower, centers = i, nstart = 20)
tot.withinss[i] = kmeans_result$tot.withinss
}, silent = TRUE)
}
# Graficamos el Elbow Chart
plot(1:10, tot.withinss, type = "b", pch = 19, main = "ELBOW Chart", xlab = "Número de Clusters", ylab = "Total suma de cuadrados")
Este Elbow chart es bastante interesante, pues además de mostrar que no hay gran mejora en el rango de 4 a 7 clusters de pronto tiene un desenso repentino hasta 8 clusters, esto parece indicar que a partir de 8 clusters el modelo deja de funcionar y sobreajusta.
Hacemos un dendograma para graficar clustering por gerarquias
dendobes = hclust(
dist(t_buena[,1:9], method="euclidian"),
method="complete"
)## Warning in dist(t_buena[, 1:9], method = "euclidian"): NAs introduced by
## coercionplot(dendobes, hang = -5, cex = 0.7, main ="DENDOGRAMA")
Es este dendograma hacemos un clusterin por gerarquias y podemos
observar que si pasáramos una horizontal aproximadamente por el 25 o 30
obtendríamos los 4 grupos o clusters de nuestro modelo de k-means. Se ve
algo apretado sin embargo intentamos con distintos métodos y “complete”
era el que mas separado quedaba.
En conclusión, los clusters que obtuvimos no están muy bien definidos o delimitados y existe mucho solapamiento de datos, tal vez reduciendo el número de variables o haciendo una reducción de dimensionalidad (la cual intentaos hacer pero nos topamos con el inconveniente de que casi todas nuestras variables son categóricas y eso dificulta el prosedimiento, motivo por el cual desistimos de la odisea) podríamos obtener algunos clusters mejor definidos y explicados por sus variables.