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
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 del número de clusters
library(factoextra)
# install.packages("datasets")
library(datasets)
# install.packages("tidyverse")
library(tidyverse)
Ejercicio 1. Puntos
Contexto
Agrupa los siguientes 8 puntos.
Obtener datos
df1 <- data.frame(x=c(2,2,8,5,7,6,1,4), y=c(10,5,4,8,5,4,2,9))
Entender datos
summary(df1)
## 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)
## '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
plot(df1$x,df1$y)

Escalar datos
# datos_escalados <- scale(datos_originales)
Asignar número de grupos
grupos1 <- 3
Agrupar los puntos
set.seed(123)
clusters1 <- kmeans(df1,grupos1)
clusters1
## 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"
Optimizar número de grupos
set.seed(123)
optimizacion1 <- clusGap(df1, FUN=kmeans, nstart=1, K.max=7)
# El K.max normalmente es 10, en este ejercicio al ser 8 datos se dejó en 7.
plot(optimizacion1, xlab="Número de clusters k", main="Optimización de Clusters")

# Se selecciona como óptimo el primer punto más alto.
# Si es diferente al original, regresar y ajustar.
Graficar los grupos
fviz_cluster(clusters1,data=df1)

Agregar grupos a la base de datos
df1_clusters <- cbind(df1, cluster = clusters1$cluster)
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
Conclusiones
La técnica de clustering permite identificar patrones o
grupos naturales en los datos sin necesidad de etiquetas previas.
Ejercicio 2. USArrests
Contexto
La base de datos USArrests contiene estadísticas en
arrestos por cada 100,000 residentes por agresión, asesinato y violación
en cada uno de los 50 estados de EE.UU. en 1973.
Obtener datos
df2 <- USArrests
df2 <- df2 %>% select(-UrbanPop)
Entender datos
summary(df2)
## Murder Assault Rape
## Min. : 0.800 Min. : 45.0 Min. : 7.30
## 1st Qu.: 4.075 1st Qu.:109.0 1st Qu.:15.07
## Median : 7.250 Median :159.0 Median :20.10
## Mean : 7.788 Mean :170.8 Mean :21.23
## 3rd Qu.:11.250 3rd Qu.:249.0 3rd Qu.:26.18
## Max. :17.400 Max. :337.0 Max. :46.00
str(df2)
## 'data.frame': 50 obs. of 3 variables:
## $ Murder : num 13.2 10 8.1 8.8 9 7.9 3.3 5.9 15.4 17.4 ...
## $ Assault: int 236 263 294 190 276 204 110 238 335 211 ...
## $ Rape : num 21.2 44.5 31 19.5 40.6 38.7 11.1 15.8 31.9 25.8 ...
Escalar datos
df2_escalados <- scale(df2)
summary(df2_escalados)
## Murder Assault Rape
## Min. :-1.6044 Min. :-1.5090 Min. :-1.4874
## 1st Qu.:-0.8525 1st Qu.:-0.7411 1st Qu.:-0.6574
## Median :-0.1235 Median :-0.1411 Median :-0.1209
## Mean : 0.0000 Mean : 0.0000 Mean : 0.0000
## 3rd Qu.: 0.7949 3rd Qu.: 0.9388 3rd Qu.: 0.5277
## Max. : 2.2069 Max. : 1.9948 Max. : 2.6444
Asignar número de grupos
grupos2 <- 5
Agrupar los puntos
set.seed(123)
clusters2 <- kmeans(df2_escalados,grupos2)
Optimizar número de grupos
set.seed(123)
optimizacion2 <- clusGap(df2_escalados, FUN=kmeans, nstart=1, K.max=10)
plot(optimizacion2, xlab="Número de clusters k", main="Optimización de Clusters")

# Se selecciona como óptimo el primer punto más alto.
# Si es diferente al original, regresar y ajustar.
Graficar los grupos
fviz_cluster(clusters2,data=df2_escalados)

