
Teoría
Agrupamiento o clustering es una técnica de
aprendizaje automático no supervisado que agrupa datos en función de su
similitud.
Algunos usos típicos de esta técnica son:
- Segmentación de clientes
- Detección de anormalidades
- Categorización de documentos
Paso 1.Instalar paquetes y llamar
librerías
#install.packages("cluster") #Análisis de agrupamiento
library(cluster)
#install.packages("ggplot2") #Graficar
library(ggplot2)
#install.packages("data.table") #Manejo de muchos datos
library(data.table)
#install.packages("factoextra") #Gráfica de optimización de númeor de clústers
library(factoextra)
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa
Paso 2.Obtener los datos
df1 <- data.frame(x=c(2,2,8,5,7,6,1,4), y=c(10,5,4,8,5,4,2,9))
Paso 3.Entender los datos
summary(df1) #Da min,max,mean chr no da nada
## x y
## Min. :1.000 Min. : 2.000
## 1st Qu.:2.000 1st Qu.: 4.000
## Median :4.500 Median : 5.000
## Mean :4.375 Mean : 5.875
## 3rd Qu.:6.250 3rd Qu.: 8.250
## Max. :8.000 Max. :10.000
str(df1) #Da structura, si es numerico o chr
## 'data.frame': 8 obs. of 2 variables:
## $ x: num 2 2 8 5 7 6 1 4
## $ y: num 10 5 4 8 5 4 2 9
Paso 4.Escalar los datos
#Solo si los datos no están en la misma escala.
#No se ocupara por el momento pero es el código.
#datos_escalados <- scale(datos_originales)
#Escala cercanos a 0 y a 1 para hacer clusters
Paso 5.Determinar número de grupos
#Siempre es un valor inicial "cualquiera", luego se optimiza.
plot(df1$x,df1$y) #El $ es para especificar una columna

grupos1 <- 3 #Los que consideremos después de ver el visual
Paso 6.Generar los grupos
set.seed(123) # Fijar semilla para que los números aleatorios sean reproducibles
clusters1 <- kmeans(df1,grupos1)
clusters1 #Para verificar el mismo numero debe de estar al principio, enmedio y al final de "clustering vector: "
## K-means clustering with 3 clusters of sizes 2, 3, 3
##
## Cluster means:
## x y
## 1 1.500000 3.500000
## 2 3.666667 9.000000
## 3 7.000000 4.333333
##
## Clustering vector:
## [1] 2 1 3 2 3 3 1 2
##
## Within cluster sum of squares by cluster:
## [1] 5.000000 6.666667 2.666667
## (between_SS / total_SS = 85.8 %)
##
## Available components:
##
## [1] "cluster" "centers" "totss" "withinss" "tot.withinss"
## [6] "betweenss" "size" "iter" "ifault"
Paso 7.Optimizar el número de grupos
#**No funcionó el código del profe**
# Calcular la función Gap Statistic para determinar el número óptimo de clusters
#optimizacion1 <- clusGap(df1, FUN = kmeans, nstart = 1, k.max = 7)
# Nota: k.max normalmente se fija en 10, pero en este ejercicio con 8 datos se dejó en 7
#plot(optimizacion1, xlab = "Número de clusters k", main= "Optimización de Clusters")
# El número óptimo de clusters se elige como el primer valor donde la brecha (Gap) es máxima
set.seed(123) # Para reproducibilidad
# Gap Statistic con kmeans
optimizacion1 <- clusGap(
df1,
FUN = function(x, k) kmeans(x, centers = k, nstart = 25),
K.max = 7,
B = 100 # número de simulaciones bootstrap (más alto = más preciso)
)
# Graficar resultados
plot(optimizacion1, xlab = "Número de clusters k", main = "Optimización de Clusters")

Paso 8.Graficar los grupos
fviz_cluster(clusters1, data=df1)

