Teoría

Clustering es una técnica de aprendizaje no supervisado que agrupa observaciones según su similitud.

En este caso lo usaremos para segmentar clientes según:

Frecuencia de compra

Ticket promedio

Esto nos ayudará a generar estrategias de marketing personalizadas.

Paso 1. Librerías

# install.packages("tidyverse")
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.2.0     ✔ readr     2.1.6
## ✔ forcats   1.0.1     ✔ stringr   1.6.0
## ✔ ggplot2   4.0.2     ✔ tibble    3.3.1
## ✔ lubridate 1.9.5     ✔ tidyr     1.3.2
## ✔ purrr     1.2.1     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
# install.packages("cluster")
library(cluster)

# install.packages("factoextra")
library(factoextra)
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa
# install.packages("lubridate")
library(lubridate)
library(readxl)

Paso 2. Cargar datos

df <- read_excel("/Users/samanthagarcia/Desktop/supermarket.xlsx")
## Warning: Expecting numeric in A522063 / R522063C1: got 'A563185'
## Warning: Expecting numeric in A522064 / R522064C1: got 'A563186'
## Warning: Expecting numeric in A522065 / R522065C1: got 'A563187'
head(df)
## # A tibble: 6 × 8
##   BillNo Itemname         Quantity Date                Time                Price
##    <dbl> <chr>               <dbl> <dttm>              <dttm>              <dbl>
## 1 536365 WHITE HANGING H…        6 2010-12-01 00:00:00 1899-12-31 08:26:00  2.55
## 2 536365 WHITE METAL LAN…        6 2010-12-01 00:00:00 1899-12-31 08:26:00  3.39
## 3 536365 CREAM CUPID HEA…        8 2010-12-01 00:00:00 1899-12-31 08:26:00  2.75
## 4 536365 KNITTED UNION F…        6 2010-12-01 00:00:00 1899-12-31 08:26:00  3.39
## 5 536365 RED WOOLLY HOTT…        6 2010-12-01 00:00:00 1899-12-31 08:26:00  3.39
## 6 536365 SET 7 BABUSHKA …        2 2010-12-01 00:00:00 1899-12-31 08:26:00  7.65
## # ℹ 2 more variables: CustomerID <dbl>, Country <chr>
df$Total <- df$Quantity * df$Price

Paso 4. Crear variables para clustering

Vamos a calcular:

Frecuencia de compra por cliente

Ticket promedio por cliente

clientes <- df %>%
  group_by(CustomerID) %>%
  summarise(
    Frecuencia = n_distinct(BillNo),
    TicketPromedio = mean(Total)
  )

head(clientes)
## # A tibble: 6 × 3
##   CustomerID Frecuencia TicketPromedio
##        <dbl>      <int>          <dbl>
## 1      12346          1        77184. 
## 2      12347          7           23.7
## 3      12349          1           24.1
## 4      12350          1           19.7
## 5      12352          8           29.5
## 6      12353          1           22.2

Paso 5. Estadística descriptiva

summary(clientes)
##    CustomerID      Frecuencia      TicketPromedio    
##  Min.   :12346   Min.   :   1.00   Min.   :    0.00  
##  1st Qu.:13831   1st Qu.:   1.00   1st Qu.:   12.24  
##  Median :15321   Median :   2.00   Median :   17.67  
##  Mean   :15316   Mean   :   5.04   Mean   :   68.38  
##  3rd Qu.:16790   3rd Qu.:   5.00   3rd Qu.:   24.69  
##  Max.   :18287   Max.   :3498.00   Max.   :77183.60  
##  NA's   :1
sd(clientes$Frecuencia)
## [1] 53.76148
sd(clientes$TicketPromedio)
## [1] 1474.699

Paso 6. Estandarizar datos

clientes_scaled <- scale(clientes[,2:3])

Paso 7. Optimizar número de clusters

fviz_nbclust(clientes_scaled, kmeans, method = "wss") +
  labs(title="Método del Codo") +
  theme_minimal()

Paso 8. Crear 4 clusters

set.seed(123)

k4 <- kmeans(clientes_scaled, centers = 4, nstart = 25)

clientes$Cluster <- as.factor(k4$cluster)

Paso 9. Visualización

ggplot(clientes, aes(x=Frecuencia, y=TicketPromedio, color=Cluster)) +
  geom_point(size=3, alpha=0.7) +
  theme_minimal() +
  labs(
    title="Segmentación de Clientes",
    x="Frecuencia de Compra",
    y="Ticket Promedio"
  )

Características por Cluster

clientes <- clientes %>%
  mutate(
    NombreCluster = case_when(
      Cluster == 1 ~ "Clientes Premium",
      Cluster == 2 ~ "Clientes Frecuentes",
      Cluster == 3 ~ "Clientes Ocasionales",
      Cluster == 4 ~ "Clientes Bajo Valor"
    )
  )

clientes %>%
  group_by(NombreCluster) %>%
  summarise(
    Frecuencia_Promedio = mean(Frecuencia),
    Ticket_Promedio = mean(TicketPromedio)
  )
