Teoría

Agrupamiento o cluserting 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 anormlidades
  • Categorización de documentos

Instalar paquetes y llamar librerías

#install.packages("cluster")
library(cluster)
#install.packages("ggplot2")
library(ggplot2)
#install.packages("data.table")
library(data.table)
## 
## Attaching package: 'data.table'
## The following object is masked from 'package:base':
## 
##     %notin%
#install.packages("factoextra")
library(factoextra)
## Welcome to factoextra!
## Want to learn more? See two factoextra-related books at https://www.datanovia.com/library/principal-component-methods
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.2.1     ✔ readr     2.2.0
## ✔ forcats   1.0.1     ✔ stringr   1.6.0
## ✔ lubridate 1.9.5     ✔ tibble    3.3.1
## ✔ purrr     1.2.2     ✔ tidyr     1.3.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::between()     masks data.table::between()
## ✖ dplyr::filter()      masks stats::filter()
## ✖ dplyr::first()       masks data.table::first()
## ✖ lubridate::hour()    masks data.table::hour()
## ✖ lubridate::isoweek() masks data.table::isoweek()
## ✖ lubridate::isoyear() masks data.table::isoyear()
## ✖ dplyr::lag()         masks stats::lag()
## ✖ dplyr::last()        masks data.table::last()
## ✖ lubridate::mday()    masks data.table::mday()
## ✖ lubridate::minute()  masks data.table::minute()
## ✖ lubridate::month()   masks data.table::month()
## ✖ lubridate::quarter() masks data.table::quarter()
## ✖ lubridate::second()  masks data.table::second()
## ✖ purrr::transpose()   masks data.table::transpose()
## ✖ lubridate::wday()    masks data.table::wday()
## ✖ lubridate::week()    masks data.table::week()
## ✖ lubridate::yday()    masks data.table::yday()
## ✖ lubridate::year()    masks data.table::year()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

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 dejo 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

Graficar los grupos

fviz_cluster(clusters1,data=df1)

Agregar grups 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. US Arrests

Contexto

La base de datos US Arrests contiene estadísticas en arrestos por cada 100,000 residentes por agresión, asesinato y violacio2n 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

Graficar los grupos

fviz_cluster(clusters2,data=df2_escalados)

Agregar grups 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.

