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 anomalidades.
*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)
#install.packages("factoextra")
library(factoextra)
#install.packages("tidyr")
library(tidyr)
#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)
optimizacion <- 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(optimizacion, xlab="Número de clsuters k", main="Optimización de clusters")

# Se selecciona como óptimo el primer punto más alto
# Si es diferente al original, regresar y ajustar

Gráficar 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

Conlusiones

La técnica de clustering permite identificar patrones o grupos naturales en los datos sin necesidad de etiquetas previas.

Ejercicio 2. USArrest

Contexto

La base de datos de USArrest 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)
optimizacion <- 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(optimizacion, xlab="Número de clsuters k", main="Optimización de clusters")

# Se selecciona como óptimo el primer punto más alto
# Si es diferente al original, regresar y ajustar

Gráficar 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"
  ))

Ejercicio 3. Segmentación de Clientes

Contexto

La base de datos ventas tiene los registros entre el 01 de diciembre de 2010 y el 09 de diciembre de 2011 de las ventas de una empresa minorista en línea sin tienda física, basada en Reino Unido.
La empresa venfe principalmente regalos únicos para toda ocasión, y muchos de sus clientes son mayoristas.
Objetivo: Segmentar clientes, asignatles nombre y características de comportamiento, y proponer sugerencias a la empresa para aumentar ventas.

