Carlos Felipe Belloso Castillo
2025-11-28
UNIVERSIDAD DE EL SALVADOR
FACULTAD DE CIENCIAS ECONÓMICAS
ESCUELA DE ECONOMÍA
Aplicación: Analisis de Cluster (Conglomerados)
Asignatura: Metodos para el Analisis Económico
Docente: Carlos Ademir Perez Alas
Karla Lizeth Sandoval Garcia - SG22017
Ricardo Jose Mendez Lopez -
ML21027
Carlos Felipe Belloso Castillo - BC23009
Grupo: GT02
Carga de datos
datos <- data.frame(
Comunidad = c("España", "Andalucía", "Aragón", "Asturias", "Baleares", "Canarias", "Cantabria", "Castilla y León", "Cast.-La Mancha", "Cataluña", "Com. Valenciana", "Extremadura", "Galicia", "Madrid", "Murcia", "Navarra", "País Vasco", "Rioja"),
Automovil = c(69.0, 66.7, 67.2, 63.7, 71.9,
72.7, 63.4, 65.8, 61.5,
70.4, 72.7, 60.5, 65.5,
74.0, 69.0, 76.4, 71.3, 64.9),
TV_color = c(97.6, 98.0, 97.5, 95.2, 98.8,
96.8, 94.9, 97.1, 97.3,
98.1, 98.4, 97.7, 91.3,
99.4, 98.7, 99.3, 98.3, 98.6),
Video = c(62.4, 82.7, 56.8, 52.1, 62.4,
68.4, 48.9, 47.7, 53.6,
71.1, 68.2, 43.7, 42.7,
76.3, 59.3, 60.6, 61.6, 54.4),
Microondas = c(32.3, 24.1, 43.4, 24.4, 29.8,
27.9, 36.5, 28.1, 21.7,
36.8, 26.6, 20.7, 13.5,
53.9, 19.5, 44.0, 45.7, 44.4),
Lavavajillas =c(17.0, 12.7, 20.6, 13.3, 10.1,
5.80, 11.2, 14.0, 7.10,
19.8, 12.1, 11.7, 14.6,
32.3, 12.1, 20.6, 23.7, 17.6),
Telefono = c(85.2, 74.7, 88.4, 88.1, 87.9,
75.4, 80.5, 85.0, 72.9,
92.2, 84.4, 67.1, 85.9,
95.7, 81.4, 87.4, 94.3, 83.4))
print(datos)## Comunidad Automovil TV_color Video Microondas Lavavajillas Telefono
## 1 España 69.0 97.6 62.4 32.3 17.0 85.2
## 2 Andalucía 66.7 98.0 82.7 24.1 12.7 74.7
## 3 Aragón 67.2 97.5 56.8 43.4 20.6 88.4
## 4 Asturias 63.7 95.2 52.1 24.4 13.3 88.1
## 5 Baleares 71.9 98.8 62.4 29.8 10.1 87.9
## 6 Canarias 72.7 96.8 68.4 27.9 5.8 75.4
## 7 Cantabria 63.4 94.9 48.9 36.5 11.2 80.5
## 8 Castilla y León 65.8 97.1 47.7 28.1 14.0 85.0
## 9 Cast.-La Mancha 61.5 97.3 53.6 21.7 7.1 72.9
## 10 Cataluña 70.4 98.1 71.1 36.8 19.8 92.2
## 11 Com. Valenciana 72.7 98.4 68.2 26.6 12.1 84.4
## 12 Extremadura 60.5 97.7 43.7 20.7 11.7 67.1
## 13 Galicia 65.5 91.3 42.7 13.5 14.6 85.9
## 14 Madrid 74.0 99.4 76.3 53.9 32.3 95.7
## 15 Murcia 69.0 98.7 59.3 19.5 12.1 81.4
## 16 Navarra 76.4 99.3 60.6 44.0 20.6 87.4
## 17 País Vasco 71.3 98.3 61.6 45.7 23.7 94.3
## 18 Rioja 64.9 98.6 54.4 44.4 17.6 83.4Cálculo de Distancias de Mahalanobis y P-values
library(dplyr)##
## Adjuntando el paquete: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union# Seleccionamos solo las columnas numéricas automáticamente
datos_num <- datos %>% select(where(is.numeric))
# Calculamos la distancia (usa las medias y covarianza de los datos seleccionados)
d2 <- mahalanobis(datos_num, colMeans(datos_num), cov(datos_num), inverted = FALSE)
# Calculamos P-valores (grados de libertad = número de columnas numéricas)
p_values <- pchisq(d2, df = ncol(datos_num), lower.tail = FALSE)
# Crear Data Frame de Resultados
resultados <- data.frame(
Comunidad = datos$Comunidad,
D2_Mahalanobis = round(d2, digits = 2),
P_Value = round(p_values, digits = 2)
)
# Visualizar Tabla
resultados %>%
mutate(Es_Atipico = ifelse(P_Value < 0.05, "Si", "No"))## Comunidad D2_Mahalanobis P_Value Es_Atipico
## 1 España 0.20 1.00 No
## 2 Andalucía 10.52 0.10 No
## 3 Aragón 1.91 0.93 No
## 4 Asturias 4.46 0.61 No
## 5 Baleares 5.70 0.46 No
## 6 Canarias 9.58 0.14 No
## 7 Cantabria 7.29 0.29 No
## 8 Castilla y León 2.21 0.90 No
## 9 Cast.-La Mancha 3.54 0.74 No
## 10 Cataluña 2.95 0.82 No
## 11 Com. Valenciana 2.65 0.85 No
## 12 Extremadura 10.43 0.11 No
## 13 Galicia 13.24 0.04 Si
## 14 Madrid 8.31 0.22 No
## 15 Murcia 4.88 0.56 No
## 16 Navarra 7.65 0.26 No
## 17 País Vasco 2.32 0.89 No
## 18 Rioja 4.17 0.65 NoEn este caso no se considera ninguna comunidad autónoma como un valor atípico
Metodos jerarquicos
# Calcular la matriz de distancias euclidianas entre las observaciones
# Basado en las columnas seleccionadas relacionadas con posesiones
matriz_eucliana <- dist(datos[, c("Automovil", "TV_color", "Video", "Microondas", "Lavavajillas", "Telefono")], method = "euclidean", diag = TRUE)
# Realizar el agrupamiento jerárquico utilizando el método de Ward.D2
hclust_ward <- hclust(matriz_eucliana, method = "ward.D2")
# Graficar el dendrograma para el método Ward.D2
# Las etiquetas corresponden a la columna "comunidad" del data frame original
plot(hclust_ward, labels = datos$Comunidad)
# Realizar el agrupamiento jerárquico utilizando el método de promedio (average linkage)
hclust.average <- hclust(matriz_eucliana, method = "average")
# Graficar el dendrograma para el método promedio
plot(hclust.average, labels = datos$Comunidad)
hclust.complete <- hclust(matriz_eucliana, method = "complete")
# Graficar el dendrograma para el método completo
plot(hclust.complete, labels = datos$Comunidad)
# Realizar el agrupamiento jerárquico utilizando el método de enlace simple (single linkage)
hclust.simple <- hclust(matriz_eucliana, method = "single")
# Graficar el dendrograma para el método de enlace simple
plot(hclust.simple, labels = datos$Comunidad)
# Realizar el agrupamiento jerárquico utilizando el método de centroide
hclust.centroide <- hclust(matriz_eucliana, method = "centroid")
# Graficar el dendrograma para el método de centroide
plot(hclust.centroide, labels = datos$Comunidad)
library(NbClust)
# Seleccionar las columnas relevantes del data frame para el análisis de agrupamiento
Datos.nbclust <- datos[, c("Automovil", "TV_color", "Video", "Microondas", "Lavavajillas", "Telefono")]
# Aplicar el método NbClust para determinar el número óptimo de clústeres
# Se utiliza la distancia euclidiana para calcular las distancias
# El número de clústeres evaluados varía entre 2 y 15
# El método de agrupamiento utilizado es Ward.D2
# El índice "alllong" evalúa múltiples criterios para determinar la calidad del agrupamiento
res.wardD2 <- NbClust(Datos.nbclust, distance = "euclidean",
min.nc = 2, max.nc = 15,
method = "ward.D2", index = "alllong")
## *** : The Hubert index is a graphical method of determining the number of clusters.
## In the plot of Hubert index, we seek a significant knee that corresponds to a
## significant increase of the value of the measure i.e the significant peak in Hubert
## index second differences plot.
## 
## *** : The D index is a graphical method of determining the number of clusters.
## In the plot of D index, we seek a significant knee (the significant peak in Dindex
## second differences plot) that corresponds to a significant increase of the value of
## the measure.
##
## *******************************************************************
## * Among all indices:
## * 6 proposed 2 as the best number of clusters
## * 9 proposed 3 as the best number of clusters
## * 2 proposed 4 as the best number of clusters
## * 1 proposed 7 as the best number of clusters
## * 1 proposed 13 as the best number of clusters
## * 8 proposed 15 as the best number of clusters
##
## ***** Conclusion *****
##
## * According to the majority rule, the best number of clusters is 3
##
##
## *******************************************************************# Dividiendo las observaciones en 2 grupos usando el dendrograma Ward.D2
# `hclust_ward` contiene el agrupamiento jerárquico basado en el método Ward.D2
# `k = 2` indica que se deben formar 2 grupos
# `h = NULL` indica que no se especifica un nivel de corte basado en la altura
grupo.ward <- cutree(hclust_ward, k = 2, h = NULL)
# Combinar la información del agrupamiento con los datos originales
# Se añade la variable `grupo.ward` al data frame original `Datos_3_3_Caso`
datos_grupos <- cbind(datos, grupo.ward)
# Eliminar la columna `Comunidad.` del nuevo data frame, ya que no es relevante para este análisis
datos$Comunidad <- NULL
# Calcular el promedio de cada variable en los grupos formados
# `aggregate()` agrupa los datos según la variable `grupo.ward` y calcula la media
# `round()` redondea los resultados a 2 decimales
round(aggregate(datos_grupos, list(grupo.ward), mean), 2) -> datos_caso3## Warning in mean.default(X[[i]], ...): argument is not numeric or logical:
## returning NA
## Warning in mean.default(X[[i]], ...): argument is not numeric or logical:
## returning NA# Mostrar el data frame resultante con los promedios de cada grupo
print(datos_caso3)## Group.1 Comunidad Automovil TV_color Video Microondas Lavavajillas Telefono
## 1 1 NA 66.87 96.82 57.68 25.42 11.81 80.71
## 2 2 NA 70.70 98.53 63.47 44.70 22.43 90.23
## grupo.ward
## 1 1
## 2 2# 2. PREPARACIÓN DE LA VARIABLE 'datos_kmeans'
# Quitamos la primera columna (Comunidad)
datos_numericos <- datos [, -1]
# IMPORTANTE: Seleccionamos solo las primeras 5 columnas numéricas
# para que coincidan con tus centros c1 y c2 (que tienen 5 valores).
datos_kmeans <- datos_numericos[, 1:5]
# 3. DEFINICIÓN DE CENTROS
c1 <- c(66.87, 96.82, 56.01, 25.43, 11.81)
c2 <- c(70.70, 98.53, 63.47, 44.70, 22.43)
# 4. EJECUCIÓN DEL MODELO
set.seed(123)
solucion <- kmeans(datos_kmeans, centers = rbind(c1, c2))
# 5. RESULTADO
print(solucion)## K-means clustering with 2 clusters of sizes 12, 6
##
## Cluster means:
## TV_color Video Microondas Lavavajillas Telefono
## 1 96.81667 57.67500 25.425 11.80833 80.70833
## 2 98.53333 63.46667 44.700 22.43333 90.23333
##
## Clustering vector:
## [1] 1 1 2 1 1 1 1 1 1 2 1 1 1 2 1 2 2 2
##
## Within cluster sum of squares by cluster:
## [1] 2613.7400 758.6333
## (between_SS / total_SS = 42.0 %)
##
## Available components:
##
## [1] "cluster" "centers" "totss" "withinss" "tot.withinss"
## [6] "betweenss" "size" "iter" "ifault"3. Métodos no jerarquicos.
Datos.NbClust <- datos[, c("Automovil", "TV_color", "Video", "Microondas", "Lavavajillas", "Telefono")]
# Realizar agrupamiento jerárquico utilizando el método Ward.D2
hclust.ward.caso3 <- hclust(matriz_eucliana, method = "ward.D2")
# Graficar el dendrograma resultante del agrupamiento jerárquico
plot(hclust.complete, labels = datos$Comunidad)
# Dividir laaqobservaciones en 2 grupos basándose en el dendrograma
groups <- cutree(hclust.complete, k = 2)
# Dibujar rectángulos en el dendrograma alrededor de los dos grupos formados
# `rect.hclust()` destaca visualmente los clústeres en el dendrograma
# `k = 2` indica que se deben dibujar rectángulos alrededor de 2 grupos
# `border = "red"` especifica que los rectángulos deben tener un borde rojo
rect.hclust(hclust.complete, k = 2, border = "green")
DatosCaso3.1b <- datos
DatosCaso3.1b <- na.omit(DatosCaso3.1b)
DatosCaso3.1b <- DatosCaso3.1b[, sapply(DatosCaso3.1b, is.numeric)]
kmeans.caso3.1 <- kmeans(DatosCaso3.1b, 2)
aggregate(DatosCaso3.1b, by = list(kmeans.caso3.1$cluster), FUN = mean)## Group.1 Automovil TV_color Video Microondas Lavavajillas Telefono
## 1 1 66.86667 96.81667 57.67500 25.425 11.80833 80.70833
## 2 2 70.70000 98.53333 63.46667 44.700 22.43333 90.23333DatosCaso3.1b <- cbind(DatosCaso3.1b, Cluster = kmeans.caso3.1$cluster)
library(psych)
DatosCaso3.1b <- data.frame(DatosCaso3.1b, kmeans.caso3.1$cluster)
kmeans.caso3.1.cluster <- kmeans.caso3.1$cluster
t.test(Automovil ~ kmeans.caso3.1.cluster, data = DatosCaso3.1b)##
## Welch Two Sample t-test
##
## data: Automovil by kmeans.caso3.1.cluster
## t = -1.8106, df = 10.091, p-value = 0.1
## alternative hypothesis: true difference in means between group 1 and group 2 is not equal to 0
## 95 percent confidence interval:
## -8.5449256 0.8782589
## sample estimates:
## mean in group 1 mean in group 2
## 66.86667 70.70000library(dplyr)
library(kableExtra)
solucion.cluster<-solucion$cluster
# Calcular las pruebas t
t1 <- t.test(Automovil ~ solucion.cluster, data = Datos.NbClust)
t2 <- t.test(TV_color ~ solucion.cluster, data = Datos.NbClust)
t3 <- t.test(Video ~ solucion.cluster, data = Datos.NbClust)
t4 <- t.test(Microondas ~ solucion.cluster, data = Datos.NbClust)
t5 <- t.test(Lavavajillas ~ solucion.cluster, data = Datos.NbClust)
t6 <- t.test(Telefono ~ solucion.cluster, data = Datos.NbClust)
# Crear un dataframe con los resultados de las pruebas t
resultados.ttest <- data.frame(
Variable = c("Automovil", "TVcolor", "Video", "Microondas", "Lavavajillas", "Telefono"),
Grupo_1 = c(t1$estimate[1], t2$estimate[1], t3$estimate[1], t4$estimate[1], t5$estimate[1], t6$estimate[1]),
Grupo_2 = c(t1$estimate[2], t2$estimate[2], t3$estimate[2], t4$estimate[2], t5$estimate[2], t6$estimate[2]),
# Aplica la función abs() para asegurarte de que las estadísticas t sean siempre positivas
Pruebas_t = c(abs(t1$statistic), abs(t2$statistic), abs(t3$statistic), abs(t4$statistic), abs(t5$statistic), abs(t6$statistic))
)
# Mostrar los resultados con kable
head(resultados.ttest) %>%
kable(caption = "Significatividad de las diferencias entre los perfiles de los conglomerados",
align = "c", digits = 2) %>%
kable_classic(html_font = "Times New Roman", font_size = 14) %>%
kable_styling()| Variable | Grupo_1 | Grupo_2 | Pruebas_t |
|---|---|---|---|
| Automovil | 66.87 | 70.70 | 1.81 |
| TVcolor | 96.82 | 98.53 | 2.52 |
| Video | 57.68 | 63.47 | 1.19 |
| Microondas | 25.42 | 44.70 | 6.73 |
| Lavavajillas | 11.81 | 22.43 | 4.61 |
| Telefono | 80.71 | 90.23 | 3.51 |