LS0tCnRpdGxlOiAiQ2x1c3RlcnMgLSBQdW50b3MsIFVTIEFycmVzdHMgeSBDbGllbnRlcyIKYXV0aG9yOiAiTWF5dGUgQXZhbG9zIEd1enVtYW4iCmRhdGU6ICJgciBTeXMuRGF0ZSgpYCIKb3V0cHV0OiAKICBodG1sX2RvY3VtZW50OgogICAgdG9jOiBUUlVFCiAgICB0b2NfZmxvYXQ6IFRSVUUKICAgIGNvZGVfZG93bmxvYWQ6IFRSVUUKICAgIHRoZW1lOiBkYXJrbHkKICAgIAotLS0KIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gVGVvcsOtYSA8L3NwYW4+CioqQWdydXBhbWllbnRvKiogbyAqY2x1c2VydGluZyogZXMgdW5hIHTDqWNuaWNhIGRlIGFwcmVuZGl6YWplIGF1dG9tw6F0aWNvIG5vIHN1cGVydmlzYWRvIHF1ZSBhZ3J1cGEgZGF0b3MgZW4gZnVuY2nDs24gZGUgc3Ugc2ltaWxpdHVkLiAgCgpBbGd1bm9zIHVzb3MgdMOtcGljb3MgZGUgZXN0YSB0w6ljbmljYSBzb246ICAKCiogU2VnbWVudGFjacOzbiBkZSBjbGllbnRlcyAgCiogRGV0ZWNjacOzbiBkZSBhbm9ybWxpZGFkZXMgIAoqIENhdGVnb3JpemFjacOzbiBkZSBkb2N1bWVudG9zICAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEluc3RhbGFyIHBhcXVldGVzIHkgbGxhbWFyIGxpYnJlcsOtYXMgPC9zcGFuPgpgYGB7ciB3YXJuaW5nPUZBTFNFfQojaW5zdGFsbC5wYWNrYWdlcygiY2x1c3RlciIpCmxpYnJhcnkoY2x1c3RlcikKI2luc3RhbGwucGFja2FnZXMoImdncGxvdDIiKQpsaWJyYXJ5KGdncGxvdDIpCiNpbnN0YWxsLnBhY2thZ2VzKCJkYXRhLnRhYmxlIikKbGlicmFyeShkYXRhLnRhYmxlKQojaW5zdGFsbC5wYWNrYWdlcygiZmFjdG9leHRyYSIpCmxpYnJhcnkoZmFjdG9leHRyYSkKbGlicmFyeSh0aWR5dmVyc2UpCmBgYAoKIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gRWplcmNpY2lvIDEuIFB1bnRvcyA8L3NwYW4+CiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBDb250ZXh0byA8L3NwYW4+CkFncnVwYSBsb3Mgc2lndWllbnRlcyA4IHB1bnRvcwoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IE9idGVuZXIgZGF0b3MgPC9zcGFuPgpgYGB7cn0KZGYxIDwtIGRhdGEuZnJhbWUoeD1jKDIsMiw4LDUsNyw2LDEsNCksIHk9YygxMCw1LDQsOCw1LDQsMiw5KSkKYGBgCgojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gRW50ZW5kZXIgZGF0b3MgPC9zcGFuPgpgYGB7cn0Kc3VtbWFyeShkZjEpCnN0cihkZjEpCnBsb3QoZGYxJHgsIGRmMSR5KQpgYGAKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEVzY2FsYXIgZGF0b3MgPC9zcGFuPgpgYGB7cn0KI2RhdG9zX2VzY2FsYWRvcyA8LSBzY2FsZShkYXRvc19vcmlnaW5hbGVzKQpgYGAKCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBBc2lnbmFyIG7Dum1lcm8gZGUgZ3J1cG9zIDwvc3Bhbj4KYGBge3J9CmdydXBvczEgPC0gMwpgYGAKCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBBZ3J1cGFyIGxvcyBwdW50b3MgPC9zcGFuPgpgYGB7cn0Kc2V0LnNlZWQoMTIzKQpjbHVzdGVyczEgPC0ga21lYW5zKGRmMSxncnVwb3MxKQpjbHVzdGVyczEKYGBgCgojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gT3B0aW1pemFyIG7Dum1lcm8gZGUgZ3J1cG9zIDwvc3Bhbj4KYGBge3J9CnNldC5zZWVkKDEyMykKb3B0aW1pemFjaW9uMSA8LSBjbHVzR2FwKGRmMSwgRlVOPWttZWFucywgbnN0YXJ0ID0gMSwgSy5tYXg9NykKIyBFbCBLLm1heCBub3JtYWxtZW50ZSBlcyAxMCwgZW4gZXN0ZSBlamVyY2ljaW8gYWwgc2VyIDggZGF0b3Mgc2UgZGVqbyBlbiA3LgpwbG90KG9wdGltaXphY2lvbjEsIHhsYWI9Ik7Dum1lcm8gZGUgQ2x1c3RlcnMgSyIsIG1haW49Ik9wdGltaXphY2nDs24gZGUgQ2x1c3RlcnMiKQojIFNlIHNlbGVjY2lvbmEgY29tbyDDs3B0aW1vIGVsIHByaW1lciBwdW50byBtw6FzIGFsdG8KYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBHcmFmaWNhciBsb3MgZ3J1cG9zIDwvc3Bhbj4KYGBge3J9CmZ2aXpfY2x1c3RlcihjbHVzdGVyczEsZGF0YT1kZjEpCmBgYAoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEFncmVnYXIgZ3J1cHMgYSBsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4KYGBge3J9CmRmMV9jbHVzdGVycyA8LSBjYmluZChkZjEsIGNsdXN0ZXIgPSBjbHVzdGVyczEkY2x1c3RlcikKaGVhZChkZjFfY2x1c3RlcnMpCmBgYAojIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gQ29uY2x1c2lvbmVzIDwvc3Bhbj4KTGEgdMOpY25pY2EgZGUgKmNsdXN0ZXJpbmcqIHBlcm1pdGUgaWRlbnRpZmljYXIgcGF0cm9uZXMgbyBncnVwb3MgbmF0dXJhbGVzIGVuIGxvcyBkYXRvcyBzaW4gbmVjZXNpZGFkIGRlIGV0aXF1ZXRhcyBwcmV2aWFzLiAgCgoKIyA8c3BhbiBzdHlsZT0iY29sb3I6eWVsbG93Ij4gRWplcmNpY2lvIDIuIFVTIEFycmVzdHMgPC9zcGFuPgoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IENvbnRleHRvIDwvc3Bhbj4KTGEgYmFzZSBkZSBkYXRvcyAqKlVTIEFycmVzdHMqKiBjb250aWVuZSBlc3RhZMOtc3RpY2FzIGVuIGFycmVzdG9zIHBvciBjYWRhIDEwMCwwMDAgcmVzaWRlbnRlcyBwb3IgYWdyZXNpw7NuLCBhc2VzaW5hdG8geSB2aW9sYWNpbzJuIGVuIGNhZGEgdW5vIGRlIGxvcyA1MCBlc3RhZG9zIGRlIEVFLlVVLiBlbiAxOTczLgoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IE9idGVuZXIgZGF0b3MgPC9zcGFuPgpgYGB7cn0KZGYyIDwtIFVTQXJyZXN0cwpkZjIgPC0gZGYyICU+JSBzZWxlY3QoLVVyYmFuUG9wKQpgYGAKCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBFbnRlbmRlciBkYXRvcyA8L3NwYW4+CmBgYHtyfQpzdW1tYXJ5KGRmMikKc3RyKGRmMikKYGBgCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBFc2NhbGFyIGRhdG9zIDwvc3Bhbj4KYGBge3J9CmRmMl9lc2NhbGFkb3MgPC0gc2NhbGUoZGYyKQpzdW1tYXJ5KGRmMl9lc2NhbGFkb3MpCmBgYAoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEFzaWduYXIgbsO6bWVybyBkZSBncnVwb3MgPC9zcGFuPgpgYGB7cn0KZ3J1cG9zMiA8LSA1CmBgYAoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEFncnVwYXIgbG9zIHB1bnRvcyA8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCmNsdXN0ZXJzMiA8LSBrbWVhbnMoZGYyX2VzY2FsYWRvcyxncnVwb3MyKQpgYGAKCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjp5ZWxsb3ciPiBPcHRpbWl6YXIgbsO6bWVybyBkZSBncnVwb3MgPC9zcGFuPgpgYGB7cn0Kc2V0LnNlZWQoMTIzKQpvcHRpbWl6YWNpb24yIDwtIGNsdXNHYXAoZGYyX2VzY2FsYWRvcywgRlVOPWttZWFucywgbnN0YXJ0ID0gMSwgSy5tYXg9MTApCnBsb3Qob3B0aW1pemFjaW9uMiwgeGxhYj0iTsO6bWVybyBkZSBDbHVzdGVycyBLIiwgbWFpbj0iT3B0aW1pemFjacOzbiBkZSBDbHVzdGVycyIpCiMgU2Ugc2VsZWNjaW9uYSBjb21vIMOzcHRpbW8gZWwgcHJpbWVyIHB1bnRvIG3DoXMgYWx0bwpgYGAKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEdyYWZpY2FyIGxvcyBncnVwb3MgPC9zcGFuPgpgYGB7cn0KZnZpel9jbHVzdGVyKGNsdXN0ZXJzMixkYXRhPWRmMl9lc2NhbGFkb3MpCmBgYAoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IEFncmVnYXIgZ3J1cHMgYSBsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4KYGBge3J9CmRmMl9jbHVzdGVycyA8LSBjYmluZChkZjIsIGNsdXN0ZXIgPSBjbHVzdGVyczIkY2x1c3RlcikKaGVhZChkZjJfY2x1c3RlcnMpCgpkZjJfY2x1c3RlcnMgJT4lIGdyb3VwX2J5KGNsdXN0ZXIpICU+JSBzdW1tYXJpc2VfYWxsKG1lYW4pICU+JQogIG11dGF0ZShpbmRpY2Fkb3JfaW5zZWd1cmlkYWQ9TXVyZGVyK0Fzc2F1bHQrUmFwZSkKCmRmMl9jbHVzdGVycyA8LSBkZjJfY2x1c3RlcnMgJT4lIAogIG11dGF0ZShjbHVzdGVyID0gY2FzZV93aGVuKAogICAgY2x1c3RlciA9PSAxIH4gIkluc2VndXJpZGFkIE11eSBBbHRhIiwKICAgIGNsdXN0ZXIgPT0gNCB+ICJJbnNlZ3VyaWRhZCBBbHRhIiwKICAgIGNsdXN0ZXIgPT0gNSB+ICJJbnNlZ3VyaWRhZCBNZWRpYSIsCiAgICBjbHVzdGVyID09IDMgfiAiSW5zZWd1cmlkYWQgQmFqYSIsCiAgICBjbHVzdGVyID09IDIgfiAiSW5zZWd1cmlkYWQgTXV5IEJhamEiCiAgKSkKaGVhZChkZjJfY2x1c3RlcnMpCgpgYGAKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnllbGxvdyI+IENvbmNsdXNpb25lcyA8L3NwYW4+CkxhIHTDqWNuaWNhIGRlICpjbHVzdGVyaW5nKiBwZXJtaXRlIGlkZW50aWZpY2FyIHBhdHJvbmVzIG8gZ3J1cG9zIG5hdHVyYWxlcyBlbiBsb3MgZGF0b3Mgc2luIG5lY2VzaWRhZCBkZSBldGlxdWV0YXMgcHJldmlhcy4gIA==