Agregar grupos a la base de datos
df2_clusters <- cbind(df2, cluster = clusters2$cluster)
head(df2_clusters)
## Murder Assault Rape cluster
## Alabama 13.2 236 21.2 5
## Alaska 10.0 263 44.5 4
## Arizona 8.1 294 31.0 1
## Arkansas 8.8 190 19.5 3
## California 9.0 276 40.6 4
## Colorado 7.9 204 38.7 4
df2_clusters %>% group_by(cluster) %>% summarise_all(mean) %>% mutate(indicador_inseguridad=Murder+Assault+Rape)
## # A tibble: 5 × 5
## cluster Murder Assault Rape indicador_inseguridad
## <int> <dbl> <dbl> <dbl> <dbl>
## 1 1 11.4 282. 29.7 323.
## 2 2 3.08 80.9 11.8 95.8
## 3 3 6.59 146. 20.1 172.
## 4 4 9.78 249. 42.4 301.
## 5 5 14.4 245 22.2 282.
df2_clusters <- df2_clusters %>%
mutate(cluster= case_when(
cluster == 1 ~ "Inseguridad Muy Alta",
cluster == 4 ~ "Inseguridad Alta",
cluster == 5 ~ "Inseguridad Media",
cluster == 3 ~ "Inseguridad Baja",
cluster == 2 ~ "Inseguridad Muy Baja"
))
head(df2_clusters)
## Murder Assault Rape cluster
## Alabama 13.2 236 21.2 Inseguridad Media
## Alaska 10.0 263 44.5 Inseguridad Alta
## Arizona 8.1 294 31.0 Inseguridad Muy Alta
## Arkansas 8.8 190 19.5 Inseguridad Baja
## California 9.0 276 40.6 Inseguridad Alta
## Colorado 7.9 204 38.7 Inseguridad Alta
Conclusiones
La técnica de clustering permite identificar patrones o
grupos naturales en los datos sin necesidad de etiquetas previas.
LS0tDQp0aXRsZTogIkNsdXN0ZXJzIC0gUHVudG9zLCBVU0FycmVzdHMgeSBDbGllbnRlcyINCmF1dGhvcjogIlJhdWwgQ2FudHUgQTAxMDg3NjgzIg0KZGF0ZTogIjIwMjYtMDgtMjUiDQpvdXRwdXQ6IA0KICBodG1sX2RvY3VtZW50Og0KICAgIHRvYzogVFJVRQ0KICAgIHRvY19mbG9hdDogVFJVRQ0KICAgIGNvZGVfZG93bmxvYWQ6IFRSVUUNCiAgICB0aGVtZTogZGFya2x5DQotLS0NCg0KIVtdKGh0dHBzOi8vbWlyby5tZWRpdW0uY29tL3YyLzEqYjJzTzJmLS15ZlppSmF6YzVyWVNwZy5naWYpDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IFRlb3LDrWEgPC9zcGFuPg0KKipBZ3J1cGFtaWVudG8qKiBvICpjbHVzdGVyaW5nKiBlcyB1bmEgdMOpY25pY2EgZGUgYXByZW5kaXphamUgYXV0b23DoXRpY28gbm8gc3VwZXJ2aXNhZG8gcXVlIGFncnVwYSBkYXRvcyBlbiBmdW5jacOzbiBkZSBzdSBzaW1pbGl0dWQuICANCg0KQWxndW5vcyB1c29zIHTDrXBpY29zIGRlIGVzdGEgdMOpY25pY2Egc29uOiAgDQoNCiogU2VnbWVudGFjacOzbiBkZSBjbGllbnRlcyAgDQoqIERldGVjY2nDs24gZGUgYW5vcm1hbGlkYWRlcyAgDQoqIENhdGVnb3JpemFjacOzbiBkZSBkb2N1bWVudG9zICANCg0KIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gSW5zdGFsYXIgcGFxdWV0ZXMgeSBsbGFtYXIgbGlicmVyw61hcyA8L3NwYW4+DQpgYGB7ciBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQ0KIyBpbnN0YWxsLnBhY2thZ2VzKCJjbHVzdGVyIikgIyBBbsOhbGlzaXMgZGUgQWdydXBhbWllbnRvDQpsaWJyYXJ5KGNsdXN0ZXIpDQojIGluc3RhbGwucGFja2FnZXMoImdncGxvdDIiKSAjIEdyYWZpY2FyDQpsaWJyYXJ5KGdncGxvdDIpDQojIGluc3RhbGwucGFja2FnZXMoImRhdGEudGFibGUiKSAjIE1hbmVqbyBkZSBtdWNob3MgZGF0b3MNCmxpYnJhcnkoZGF0YS50YWJsZSkNCiMgaW5zdGFsbC5wYWNrYWdlcygiZmFjdG9leHRyYSIpICMgR3LDoWZpY2EgZGUgb3B0aW1pemFjacOzbiBkZWwgbsO6bWVybyBkZSBjbHVzdGVycw0KbGlicmFyeShmYWN0b2V4dHJhKQ0KIyBpbnN0YWxsLnBhY2thZ2VzKCJkYXRhc2V0cyIpDQpsaWJyYXJ5KGRhdGFzZXRzKQ0KIyBpbnN0YWxsLnBhY2thZ2VzKCJ0aWR5dmVyc2UiKQ0KbGlicmFyeSh0aWR5dmVyc2UpDQpgYGANCg0KIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gRWplcmNpY2lvIDEuIFB1bnRvcyA8L3NwYW4+DQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBDb250ZXh0byA8L3NwYW4+DQpBZ3J1cGEgbG9zIHNpZ3VpZW50ZXMgOCBwdW50b3MuICANCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IE9idGVuZXIgZGF0b3MgPC9zcGFuPg0KYGBge3J9DQpkZjEgPC0gZGF0YS5mcmFtZSh4PWMoMiwyLDgsNSw3LDYsMSw0KSwgeT1jKDEwLDUsNCw4LDUsNCwyLDkpKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBFbnRlbmRlciBkYXRvcyA8L3NwYW4+DQpgYGB7cn0NCnN1bW1hcnkoZGYxKQ0Kc3RyKGRmMSkNCnBsb3QoZGYxJHgsZGYxJHkpDQpgYGANCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEVzY2FsYXIgZGF0b3MgPC9zcGFuPg0KYGBge3J9DQojIGRhdG9zX2VzY2FsYWRvcyA8LSBzY2FsZShkYXRvc19vcmlnaW5hbGVzKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBBc2lnbmFyIG7Dum1lcm8gZGUgZ3J1cG9zIDwvc3Bhbj4NCmBgYHtyfQ0KZ3J1cG9zMSA8LSAzDQpgYGANCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEFncnVwYXIgbG9zIHB1bnRvcyA8L3NwYW4+DQpgYGB7cn0NCnNldC5zZWVkKDEyMykNCmNsdXN0ZXJzMSA8LSBrbWVhbnMoZGYxLGdydXBvczEpDQpjbHVzdGVyczENCmBgYA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gT3B0aW1pemFyIG7Dum1lcm8gZGUgZ3J1cG9zIDwvc3Bhbj4NCmBgYHtyfQ0Kc2V0LnNlZWQoMTIzKQ0Kb3B0aW1pemFjaW9uMSA8LSBjbHVzR2FwKGRmMSwgRlVOPWttZWFucywgbnN0YXJ0PTEsIEsubWF4PTcpDQojIEVsIEsubWF4IG5vcm1hbG1lbnRlIGVzIDEwLCBlbiBlc3RlIGVqZXJjaWNpbyBhbCBzZXIgOCBkYXRvcyBzZSBkZWrDsyBlbiA3Lg0KcGxvdChvcHRpbWl6YWNpb24xLCB4bGFiPSJOw7ptZXJvIGRlIGNsdXN0ZXJzIGsiLCBtYWluPSJPcHRpbWl6YWNpw7NuIGRlIENsdXN0ZXJzIikNCiMgU2Ugc2VsZWNjaW9uYSBjb21vIMOzcHRpbW8gZWwgcHJpbWVyIHB1bnRvIG3DoXMgYWx0by4NCiMgU2kgZXMgZGlmZXJlbnRlIGFsIG9yaWdpbmFsLCByZWdyZXNhciB5IGFqdXN0YXIuDQpgYGANCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEdyYWZpY2FyIGxvcyBncnVwb3MgPC9zcGFuPg0KYGBge3J9DQpmdml6X2NsdXN0ZXIoY2x1c3RlcnMxLGRhdGE9ZGYxKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBBZ3JlZ2FyIGdydXBvcyBhIGxhIGJhc2UgZGUgZGF0b3MgPC9zcGFuPg0KYGBge3J9DQpkZjFfY2x1c3RlcnMgPC0gY2JpbmQoZGYxLCBjbHVzdGVyID0gY2x1c3RlcnMxJGNsdXN0ZXIpDQpoZWFkKGRmMV9jbHVzdGVycykNCmBgYA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gQ29uY2x1c2lvbmVzIDwvc3Bhbj4NCkxhIHTDqWNuaWNhIGRlICpjbHVzdGVyaW5nKiBwZXJtaXRlIGlkZW50aWZpY2FyIHBhdHJvbmVzIG8gZ3J1cG9zIG5hdHVyYWxlcyBlbiBsb3MgZGF0b3Mgc2luIG5lY2VzaWRhZCBkZSBldGlxdWV0YXMgcHJldmlhcy4gIA0KDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEVqZXJjaWNpbyAyLiBVU0FycmVzdHMgPC9zcGFuPg0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gQ29udGV4dG8gPC9zcGFuPg0KTGEgYmFzZSBkZSBkYXRvcyAqKlVTQXJyZXN0cyoqIGNvbnRpZW5lIGVzdGFkw61zdGljYXMgZW4gYXJyZXN0b3MgcG9yIGNhZGEgMTAwLDAwMCByZXNpZGVudGVzIHBvciBhZ3Jlc2nDs24sIGFzZXNpbmF0byB5IHZpb2xhY2nDs24gZW4gY2FkYSB1bm8gZGUgbG9zIDUwIGVzdGFkb3MgZGUgRUUuVVUuIGVuIDE5NzMuICANCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IE9idGVuZXIgZGF0b3MgPC9zcGFuPg0KYGBge3J9DQpkZjIgPC0gVVNBcnJlc3RzDQpkZjIgPC0gZGYyICU+JSBzZWxlY3QoLVVyYmFuUG9wKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBFbnRlbmRlciBkYXRvcyA8L3NwYW4+DQpgYGB7cn0NCnN1bW1hcnkoZGYyKQ0Kc3RyKGRmMikNCmBgYA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gRXNjYWxhciBkYXRvcyA8L3NwYW4+DQpgYGB7cn0NCmRmMl9lc2NhbGFkb3MgPC0gc2NhbGUoZGYyKQ0Kc3VtbWFyeShkZjJfZXNjYWxhZG9zKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBBc2lnbmFyIG7Dum1lcm8gZGUgZ3J1cG9zIDwvc3Bhbj4NCmBgYHtyfQ0KZ3J1cG9zMiA8LSA1DQpgYGANCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEFncnVwYXIgbG9zIHB1bnRvcyA8L3NwYW4+DQpgYGB7cn0NCnNldC5zZWVkKDEyMykNCmNsdXN0ZXJzMiA8LSBrbWVhbnMoZGYyX2VzY2FsYWRvcyxncnVwb3MyKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBPcHRpbWl6YXIgbsO6bWVybyBkZSBncnVwb3MgPC9zcGFuPg0KYGBge3J9DQpzZXQuc2VlZCgxMjMpDQpvcHRpbWl6YWNpb24yIDwtIGNsdXNHYXAoZGYyX2VzY2FsYWRvcywgRlVOPWttZWFucywgbnN0YXJ0PTEsIEsubWF4PTEwKQ0KcGxvdChvcHRpbWl6YWNpb24yLCB4bGFiPSJOw7ptZXJvIGRlIGNsdXN0ZXJzIGsiLCBtYWluPSJPcHRpbWl6YWNpw7NuIGRlIENsdXN0ZXJzIikNCiMgU2Ugc2VsZWNjaW9uYSBjb21vIMOzcHRpbW8gZWwgcHJpbWVyIHB1bnRvIG3DoXMgYWx0by4NCiMgU2kgZXMgZGlmZXJlbnRlIGFsIG9yaWdpbmFsLCByZWdyZXNhciB5IGFqdXN0YXIuDQpgYGANCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEdyYWZpY2FyIGxvcyBncnVwb3MgPC9zcGFuPg0KYGBge3J9DQpmdml6X2NsdXN0ZXIoY2x1c3RlcnMyLGRhdGE9ZGYyX2VzY2FsYWRvcykNCmBgYA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gQWdyZWdhciBncnVwb3MgYSBsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4NCmBgYHtyfQ0KZGYyX2NsdXN0ZXJzIDwtIGNiaW5kKGRmMiwgY2x1c3RlciA9IGNsdXN0ZXJzMiRjbHVzdGVyKQ0KaGVhZChkZjJfY2x1c3RlcnMpDQoNCmRmMl9jbHVzdGVycyAlPiUgZ3JvdXBfYnkoY2x1c3RlcikgJT4lIHN1bW1hcmlzZV9hbGwobWVhbikgJT4lIG11dGF0ZShpbmRpY2Fkb3JfaW5zZWd1cmlkYWQ9TXVyZGVyK0Fzc2F1bHQrUmFwZSkNCg0KZGYyX2NsdXN0ZXJzIDwtIGRmMl9jbHVzdGVycyAlPiUNCiAgbXV0YXRlKGNsdXN0ZXI9IGNhc2Vfd2hlbigNCiAgICBjbHVzdGVyID09IDEgfiAiSW5zZWd1cmlkYWQgTXV5IEFsdGEiLA0KICAgIGNsdXN0ZXIgPT0gNCB+ICJJbnNlZ3VyaWRhZCBBbHRhIiwNCiAgICBjbHVzdGVyID09IDUgfiAiSW5zZWd1cmlkYWQgTWVkaWEiLA0KICAgIGNsdXN0ZXIgPT0gMyB+ICJJbnNlZ3VyaWRhZCBCYWphIiwNCiAgICBjbHVzdGVyID09IDIgfiAiSW5zZWd1cmlkYWQgTXV5IEJhamEiDQogICkpDQpoZWFkKGRmMl9jbHVzdGVycykNCmBgYA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gQ29uY2x1c2lvbmVzIDwvc3Bhbj4NCkxhIHTDqWNuaWNhIGRlICpjbHVzdGVyaW5nKiBwZXJtaXRlIGlkZW50aWZpY2FyIHBhdHJvbmVzIG8gZ3J1cG9zIG5hdHVyYWxlcyBlbiBsb3MgZGF0b3Mgc2luIG5lY2VzaWRhZCBkZSBldGlxdWV0YXMgcHJldmlhcy4gDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEVqZXJjaWNpbyAzLiBTZWdtZW50YWNpw7NuIGRlIENsaWVudGVzIDwvc3Bhbj4NCg0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IENvbnRleHRvIDwvc3Bhbj4NCkxhIGJhc2UgZGUgZGF0b3MgKip2ZW50YXMqKiB0aWVuZSBsb3MgcmVnaXN0cm9zIGVudHJlIGVsIDEgZGUgZGljaWVtYnJlIGRlIDIwMTAgeSBlbCA5IGRlIGRpY2llbWJyZSBkZSAyMDExIGRlIGxhcyB2ZW50YXMgZGUgdW5hIGVtcHJlc2EgbWlub3Jpc3RhIGVuIGzDrW5lYSBzaW4gdGllbmRhIGbDrXNpY2EsIGJhc2FkYSBlbiBSZWlubyBVbmlkby4gIA0KTGEgZW1wcmVzYSB2ZW5kZSBwcmluY2lwYWxtZW50ZSByZWdhbG9zIMO6bmljb3MgcGFyYSB0b2RhIG9jYXNpw7NuLCB5IG11Y2hvcyBkZSBzdXMgY2xpZW50ZXMgc29uIG1heW9yaXN0YXMuICANCk9iamV0aXZvOiBTZWdtZW50YXIgY2xpZW50ZXMsIGFzaWduYXJsZXMgbm9tYnJlIHkgY2FyYWN0ZXLDrXN0aWNhcyBkZSBjb21wb3J0YW1pZW50bywgeSBwcm9wb25lciBzdWdlcmVuY2lhcyBhIGxhIGVtcHJlc2EgcGFyYSBhdW1lbnRhciB2ZW50YXMuICANCg0KDQoNCg0KDQoNCg0KDQoNCg0K