Paso 9.Agregar grupos a la Base de Datos
df1_clusters <- cbind(df1, cluster = clusters1$cluster) #Agrega la columna
head(df1_clusters)
## x y cluster
## 1 2 10 2
## 2 2 5 1
## 3 8 4 3
## 4 5 8 2
## 5 7 5 3
## 6 6 4 3
Paso 10.Conclusión
La técnica de clusetring permite identificar patrones o
grupos naturales en los datos sin necesidad de etiquetas previas.
LS0tDQp0aXRsZTogIkFncnVwYW1pZW50byAoQ2zDunN0ZXJzKSINCmF1dGhvcjogIkF0ZW5lYSBMb3BleiBDb3JvbmEgQTAxNzUwOTk5Ig0KZGF0ZTogIjIwMjUtMDgtMTgiDQpvdXRwdXQ6IA0KICBodG1sX2RvY3VtZW50Og0KICAgIHRvYzogVFJVRSAjVGFibGEgZGUgY29udGVuaWRvcw0KICAgIHRvY19mbG9hdDogVFJVRSAjVGJsYSBkZSBhbGdvDQogICAgY29kZV9kb3dubG9hZDogVFJVRSAjUG9kZXIgZGVzY2FyZ2FyIGPDs2RpZ28NCiAgICB0aGVtZTogeWV0aQ0KLS0tDQoNCiFbXShodHRwczovL2Rhc2hlZTg3LmdpdGh1Yi5pby9pbWFnZXMvbWVhbl9zaGlmdF90dXRvcmlhbC5naWYpDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+IFRlb3LDrWEgPC9zcGFuPiAgDQoqKkFncnVwYW1pZW50byoqIG8gKmNsdXN0ZXJpbmcqIGVzIHVuYSB0w6ljbmljYSBkZSBhcHJlbmRpemFqZSBhdXRvbcOhdGljbyBubyBzdXBlcnZpc2FkbyBxdWUgYWdydXBhIGRhdG9zIGVuIGZ1bmNpw7NuIGRlIHN1IHNpbWlsaXR1ZC4gIA0KDQpBbGd1bm9zIHVzb3MgdMOtcGljb3MgZGUgZXN0YSB0w6ljbmljYSBzb246DQoNCiogU2VnbWVudGFjacOzbiBkZSBjbGllbnRlcw0KKiBEZXRlY2Npw7NuIGRlIGFub3JtYWxpZGFkZXMNCiogQ2F0ZWdvcml6YWNpw7NuIGRlIGRvY3VtZW50b3MNCg0KIyA8c3BhbiBzdHlsZT0iY29sb3I6IGJsdWU7Ij4gUGFzbyAxLkluc3RhbGFyIHBhcXVldGVzIHkgbGxhbWFyIGxpYnJlcsOtYXMgPC9zcGFuPiAgDQpgYGB7ciBtZXNzYWdlPVRSVUUsIHdhcm5pbmc9VFJVRX0NCiNpbnN0YWxsLnBhY2thZ2VzKCJjbHVzdGVyIikgI0Fuw6FsaXNpcyBkZSBhZ3J1cGFtaWVudG8NCmxpYnJhcnkoY2x1c3RlcikNCiNpbnN0YWxsLnBhY2thZ2VzKCJnZ3Bsb3QyIikgI0dyYWZpY2FyDQpsaWJyYXJ5KGdncGxvdDIpDQojaW5zdGFsbC5wYWNrYWdlcygiZGF0YS50YWJsZSIpICNNYW5lam8gZGUgbXVjaG9zIGRhdG9zDQpsaWJyYXJ5KGRhdGEudGFibGUpDQojaW5zdGFsbC5wYWNrYWdlcygiZmFjdG9leHRyYSIpICNHcsOhZmljYSBkZSBvcHRpbWl6YWNpw7NuIGRlIG7Dum1lb3IgZGUgY2zDunN0ZXJzDQpsaWJyYXJ5KGZhY3RvZXh0cmEpDQpgYGANCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+IFBhc28gMi5PYnRlbmVyIGxvcyBkYXRvcyA8L3NwYW4+ICANCmBgYHtyfQ0KZGYxIDwtIGRhdGEuZnJhbWUoeD1jKDIsMiw4LDUsNyw2LDEsNCksIHk9YygxMCw1LDQsOCw1LDQsMiw5KSkNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjogYmx1ZTsiPiBQYXNvIDMuRW50ZW5kZXIgbG9zIGRhdG9zIDwvc3Bhbj4NCmBgYHtyfQ0Kc3VtbWFyeShkZjEpICNEYSBtaW4sbWF4LG1lYW4gY2hyIG5vIGRhIG5hZGENCnN0cihkZjEpICNEYSBzdHJ1Y3R1cmEsIHNpIGVzIG51bWVyaWNvIG8gY2hyDQpgYGANCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+IFBhc28gNC5Fc2NhbGFyIGxvcyBkYXRvcyA8L3NwYW4+DQpgYGB7cn0NCiNTb2xvIHNpIGxvcyBkYXRvcyBubyBlc3TDoW4gZW4gbGEgbWlzbWEgZXNjYWxhLg0KI05vIHNlIG9jdXBhcmEgcG9yIGVsIG1vbWVudG8gcGVybyBlcyBlbCBjw7NkaWdvLg0KI2RhdG9zX2VzY2FsYWRvcyA8LSBzY2FsZShkYXRvc19vcmlnaW5hbGVzKSANCiNFc2NhbGEgY2VyY2Fub3MgYSAwIHkgYSAxIHBhcmEgaGFjZXIgY2x1c3RlcnMNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjogYmx1ZTsiPiBQYXNvIDUuRGV0ZXJtaW5hciBuw7ptZXJvIGRlIGdydXBvcyA8L3NwYW4+DQpgYGB7cn0NCiNTaWVtcHJlIGVzIHVuIHZhbG9yIGluaWNpYWwgImN1YWxxdWllcmEiLCBsdWVnbyBzZSBvcHRpbWl6YS4NCnBsb3QoZGYxJHgsZGYxJHkpICNFbCAkIGVzIHBhcmEgZXNwZWNpZmljYXIgdW5hIGNvbHVtbmENCmdydXBvczEgPC0gMyAjTG9zIHF1ZSBjb25zaWRlcmVtb3MgZGVzcHXDqXMgZGUgdmVyIGVsIHZpc3VhbA0KDQpgYGANCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+IFBhc28gNi5HZW5lcmFyIGxvcyBncnVwb3MgPC9zcGFuPg0KDQpgYGB7cn0NCnNldC5zZWVkKDEyMykgICMgRmlqYXIgc2VtaWxsYSBwYXJhIHF1ZSBsb3MgbsO6bWVyb3MgYWxlYXRvcmlvcyBzZWFuIHJlcHJvZHVjaWJsZXMNCg0KY2x1c3RlcnMxIDwtIGttZWFucyhkZjEsZ3J1cG9zMSkNCmNsdXN0ZXJzMSAjUGFyYSB2ZXJpZmljYXIgZWwgbWlzbW8gbnVtZXJvIGRlYmUgZGUgZXN0YXIgYWwgcHJpbmNpcGlvLCBlbm1lZGlvIHkgYWwgZmluYWwgZGUgImNsdXN0ZXJpbmcgdmVjdG9yOiAiDQpgYGANCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+IFBhc28gNy5PcHRpbWl6YXIgZWwgbsO6bWVybyBkZSBncnVwb3MgPC9zcGFuPg0KDQpgYGB7cn0NCiMqKk5vIGZ1bmNpb27DsyBlbCBjw7NkaWdvIGRlbCBwcm9mZSoqDQojIENhbGN1bGFyIGxhIGZ1bmNpw7NuIEdhcCBTdGF0aXN0aWMgcGFyYSBkZXRlcm1pbmFyIGVsIG7Dum1lcm8gw7NwdGltbyBkZSBjbHVzdGVycw0KI29wdGltaXphY2lvbjEgPC0gY2x1c0dhcChkZjEsIEZVTiA9IGttZWFucywgbnN0YXJ0ID0gMSwgay5tYXggPSA3KQ0KDQojIE5vdGE6IGsubWF4IG5vcm1hbG1lbnRlIHNlIGZpamEgZW4gMTAsIHBlcm8gZW4gZXN0ZSBlamVyY2ljaW8gY29uIDggZGF0b3Mgc2UgZGVqw7MgZW4gNw0KI3Bsb3Qob3B0aW1pemFjaW9uMSwgeGxhYiA9ICJOw7ptZXJvIGRlIGNsdXN0ZXJzIGsiLCBtYWluPSAiT3B0aW1pemFjacOzbiBkZSBDbHVzdGVycyIpDQoNCiMgRWwgbsO6bWVybyDDs3B0aW1vIGRlIGNsdXN0ZXJzIHNlIGVsaWdlIGNvbW8gZWwgcHJpbWVyIHZhbG9yIGRvbmRlIGxhIGJyZWNoYSAoR2FwKSBlcyBtw6F4aW1hDQoNCmBgYA0KDQpgYGB7cn0NCnNldC5zZWVkKDEyMykgICMgUGFyYSByZXByb2R1Y2liaWxpZGFkDQoNCiMgR2FwIFN0YXRpc3RpYyBjb24ga21lYW5zDQpvcHRpbWl6YWNpb24xIDwtIGNsdXNHYXAoDQogIGRmMSwNCiAgRlVOID0gZnVuY3Rpb24oeCwgaykga21lYW5zKHgsIGNlbnRlcnMgPSBrLCBuc3RhcnQgPSAyNSksIA0KICBLLm1heCA9IDcsDQogIEIgPSAxMDAgICAjIG7Dum1lcm8gZGUgc2ltdWxhY2lvbmVzIGJvb3RzdHJhcCAobcOhcyBhbHRvID0gbcOhcyBwcmVjaXNvKQ0KKQ0KDQojIEdyYWZpY2FyIHJlc3VsdGFkb3MNCnBsb3Qob3B0aW1pemFjaW9uMSwgeGxhYiA9ICJOw7ptZXJvIGRlIGNsdXN0ZXJzIGsiLCBtYWluID0gIk9wdGltaXphY2nDs24gZGUgQ2x1c3RlcnMiKQ0KDQpgYGANCg0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjogYmx1ZTsiPiBQYXNvIDguR3JhZmljYXIgbG9zIGdydXBvcyA8L3NwYW4+DQpgYGB7cn0NCmZ2aXpfY2x1c3RlcihjbHVzdGVyczEsIGRhdGE9ZGYxKQ0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+IFBhc28gOS5BZ3JlZ2FyIGdydXBvcyBhIGxhIEJhc2UgZGUgRGF0b3MgPC9zcGFuPg0KYGBge3J9DQpkZjFfY2x1c3RlcnMgPC0gY2JpbmQoZGYxLCBjbHVzdGVyID0gY2x1c3RlcnMxJGNsdXN0ZXIpICNBZ3JlZ2EgbGEgY29sdW1uYQ0KaGVhZChkZjFfY2x1c3RlcnMpDQpgYGANCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibHVlOyI+IFBhc28gMTAuQ29uY2x1c2nDs24gPC9zcGFuPg0KTGEgdMOpY25pY2EgZGUgKmNsdXNldHJpbmcqIHBlcm1pdGUgaWRlbnRpZmljYXIgcGF0cm9uZXMgbyBncnVwb3MgbmF0dXJhbGVzIGVuIGxvcyBkYXRvcyBzaW4gbmVjZXNpZGFkIGRlIGV0aXF1ZXRhcyBwcmV2aWFzLg0KDQoNCg==