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") # analísis 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) se usaría en una base de datos que tenga variables muy diferentes, en este caso no.
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. "3"
# si es diferente, después de esté plot, pues ovbiamente cambiamos el numero de grupos, en la linea de grupos1
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)
# el K.max normalmente es 10, en este ejercicio al ser 8 datos se dejó en 7.
plot(optimizacion2, xlab="Número de clusters k", main="Optimización de Clusters")

# se selecciona como óptimo el primer punto más alto. "3"
# si es diferente, después de esté plot, pues ovbiamente cambiamos el numero de grupos, en la linea de grupos1
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 ~ "Inseguidad 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 Inseguidad Alta
## Arizona 8.1 294 31.0 Inseguridad Muy Alta
## Arkansas 8.8 190 19.5 Inseguridad Baja
## California 9.0 276 40.6 Inseguidad Alta
## Colorado 7.9 204 38.7 Inseguidad Alta
Conclusiones
La técnica de clustering permite identificar patrones o
grupos naturales en los datos sin necesidad de etiquetas previas.
LS0tCnRpdGxlOiAiQ2x1c3RlcnMgLSBQdW50b3MsIFVTQXJyZXN0cyB5IENsaWVudGVzIgphdXRob3I6ICJNYXJjZWxvIFNhbGF6YXIgQU8xNzIyMTkyIgpkYXRlOiAiMjAyNi0wOC0yNSIKb3V0cHV0OiAKICBodG1sX2RvY3VtZW50OgogICAgdG9jOiBUUlVFCiAgICB0b2NfZmxvYXQ6IFRSVUUKICAgIGNvZGVfZG93bmxvYWQ6IFRSVUUKICAgIHRoZW1lOiBkYXJrbHkKLS0tCgohW10oaHR0cHM6Ly9pLm1ha2VhZ2lmLmNvbS9tZWRpYS8xLTMwLTIwMjQvbWM3RFpmLmdpZikKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOlllbGxvdyI+VGVvcsOtYSA8L3NwYW4+CioqQWdydXBhbWllbnRvKiogbyAqY2x1c3RlcmluZyogZXMgdW5hIHTDqWNuaWNhIGRlIGFwcmVuZGl6YWplIGF1dG9tw6F0aWNvIG5vIHN1cGVydmlzYWRvIHF1ZSBhZ3J1cGEgZGF0b3MgZW4gZnVuY2nDs24gZGUgc3Ugc2ltaWxpdHVkLiAgCgpBbGd1bm9zIHVzb3MgdMOtcGljb3MgZGUgZXN0YSB0w6ljbmljYSBzb246ICAKCiogU2VnbWVudGFjacOzbiBkZSBDbGllbnRlcy4gICAgCiogRGV0ZWNjacOzbiBkZSBhbm9ybWFsaWRhZGVzLiAgCiogQ2F0ZWdvcml6YWNpw7NuIGRlIERvY3VtZW50b3MuICAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOlllbGxvdyI+IEluc3RhbGFyIHBhcXVldGVzIHkgbGxhbWFyIGxpYnJlcsOtYXMgPC9zcGFuPgpgYGB7ciBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQojIGluc3RhbGwucGFja2FnZXMoImNsdXN0ZXIiKSAjIGFuYWzDrXNpcyBkZSBhZ3J1cGFtaWVudG8KbGlicmFyeShjbHVzdGVyKQojIGluc3RhbGwucGFja2FnZXMoImdncGxvdDIiKSAjIGdyYWZpY2FyIApsaWJyYXJ5KGdncGxvdDIpCiMgaW5zdGFsbC5wYWNrYWdlcygiZGF0YS50YWJsZSIpICMgbWFuZWpvIGRlIG11Y2hvcyBkYXRvcyAKbGlicmFyeShkYXRhLnRhYmxlKQojIGluc3RhbGwucGFja2FnZXMoImZhY3RvZXh0cmEiKSAjIGdyw6FmaWNhIGRlIG9wdGltaXphY2nDs24gZGVsIG7Dum1lcm8gZGUgY2x1c3RlcnMKbGlicmFyeShmYWN0b2V4dHJhKQojIGluc3RhbGwucGFja2FnZXMoImRhdGFzZXRzIikKbGlicmFyeShkYXRhc2V0cykKIyBpbnN0YWxsLnBhY2thZ2VzKCJ0aWR5dmVyc2UiKQpsaWJyYXJ5KHRpZHl2ZXJzZSkKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBFamVyY2ljaW8gMS4gUHVudG9zICA8L3NwYW4+CgojIyA8c3BhbiBzdHlsZT0iY29sb3I6WWVsbG93Ij4gQ29udGV4dG8gIDwvc3Bhbj4KQWdydXBhIGxvcyBzaWd1aWVudGVzIDggcHVudG9zLiAKCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBPYnRlbmVyIERhdG9zICA8L3NwYW4+CmBgYHtyfQpkZjEgPC0gZGF0YS5mcmFtZSh4PWMoMiwyLDgsNSw3LDYsMSw0KSwgeT1jKDEwLDUsNCw4LDUsNCwyLDkpKQpgYGAKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOlllbGxvdyI+IEVudGVuZGVyIERhdG9zICA8L3NwYW4+CmBgYHtyfQpzdW1tYXJ5KGRmMSkKc3RyKGRmMSkKcGxvdChkZjEkeCxkZjEkeSkKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBFc2NhbGFyIERhdG9zICA8L3NwYW4+CmBgYHtyfQojIGRhdG9zX2VzY2FsYWRvcyA8LSBzY2FsZShkYXRvc19vcmlnaW5hbGVzKSBzZSB1c2Fyw61hIGVuIHVuYSBiYXNlIGRlIGRhdG9zIHF1ZSB0ZW5nYSB2YXJpYWJsZXMgbXV5IGRpZmVyZW50ZXMsIGVuIGVzdGUgY2FzbyBuby4KYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBBc2lnbmFyIG7Dum1lcm8gZGUgZ3J1cG9zICA8L3NwYW4+CmBgYHtyfQpncnVwb3MxIDwtIDMKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBBZ3J1cGFyIGxvcyBwdW50b3MgIDwvc3Bhbj4KYGBge3J9CnNldC5zZWVkKDEyMykKY2x1c3RlcnMxIDwtIGttZWFucyhkZjEsZ3J1cG9zMSkKY2x1c3RlcnMxCmBgYAojIyA8c3BhbiBzdHlsZT0iY29sb3I6WWVsbG93Ij4gT3B0aW1pemFyIG7Dum1lcm8gZGUgZ3J1cG9zICA8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCm9wdGltaXphY2lvbjEgPC0gY2x1c0dhcChkZjEsIEZVTj1rbWVhbnMsIG5zdGFydD0xLCBLLm1heD03KQojIGVsIEsubWF4IG5vcm1hbG1lbnRlIGVzIDEwLCBlbiBlc3RlIGVqZXJjaWNpbyBhbCBzZXIgOCBkYXRvcyBzZSBkZWrDsyBlbiA3LgpwbG90KG9wdGltaXphY2lvbjEsIHhsYWI9Ik7Dum1lcm8gZGUgY2x1c3RlcnMgayIsIG1haW49Ik9wdGltaXphY2nDs24gZGUgQ2x1c3RlcnMiKQojIHNlIHNlbGVjY2lvbmEgY29tbyDDs3B0aW1vIGVsIHByaW1lciBwdW50byBtw6FzIGFsdG8uICIzIgojIHNpIGVzIGRpZmVyZW50ZSwgZGVzcHXDqXMgZGUgZXN0w6kgcGxvdCwgcHVlcyBvdmJpYW1lbnRlIGNhbWJpYW1vcyBlbCBudW1lcm8gZGUgZ3J1cG9zLCBlbiBsYSBsaW5lYSBkZSBncnVwb3MxCmBgYAojIyA8c3BhbiBzdHlsZT0iY29sb3I6WWVsbG93Ij4gR3JhZmljYXIgbG9zIGdydXBvcyAgPC9zcGFuPgpgYGB7cn0KZnZpel9jbHVzdGVyKGNsdXN0ZXJzMSwgZGF0YSA9IGRmMSkKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBBZ3JlZ2FyIGdydXBvcyBhIGxhIGJhc2UgZGUgZGF0b3MgIDwvc3Bhbj4KYGBge3J9CmRmMV9jbHVzdGVycyA8LSBjYmluZChkZjEsIGNsdXN0ZXIgPSBjbHVzdGVyczEkY2x1c3RlcikKaGVhZChkZjFfY2x1c3RlcnMpCmBgYAojIyA8c3BhbiBzdHlsZT0iY29sb3I6WWVsbG93Ij4gQ29uY2x1c2lvbmVzICA8L3NwYW4+CkxhIHTDqWNuaWNhIGRlICpjbHVzdGVyaW5nKiBwZXJtaXRlIGlkZW50aWZpY2FyIHBhdHJvbmVzIG8gZ3J1cG9zIG5hdHVyYWxlcyBlbiBsb3MgZGF0b3Mgc2luIG5lY2VzaWRhZCBkZSBldGlxdWV0YXMgcHJldmlhcy4gIAoKIyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tCiMgPHNwYW4gc3R5bGU9ImNvbG9yOlllbGxvdyI+IEVqZXJjaWNpbyAyLiBVU0FycmVzdHMgPC9zcGFuPgoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOlllbGxvdyI+IENvbnRleHRvICA8L3NwYW4+CkxhIGJhc2UgZGUgZGF0b3MgKipVU0FycmVzdHMqKiBjb250aWVuZSBlc3RhZMOtc3RpY2FzIGVuIGFycmVzdG9zIHBvciBjYWRhIDEwMCwwMDAgcmVzaWRlbnRlcyBwb3IgYWdyZXNpw7NuLCBhc2VzaW5hdG8geSB2aW9sYWNpw7NuIGVuIGNhZGEgdW5vIGRlIGxvcyA1MCBlc3RhZG9zIGRlIEVFLlVVLiBlbiAxOTczLgoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOlllbGxvdyI+IE9idGVuZXIgRGF0b3MgIDwvc3Bhbj4KYGBge3J9CmRmMiA8LSBVU0FycmVzdHMKZGYyIDwtIGRmMiAlPiUgc2VsZWN0KC1VcmJhblBvcCkKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBFbnRlbmRlciBEYXRvcyAgPC9zcGFuPgpgYGB7cn0Kc3VtbWFyeShkZjIpCnN0cihkZjIpCmBgYAojIyA8c3BhbiBzdHlsZT0iY29sb3I6WWVsbG93Ij4gRXNjYWxhciBEYXRvcyAgPC9zcGFuPgpgYGB7cn0KZGYyX2VzY2FsYWRvcyA8LSBzY2FsZShkZjIpCnN1bW1hcnkoZGYyX2VzY2FsYWRvcykKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBBc2lnbmFyIG7Dum1lcm8gZGUgZ3J1cG9zICA8L3NwYW4+CmBgYHtyfQpncnVwb3MyIDwtIDUKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBBZ3J1cGFyIGxvcyBwdW50b3MgIDwvc3Bhbj4KYGBge3J9CnNldC5zZWVkKDEyMykKY2x1c3RlcnMyIDwtIGttZWFucyhkZjJfZXNjYWxhZG9zLGdydXBvczIpCmBgYAojIyA8c3BhbiBzdHlsZT0iY29sb3I6WWVsbG93Ij4gT3B0aW1pemFyIG7Dum1lcm8gZGUgZ3J1cG9zICA8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCm9wdGltaXphY2lvbjIgPC0gY2x1c0dhcChkZjJfZXNjYWxhZG9zLCBGVU49a21lYW5zLCBuc3RhcnQ9MSwgSy5tYXg9MTApCiMgZWwgSy5tYXggbm9ybWFsbWVudGUgZXMgMTAsIGVuIGVzdGUgZWplcmNpY2lvIGFsIHNlciA4IGRhdG9zIHNlIGRlasOzIGVuIDcuCnBsb3Qob3B0aW1pemFjaW9uMiwgeGxhYj0iTsO6bWVybyBkZSBjbHVzdGVycyBrIiwgbWFpbj0iT3B0aW1pemFjacOzbiBkZSBDbHVzdGVycyIpCiMgc2Ugc2VsZWNjaW9uYSBjb21vIMOzcHRpbW8gZWwgcHJpbWVyIHB1bnRvIG3DoXMgYWx0by4gIjMiCiMgc2kgZXMgZGlmZXJlbnRlLCBkZXNwdcOpcyBkZSBlc3TDqSBwbG90LCBwdWVzIG92YmlhbWVudGUgY2FtYmlhbW9zIGVsIG51bWVybyBkZSBncnVwb3MsIGVuIGxhIGxpbmVhIGRlIGdydXBvczEKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBHcmFmaWNhciBsb3MgZ3J1cG9zICA8L3NwYW4+CmBgYHtyfQpmdml6X2NsdXN0ZXIoY2x1c3RlcnMyLCBkYXRhID0gZGYyX2VzY2FsYWRvcykKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBBZ3JlZ2FyIGdydXBvcyBhIGxhIGJhc2UgZGUgZGF0b3MgIDwvc3Bhbj4KYGBge3J9CmRmMl9jbHVzdGVycyA8LSBjYmluZChkZjIsIGNsdXN0ZXIgPSBjbHVzdGVyczIkY2x1c3RlcikKaGVhZChkZjJfY2x1c3RlcnMpCgpkZjJfY2x1c3RlcnMgJT4lIGdyb3VwX2J5KGNsdXN0ZXIpICU+JSBzdW1tYXJpc2VfYWxsKG1lYW4pICU+JQptdXRhdGUoaW5kaWNhZG9yX2luc2VndXJpZGFkPU11cmRlcitBc3NhdWx0K1JhcGUpCgpkZjJfY2x1c3RlcnMgPC0gZGYyX2NsdXN0ZXJzICU+JQogIG11dGF0ZShjbHVzdGVyPSBjYXNlX3doZW4oCiAgICBjbHVzdGVyID09IDEgfiAiSW5zZWd1cmlkYWQgTXV5IEFsdGEiLAogICAgY2x1c3RlciA9PSA0IH4gIkluc2VndWlkYWQgQWx0YSIsIAogICAgY2x1c3RlciA9PSA1IH4gIkluc2VndXJpZGFkIE1lZGlhIiwKICAgIGNsdXN0ZXIgPT0gMyB+ICJJbnNlZ3VyaWRhZCBCYWphIiwKICAgIGNsdXN0ZXIgPT0gMiB+ICJJbnNlZ3VyaWRhZCBNdXkgQmFqYSIKICApKQpoZWFkKGRmMl9jbHVzdGVycykKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpZZWxsb3ciPiBDb25jbHVzaW9uZXMgIDwvc3Bhbj4KTGEgdMOpY25pY2EgZGUgKmNsdXN0ZXJpbmcqIHBlcm1pdGUgaWRlbnRpZmljYXIgcGF0cm9uZXMgbyBncnVwb3MgbmF0dXJhbGVzIGVuIGxvcyBkYXRvcyBzaW4gbmVjZXNpZGFkIGRlIGV0aXF1ZXRhcyBwcmV2aWFzLiAgCgoKIyA8c3BhbiBzdHlsZT0iY29sb3I6WWVsbG93Ij4gRWplcmNpY2lvIDMuIFNlZ21lbnRhY2nDs24gZGUgQ2xpZW50ZXMgPC9zcGFuPgoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOlllbGxvdyI+IENvbnRleHRvICA8L3NwYW4+CkxhIGJhc2UgZGUgZGF0b3MgKip2ZW50YXMqKiB0aWVuZSBsb3MgcmVnaXN0cm9zIGVudHJlIGVsIDEgZGUgc2VwdGllbWJyZSBkZSAyMDEwIHkgZWwgOSBkZSBkaWNpZW1icmUgZGUgMjAxMSBkZSBsYXMgdmVudGFzIGRlIHVuYSBlbXByZXNhIG1pbnRvcmlzdGEgZW4gbMOtbmVhIAo=