LS0tCnRpdGxlOiAiQ2x1c3RlcnMgLSBQdW50b3MgVVNBcnJlc3RzIHkgQ2xpZW50ZXMiCmF1dGhvcjogIkFubmEgTHVpc2EgUm9jaGEgLSBBMDE3NDE3NzYiCmRhdGU6ICIyMDI2LTA4LTI1IgpvdXRwdXQ6IAogIGh0bWxfZG9jdW1lbnQ6CiAgICB0b2M6IFRSVUUgCiAgICB0b2NfZmxvYXQ6IFRSVUUKICAgIGNvZGVfZG93bmxvYWQ6IFRSVUUKICAgIHRoZW1lOiBzcGFjZWxhYgogICAgCi0tLQoKIVtdKGh0dHBzOi8vbWVkaWEzLmdpcGh5LmNvbS9tZWRpYS92MS5ZMmxrUFRjNU1HSTNOakV4TkdadWFXVndPWEJwT1hKaWREZHFOMnQ0ZW1Gd2FEWmtabWxqYXpVMGJXVm1jWFI2Ym1oMmF5WmxjRDEyTVY5cGJuUmxjbTVoYkY5bmFXWmZZbmxmYVdRbVkzUTlady8xMnZWQUdrYXFIVXFDUS9naXBoeS5naWYpCgojIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+VGVvcsOtYTwvc3Bhbj4KKkFncnVwYW1pZW50byogbyAqQ2x1c3RlcmluZyogZXMgdW5hIHTDqWNuaWNhIGRlIGFwcmVuZGl6YWplIGF1dG9tw6F0aWNvIG5vIHN1cGVydmlzYWRvIHF1ZSBhZ3J1cGEgZGF0b3MgZW4gZnVuY2nDs24gZGUgc3Ugc2ltaWxpdHVkLiAgCgpBbGd1bm9zIHVzb3MgdMOtcGljb3MgZGUgZXN0YSB0w6ljbmljYSBzb246CgoqU2VnbWVudGFjacOzbiBkZSBjbGllbnRlcy4gICAKKkRldGVjY2nDs24gZGUgYW5vbWFsaWRhZGVzLiAgIAoqQ2F0ZWdvcml6YWNpw7NuIGRlIGRvY3VtZW50b3MuICAgCgojIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+SW5zdGFsYXIgcGFxdWV0ZXMgeSBsbGFtYXIgbGlicmVyw61hczwvc3Bhbj4KYGBge3IgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRSwgcGFnZWQucHJpbnQ9RkFMU0V9CgojaW5zdGFsbC5wYWNrYWdlcygiY2x1c3RlciIpCmxpYnJhcnkoY2x1c3RlcikKI2luc3RhbGwucGFja2FnZXMoImdncGxvdDIiKQpsaWJyYXJ5KGdncGxvdDIpCiNpbnN0YWxsLnBhY2thZ2VzKCJkYXRhLnRhYmxlIikKbGlicmFyeShkYXRhLnRhYmxlKQojaW5zdGFsbC5wYWNrYWdlcygiZmFjdG9leHRyYSIpCmxpYnJhcnkoZmFjdG9leHRyYSkKI2luc3RhbGwucGFja2FnZXMoInRpZHlyIikKbGlicmFyeSh0aWR5cikKI2luc3RhbGwucGFja2FnZXMoImRhdGFzZXRzIikKbGlicmFyeShkYXRhc2V0cykKI2luc3RhbGwucGFja2FnZXMoInRpZHl2ZXJzZSIpCmxpYnJhcnkodGlkeXZlcnNlKQpgYGAKCiMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj5FamVyY2ljaW8gMS4gUHVudG9zPC9zcGFuPgojIyA8c3BhbiBzdHlsZT0gImNvbG9yOmJsdWUiPiBDb250ZXh0bzwvc3Bhbj4KQWdydXBhIGxvcyBzaWd1aWVudGVzIDggcHVudG9zLgoKIyMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj4gT2J0ZW5lciBkYXRvczwvc3Bhbj4KYGBge3J9CmRmMSA8LSBkYXRhLmZyYW1lKHg9YygyLDIsOCw1LDcsNiwxLDQpLHk9YygxMCw1LDQsOCw1LDQsMiw5KSkKYGBgCiMjIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+IEVudGVuZGVyIGRhdG9zPC9zcGFuPgpgYGB7cn0Kc3VtbWFyeShkZjEpCnN0cihkZjEpCnBsb3QoZGYxJHgsZGYxJHkpCmBgYAojIyA8c3BhbiBzdHlsZT0gImNvbG9yOmJsdWUiPiBFc2NhbGFyIGRhdG9zIDwvc3Bhbj4KYGBge3J9CiMgZGF0b3NfZXNjYWxhZG9zIDwtIHNjYWxlKGRhdG9zX29yaWdpbmFsZXMpCmBgYAojIyA8c3BhbiBzdHlsZT0gImNvbG9yOmJsdWUiPiBBc2lnbmFyIG7Dum1lcm8gZGUgZ3J1cG9zIDwvc3Bhbj4KYGBge3J9CmdydXBvczEgPC0gMwpgYGAKIyMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj4gQWdydXBhciBsb3MgcHVudG9zIDwvc3Bhbj4KYGBge3J9CnNldC5zZWVkKDEyMykKY2x1c3RlcnMxIDwtIGttZWFucyhkZjEsIGdydXBvczEpCmNsdXN0ZXJzMQpgYGAKCiMjIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+IE9wdGltaXphciBuw7ptZXJvIGRlIGdydXBvcyA8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCm9wdGltaXphY2lvbiA8LSBjbHVzR2FwKGRmMSwgRlVOPWttZWFucywgbnN0YXJ0PTEsIEsubWF4PTcpCiMgRWwgSy5tYXggbm9ybWFsbWVudGUgZXMgMTAsIGVuIGVzdGUgZWplcmNpY2lvIGFsIHNlciA4IGRhdG9zLCBzZSBkZWrDsyBlbiA3CnBsb3Qob3B0aW1pemFjaW9uLCB4bGFiPSJOw7ptZXJvIGRlIGNsc3V0ZXJzIGsiLCBtYWluPSJPcHRpbWl6YWNpw7NuIGRlIGNsdXN0ZXJzIikKIyBTZSBzZWxlY2Npb25hIGNvbW8gw7NwdGltbyBlbCBwcmltZXIgcHVudG8gbcOhcyBhbHRvCiMgU2kgZXMgZGlmZXJlbnRlIGFsIG9yaWdpbmFsLCByZWdyZXNhciB5IGFqdXN0YXIKYGBgCiMjIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+IEdyw6FmaWNhciBsb3MgZ3J1cG9zIDwvc3Bhbj4KYGBge3J9CmZ2aXpfY2x1c3RlcihjbHVzdGVyczEsZGF0YT1kZjEpCmBgYAojIyA8c3BhbiBzdHlsZT0gImNvbG9yOmJsdWUiPiBBZ3JlZ2FyIGdydXBvcyBhIGxhIGJhc2UgZGUgZGF0b3MgPC9zcGFuPgpgYGB7cn0KZGYxX2NsdXN0ZXJzIDwtIGNiaW5kKGRmMSwgY2x1c3Rlcj1jbHVzdGVyczEkY2x1c3RlcikKaGVhZChkZjFfY2x1c3RlcnMpCmBgYAojIyA8c3BhbiBzdHlsZT0gImNvbG9yOmJsdWUiPiBDb25sdXNpb25lcyA8L3NwYW4+CkxhIHTDqWNuaWNhIGRlICoqY2x1c3RlcmluZyoqIHBlcm1pdGUgaWRlbnRpZmljYXIgcGF0cm9uZXMgbyBncnVwb3MgbmF0dXJhbGVzIGVuIGxvcyBkYXRvcyBzaW4gbmVjZXNpZGFkIGRlIGV0aXF1ZXRhcyBwcmV2aWFzLgoKCiMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj5FamVyY2ljaW8gMi4gVVNBcnJlc3QgPC9zcGFuPgojIyA8c3BhbiBzdHlsZT0gImNvbG9yOmJsdWUiPiBDb250ZXh0byA8L3NwYW4+CkxhIGJhc2UgZGUgZGF0b3MgZGUgKipVU0FycmVzdCoqIGNvbnRpZW5lIGVzdGFkw61zdGljYXMgZW4gYXJyZXN0b3MgcG9yIGNhZGEgMTAwLDAwMCByZXNpZGVudGVzIHBvciBhZ3Jlc2nDs24sIGFzZXNpbmF0byB5IHZpb2xhY2nDs24gZW4gY2FkYSB1bm8gZGUgbG9zIDUwIGVzdGFkb3MgZGUgRUUuVVUuIGVuIDE5NzMuCgoKIyMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj4gT2J0ZW5lciBkYXRvczwvc3Bhbj4KYGBge3J9CmRmMiA8LSBVU0FycmVzdHMKZGYyIDwtIGRmMiAlPiUgc2VsZWN0ICgtVXJiYW5Qb3ApCmBgYAojIyA8c3BhbiBzdHlsZT0gImNvbG9yOmJsdWUiPiBFbnRlbmRlciBkYXRvczwvc3Bhbj4KYGBge3J9CnN1bW1hcnkoZGYyKQpzdHIoZGYyKQpgYGAKIyMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj4gRXNjYWxhciBkYXRvcyA8L3NwYW4+CmBgYHtyfQpkZjJfZXNjYWxhZG9zIDwtIHNjYWxlKGRmMikKc3VtbWFyeShkZjJfZXNjYWxhZG9zKQpgYGAKIyMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj4gQXNpZ25hciBuw7ptZXJvIGRlIGdydXBvcyA8L3NwYW4+CmBgYHtyfQpncnVwb3MyIDwtIDUKYGBgCiMjIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+IEFncnVwYXIgbG9zIHB1bnRvcyA8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCmNsdXN0ZXJzMiA8LSBrbWVhbnMoZGYyX2VzY2FsYWRvcywgZ3J1cG9zMikKYGBgCiMjIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+IE9wdGltaXphciBuw7ptZXJvIGRlIGdydXBvcyA8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCm9wdGltaXphY2lvbiA8LSBjbHVzR2FwKGRmMl9lc2NhbGFkb3MsIEZVTj1rbWVhbnMsIG5zdGFydD0xLCBLLm1heD0xMCkKIyBFbCBLLm1heCBub3JtYWxtZW50ZSBlcyAxMCwgZW4gZXN0ZSBlamVyY2ljaW8gYWwgc2VyIDggZGF0b3MsIHNlIGRlasOzIGVuIDcKcGxvdChvcHRpbWl6YWNpb24sIHhsYWI9Ik7Dum1lcm8gZGUgY2xzdXRlcnMgayIsIG1haW49Ik9wdGltaXphY2nDs24gZGUgY2x1c3RlcnMiKQojIFNlIHNlbGVjY2lvbmEgY29tbyDDs3B0aW1vIGVsIHByaW1lciBwdW50byBtw6FzIGFsdG8KIyBTaSBlcyBkaWZlcmVudGUgYWwgb3JpZ2luYWwsIHJlZ3Jlc2FyIHkgYWp1c3RhcgpgYGAKCiMjIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+IEdyw6FmaWNhciBsb3MgZ3J1cG9zIDwvc3Bhbj4KYGBge3J9CmZ2aXpfY2x1c3RlcihjbHVzdGVyczIsZGF0YT1kZjJfZXNjYWxhZG9zKQpgYGAKIyMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj4gQWdyZWdhciBncnVwb3MgYSBsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4KCgpgYGB7cn0KZGYyX2NsdXN0ZXJzIDwtIGNiaW5kKGRmMiwgY2x1c3Rlcj1jbHVzdGVyczIkY2x1c3RlcikKaGVhZChkZjJfY2x1c3RlcnMpCgpkZjJfY2x1c3RlcnMgJT4lIGdyb3VwX2J5IChjbHVzdGVyKSAlPiUgc3VtbWFyaXNlX2FsbChtZWFuKSAlPiUgbXV0YXRlKGluZGljYWRvcl9pbnNlZ3VyaWRhZD1NdXJkZXIrQXNzYXVsdCtSYXBlKQoKCmRmMl9jbHVzdGVyczwtIGRmMl9jbHVzdGVycyAlPiUKICBtdXRhdGUoY2x1c3Rlcj1jYXNlX3doZW4oCiAgICBjbHVzdGVyID09IDEgfiAiSW5zZWd1cmlkYWQgTXV5IEFsdGEiLAogICAgY2x1c3RlciA9PSA0IH4gIkluc2VndXJpZGFkIEFsdGEiLAogICAgY2x1c3RlciA9PSA1IH4gIkluc2VndXJpZGFkIE1lZGlhIiwKICAgIGNsdXN0ZXIgPT0gMyB+ICJJbnNlZ3VyaWRhZCBCYWphIiwKICAgIGNsdXN0ZXIgPT0gMiB+ICJJbnNlZ3VyaWRhZCBNdXkgQmFqYSIKICApKQpgYGAKCgojIDxzcGFuIHN0eWxlPSAiY29sb3I6Ymx1ZSI+RWplcmNpY2lvIDMuIFNlZ21lbnRhY2nDs24gZGUgQ2xpZW50ZXMgPC9zcGFuPgoKIyMgPHNwYW4gc3R5bGU9ICJjb2xvcjpibHVlIj4gQ29udGV4dG8gPC9zcGFuPgpMYSBiYXNlIGRlIGRhdG9zICoqdmVudGFzKiogdGllbmUgbG9zIHJlZ2lzdHJvcyBlbnRyZSBlbCAwMSBkZSBkaWNpZW1icmUgZGUgMjAxMCB5IGVsIDA5IGRlIGRpY2llbWJyZSBkZSAyMDExIGRlIGxhcyB2ZW50YXMgZGUgdW5hIGVtcHJlc2EgbWlub3Jpc3RhIGVuIGzDrW5lYSBzaW4gdGllbmRhIGbDrXNpY2EsIGJhc2FkYSBlbiBSZWlubyBVbmlkby4gIApMYSBlbXByZXNhIHZlbmZlIHByaW5jaXBhbG1lbnRlIHJlZ2Fsb3Mgw7puaWNvcyBwYXJhIHRvZGEgb2Nhc2nDs24sIHkgbXVjaG9zIGRlIHN1cyBjbGllbnRlcyBzb24gbWF5b3Jpc3Rhcy4gIApPYmpldGl2bzogU2VnbWVudGFyIGNsaWVudGVzLCBhc2lnbmF0bGVzIG5vbWJyZSB5IGNhcmFjdGVyw61zdGljYXMgZGUgY29tcG9ydGFtaWVudG8sIHkgcHJvcG9uZXIgc3VnZXJlbmNpYXMgYSBsYSBlbXByZXNhIHBhcmEgYXVtZW50YXIgdmVudGFzLgoKCg==