## # A tibble: 4 × 3
##   NombreCluster        Frecuencia_Promedio Ticket_Promedio
##   <chr>                              <dbl>           <dbl>
## 1 Clientes Bajo Valor                 4.02            29.9
## 2 Clientes Frecuentes                 1.5          66671. 
## 3 Clientes Ocasionales               56.3           1911. 
## 4 Clientes Premium                 3498               12.8

Recomendaciones

Clientes Premium → Programas VIP y recompensas exclusivas

Clientes Frecuentes → Promociones por volumen

Clientes Ocasionales → Descuentos personalizados

Clientes Bajo Valor → Campañas de reactivación

LS0tCnRpdGxlOiAiQWJhcnJvdGVzIENsdXN0ZXJpbmciCmF1dGhvcjogIlNhbWFudGhhIEdhcmNpYSBaYW1icmFubyBBMDA4NDA0MDgiCmRhdGU6ICIyMDI2LTAyLTIzIgpvdXRwdXQ6IAogIGh0bWxfZG9jdW1lbnQ6CiAgICB0b2M6IFRSVUUKICAgIHRvY19mbG9hdDogVFJVRQogICAgY29kZV9kb3dubG9hZDogVFJVRQogICAgdGhlbWU6IHNwYWNlbGFiCi0tLQoKIVtdKGh0dHBzOi8vaW1nLmFzbWVkaWEuZXBpbWcubmV0L3Jlc2l6ZXIvdjIvQUVSUU1BUlFGTkJBQktBNFU1T0E3SVU0NUUuanBlZz9hdXRoPTk1MTY3NWJiMjYxNzgxMmNhZDNjZWUwNjdkYTFjZTMwNDBkNTk3YTIzMTYwM2EzOTRmMWFjOGNmMTNhZWIxNWQmd2lkdGg9MTQ3MiZoZWlnaHQ9ODI4JnNtYXJ0PXRydWUpCgojIDxzcGFuIHN0eWxlPSJjb2xvcjojMEIzQzVEOyI+VGVvcsOtYTwvc3Bhbj4KCkNsdXN0ZXJpbmcgZXMgdW5hIHTDqWNuaWNhIGRlIGFwcmVuZGl6YWplIG5vIHN1cGVydmlzYWRvIHF1ZSBhZ3J1cGEgb2JzZXJ2YWNpb25lcyBzZWfDum4gc3Ugc2ltaWxpdHVkLgoKRW4gZXN0ZSBjYXNvIGxvIHVzYXJlbW9zIHBhcmEgc2VnbWVudGFyIGNsaWVudGVzIHNlZ8O6bjoKCkZyZWN1ZW5jaWEgZGUgY29tcHJhCgpUaWNrZXQgcHJvbWVkaW8KCkVzdG8gbm9zIGF5dWRhcsOhIGEgZ2VuZXJhciBlc3RyYXRlZ2lhcyBkZSBtYXJrZXRpbmcgcGVyc29uYWxpemFkYXMuCgojIDxzcGFuIHN0eWxlPSJjb2xvcjojMUQ0RTg5OyI+UGFzbyAxLiBMaWJyZXLDrWFzPC9zcGFuPgpgYGB7cn0KIyBpbnN0YWxsLnBhY2thZ2VzKCJ0aWR5dmVyc2UiKQpsaWJyYXJ5KHRpZHl2ZXJzZSkKCiMgaW5zdGFsbC5wYWNrYWdlcygiY2x1c3RlciIpCmxpYnJhcnkoY2x1c3RlcikKCiMgaW5zdGFsbC5wYWNrYWdlcygiZmFjdG9leHRyYSIpCmxpYnJhcnkoZmFjdG9leHRyYSkKCiMgaW5zdGFsbC5wYWNrYWdlcygibHVicmlkYXRlIikKbGlicmFyeShsdWJyaWRhdGUpCmxpYnJhcnkocmVhZHhsKQpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiMxRDRFODk7Ij5QYXNvIDIuIENhcmdhciBkYXRvczwvc3Bhbj4KYGBge3J9CmRmIDwtIHJlYWRfZXhjZWwoIi9Vc2Vycy9zYW1hbnRoYWdhcmNpYS9EZXNrdG9wL3N1cGVybWFya2V0Lnhsc3giKQoKaGVhZChkZikKZGYkVG90YWwgPC0gZGYkUXVhbnRpdHkgKiBkZiRQcmljZQpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiMxRDRFODk7Ij5QYXNvIDQuIENyZWFyIHZhcmlhYmxlcyBwYXJhIGNsdXN0ZXJpbmc8L3NwYW4+ClZhbW9zIGEgY2FsY3VsYXI6CgpGcmVjdWVuY2lhIGRlIGNvbXByYSBwb3IgY2xpZW50ZQoKVGlja2V0IHByb21lZGlvIHBvciBjbGllbnRlCgpgYGB7cn0KY2xpZW50ZXMgPC0gZGYgJT4lCiAgZ3JvdXBfYnkoQ3VzdG9tZXJJRCkgJT4lCiAgc3VtbWFyaXNlKAogICAgRnJlY3VlbmNpYSA9IG5fZGlzdGluY3QoQmlsbE5vKSwKICAgIFRpY2tldFByb21lZGlvID0gbWVhbihUb3RhbCkKICApCgpoZWFkKGNsaWVudGVzKQpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiMxRDRFODk7Ij5QYXNvIDUuIEVzdGFkw61zdGljYSBkZXNjcmlwdGl2YTwvc3Bhbj4KYGBge3J9CnN1bW1hcnkoY2xpZW50ZXMpCgpzZChjbGllbnRlcyRGcmVjdWVuY2lhKQpzZChjbGllbnRlcyRUaWNrZXRQcm9tZWRpbykKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjojMUQ0RTg5OyI+UGFzbyA2LiBFc3RhbmRhcml6YXIgZGF0b3M8L3NwYW4+CmBgYHtyfQpjbGllbnRlc19zY2FsZWQgPC0gc2NhbGUoY2xpZW50ZXNbLDI6M10pCmBgYAoKIyA8c3BhbiBzdHlsZT0iY29sb3I6IzFENEU4OTsiPlBhc28gNy4gT3B0aW1pemFyIG7Dum1lcm8gZGUgY2x1c3RlcnM8L3NwYW4+CmBgYHtyfQpmdml6X25iY2x1c3QoY2xpZW50ZXNfc2NhbGVkLCBrbWVhbnMsIG1ldGhvZCA9ICJ3c3MiKSArCiAgbGFicyh0aXRsZT0iTcOpdG9kbyBkZWwgQ29kbyIpICsKICB0aGVtZV9taW5pbWFsKCkKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjojMUQ0RTg5OyI+UGFzbyA4LiBDcmVhciA0IGNsdXN0ZXJzPC9zcGFuPgpgYGB7cn0Kc2V0LnNlZWQoMTIzKQoKazQgPC0ga21lYW5zKGNsaWVudGVzX3NjYWxlZCwgY2VudGVycyA9IDQsIG5zdGFydCA9IDI1KQoKY2xpZW50ZXMkQ2x1c3RlciA8LSBhcy5mYWN0b3IoazQkY2x1c3RlcikKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjojMUQ0RTg5OyI+UGFzbyA5LiBWaXN1YWxpemFjacOzbjwvc3Bhbj4KYGBge3J9CmdncGxvdChjbGllbnRlcywgYWVzKHg9RnJlY3VlbmNpYSwgeT1UaWNrZXRQcm9tZWRpbywgY29sb3I9Q2x1c3RlcikpICsKICBnZW9tX3BvaW50KHNpemU9MywgYWxwaGE9MC43KSArCiAgdGhlbWVfbWluaW1hbCgpICsKICBsYWJzKAogICAgdGl0bGU9IlNlZ21lbnRhY2nDs24gZGUgQ2xpZW50ZXMiLAogICAgeD0iRnJlY3VlbmNpYSBkZSBDb21wcmEiLAogICAgeT0iVGlja2V0IFByb21lZGlvIgogICkKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjojMEIzQzVEOyI+Q2FyYWN0ZXLDrXN0aWNhcyBwb3IgQ2x1c3Rlcjwvc3Bhbj4KYGBge3J9CmNsaWVudGVzIDwtIGNsaWVudGVzICU+JQogIG11dGF0ZSgKICAgIE5vbWJyZUNsdXN0ZXIgPSBjYXNlX3doZW4oCiAgICAgIENsdXN0ZXIgPT0gMSB+ICJDbGllbnRlcyBQcmVtaXVtIiwKICAgICAgQ2x1c3RlciA9PSAyIH4gIkNsaWVudGVzIEZyZWN1ZW50ZXMiLAogICAgICBDbHVzdGVyID09IDMgfiAiQ2xpZW50ZXMgT2Nhc2lvbmFsZXMiLAogICAgICBDbHVzdGVyID09IDQgfiAiQ2xpZW50ZXMgQmFqbyBWYWxvciIKICAgICkKICApCgpjbGllbnRlcyAlPiUKICBncm91cF9ieShOb21icmVDbHVzdGVyKSAlPiUKICBzdW1tYXJpc2UoCiAgICBGcmVjdWVuY2lhX1Byb21lZGlvID0gbWVhbihGcmVjdWVuY2lhKSwKICAgIFRpY2tldF9Qcm9tZWRpbyA9IG1lYW4oVGlja2V0UHJvbWVkaW8pCiAgKQpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiMwQjNDNUQ7Ij4gUmVjb21lbmRhY2lvbmVzPC9zcGFuPgpDbGllbnRlcyBQcmVtaXVtCuKGkiBQcm9ncmFtYXMgVklQIHkgcmVjb21wZW5zYXMgZXhjbHVzaXZhcwoKQ2xpZW50ZXMgRnJlY3VlbnRlcwrihpIgUHJvbW9jaW9uZXMgcG9yIHZvbHVtZW4KCkNsaWVudGVzIE9jYXNpb25hbGVzCuKGkiBEZXNjdWVudG9zIHBlcnNvbmFsaXphZG9zCgpDbGllbnRlcyBCYWpvIFZhbG9yCuKGkiBDYW1wYcOxYXMgZGUgcmVhY3RpdmFjacOzbgoKCg==