Análisis Técnico y EDA Taller 1 Nata Supermarket
Docente: Rodrigo Taborda | Incertidumbre y Análsis de Datos | Grupo: Viernes 6:00p.m
Jeiner Velandia - Doctorando Gestión Innovación Tecnologica- Nodo Innovación
2026-08-16
# Opciones knit y repos
knitr::opts_chunk$set(echo = TRUE, message = FALSE, warning = FALSE)
options(repos = c(CRAN = "https://cloud.r-project.org/"))
# Reproducibilidad y estética
set.seed(123)
library(ggplot2)
theme_set(theme_minimal(base_size = 13))
library(tidyverse)
library(readxl)
library(lubridate)
library(mclust)
knitr::opts_chunk$set(
echo = TRUE,
warning = FALSE,
message = FALSE
)Introducción
Este documento presenta el proceso de preparación, análisis exploratorio, clusterización y perfilamiento de los clientes de Nata Supermarkets.
Fase 1. Preparación de los datos
1. Carga de datos
Se cargan las librerías necesarias para el análisis y posteriormente se importa la base de datos desde un archivo Excel.
# Cargar el archivo Excel del caso Nata Supermarkets
raw_data <- read_excel("NATA SUPERMARKET.xlsx")
# Inspección de estructura general
glimpse(raw_data)## Rows: 2,240
## Columns: 29
## $ ID <dbl> 5524, 2174, 4141, 6182, 5324, 7446, 965, 6177, 485…
## $ Year_Birth <dbl> 1957, 1954, 1965, 1984, 1981, 1967, 1971, 1985, 19…
## $ Education <chr> "Graduation", "Graduation", "Graduation", "Graduat…
## $ Marital_Status <chr> "Single", "Single", "Together", "Together", "Marri…
## $ Income <dbl> 58138, 46344, 71613, 26646, 58293, 62513, 55635, 3…
## $ Kidhome <dbl> 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 0, 0, 1, 0, 0, 1,…
## $ Teenhome <dbl> 0, 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1,…
## $ Dt_Customer <chr> "41008", "41854", "21-08-2013", "41914", "19-01-20…
## $ Recency <dbl> 58, 38, 26, 26, 94, 16, 34, 32, 19, 68, 11, 59, 82…
## $ MntWines <dbl> 635, 11, 426, 11, 173, 520, 235, 76, 14, 28, 5, 6,…
## $ MntFruits <dbl> 88, 1, 49, 4, 43, 42, 65, 10, 0, 0, 5, 16, 61, 2, …
## $ MntMeatProducts <dbl> 546, 6, 127, 20, 118, 98, 164, 56, 24, 6, 6, 11, 4…
## $ MntFishProducts <dbl> 172, 2, 111, 10, 46, 0, 50, 3, 3, 1, 0, 11, 225, 3…
## $ MntSweetProducts <dbl> 88, 1, 21, 3, 27, 42, 49, 1, 3, 1, 2, 1, 112, 5, 1…
## $ MntGoldProds <dbl> 88, 6, 42, 5, 15, 14, 27, 23, 2, 13, 1, 16, 30, 14…
## $ NumDealsPurchases <dbl> 3, 2, 1, 2, 5, 2, 4, 2, 1, 1, 1, 1, 1, 3, 1, 1, 3,…
## $ NumWebPurchases <dbl> 8, 1, 8, 2, 5, 6, 7, 4, 3, 1, 1, 2, 3, 6, 1, 7, 3,…
## $ NumCatalogPurchases <dbl> 10, 1, 2, 0, 3, 4, 3, 0, 0, 0, 0, 0, 4, 1, 0, 6, 0…
## $ NumStorePurchases <dbl> 4, 2, 10, 4, 6, 10, 7, 4, 2, 0, 2, 3, 8, 5, 3, 12,…
## $ NumWebVisitsMonth <dbl> 7, 5, 4, 6, 5, 6, 6, 8, 9, 20, 7, 8, 2, 6, 8, 3, 8…
## $ AcceptedCmp3 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0,…
## $ AcceptedCmp4 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ AcceptedCmp5 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0,…
## $ AcceptedCmp1 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0,…
## $ AcceptedCmp2 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ Complain <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ Z_CostContact <dbl> 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,…
## $ Z_Revenue <dbl> 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11…
## $ Response <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0,…2. Revisión de datos faltantes
Se revisa la cantidad de valores faltantes en cada columna.
Tb1 <- colSums(is.na(raw_data))
knitr::kable(Tb1)| x | |
|---|---|
| ID | 0 |
| Year_Birth | 0 |
| Education | 0 |
| Marital_Status | 0 |
| Income | 24 |
| Kidhome | 0 |
| Teenhome | 0 |
| Dt_Customer | 0 |
| Recency | 0 |
| MntWines | 0 |
| MntFruits | 0 |
| MntMeatProducts | 0 |
| MntFishProducts | 0 |
| MntSweetProducts | 0 |
| MntGoldProds | 0 |
| NumDealsPurchases | 0 |
| NumWebPurchases | 0 |
| NumCatalogPurchases | 0 |
| NumStorePurchases | 0 |
| NumWebVisitsMonth | 0 |
| AcceptedCmp3 | 0 |
| AcceptedCmp4 | 0 |
| AcceptedCmp5 | 0 |
| AcceptedCmp1 | 0 |
| AcceptedCmp2 | 0 |
| Complain | 0 |
| Z_CostContact | 0 |
| Z_Revenue | 0 |
| Response | 0 |
3. Formato e imputación de datos
Se realiza la imputación de la variable Income, se
estandariza el formato de la variable Dt_Customer y se
excluyen las variables sin variabilidad.
DF1 <- raw_data |>
mutate(
# Imputación por mediana en Income
Income = replace_na(
Income,
median(Income, na.rm = TRUE)
),
# Estandarización del formato de fechas
Dt_Customer = coalesce(
as.Date(
suppressWarnings(as.numeric(Dt_Customer)),
origin = "1899-12-30"
),
dmy(Dt_Customer)
)
) |>
select(
-Z_CostContact,
-Z_Revenue
)Se verifica nuevamente la presencia de valores faltantes después del tratamiento inicial.
Tb1 <- colSums(is.na(DF1))
knitr::kable(Tb1)| x | |
|---|---|
| ID | 0 |
| Year_Birth | 0 |
| Education | 0 |
| Marital_Status | 0 |
| Income | 0 |
| Kidhome | 0 |
| Teenhome | 0 |
| Dt_Customer | 0 |
| Recency | 0 |
| MntWines | 0 |
| MntFruits | 0 |
| MntMeatProducts | 0 |
| MntFishProducts | 0 |
| MntSweetProducts | 0 |
| MntGoldProds | 0 |
| NumDealsPurchases | 0 |
| NumWebPurchases | 0 |
| NumCatalogPurchases | 0 |
| NumStorePurchases | 0 |
| NumWebVisitsMonth | 0 |
| AcceptedCmp3 | 0 |
| AcceptedCmp4 | 0 |
| AcceptedCmp5 | 0 |
| AcceptedCmp1 | 0 |
| AcceptedCmp2 | 0 |
| Complain | 0 |
| Response | 0 |
4. Estadísticos descriptivos
Se calculan estadísticos descriptivos para las variables
cuantitativas: Income, Recency, las variables
que comienzan por Mnt y las que comienzan por
Num.
install.packages("kableExtra")##
## The downloaded binary packages are in
## /var/folders/js/snv71yns0rjczmz19sc55bz80000gp/T//RtmpqeBrH7/downloaded_packagesDESCRIPT_CUANTI <- DF1 |>
select(
Income,
Recency,
starts_with("Mnt"),
starts_with("Num")
) |>
summary()
knitr::kable(
DESCRIPT_CUANTI,
digits = 2,
format = "html",
align = "c"
) |>
kableExtra::kable_styling(
bootstrap_options = c("striped", "hover", "responsive"),
full_width = TRUE,
position = "center",
font_size = 11
) |>
kableExtra::row_spec(
0,
bold = TRUE
)| Income | Recency | MntWines | MntFruits | MntMeatProducts | MntFishProducts | MntSweetProducts | MntGoldProds | NumDealsPurchases | NumWebPurchases | NumCatalogPurchases | NumStorePurchases | NumWebVisitsMonth | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Min. : 1730 | Min. : 0.00 | Min. : 0.00 | Min. : 0.0 | Min. : 0.0 | Min. : 0.00 | Min. : 0.00 | Min. : 0.00 | Min. : 0.000 | Min. : 0.000 | Min. : 0.000 | Min. : 0.00 | Min. : 0.000 | |
| 1st Qu.: 35539 | 1st Qu.:24.00 | 1st Qu.: 23.75 | 1st Qu.: 1.0 | 1st Qu.: 16.0 | 1st Qu.: 3.00 | 1st Qu.: 1.00 | 1st Qu.: 9.00 | 1st Qu.: 1.000 | 1st Qu.: 2.000 | 1st Qu.: 0.000 | 1st Qu.: 3.00 | 1st Qu.: 3.000 | |
| Median : 51382 | Median :49.00 | Median : 173.50 | Median : 8.0 | Median : 67.0 | Median : 12.00 | Median : 8.00 | Median : 24.00 | Median : 2.000 | Median : 4.000 | Median : 2.000 | Median : 5.00 | Median : 6.000 | |
| Mean : 52238 | Mean :49.11 | Mean : 303.94 | Mean : 26.3 | Mean : 166.9 | Mean : 37.53 | Mean : 27.06 | Mean : 44.02 | Mean : 2.325 | Mean : 4.085 | Mean : 2.662 | Mean : 5.79 | Mean : 5.317 | |
| 3rd Qu.: 68290 | 3rd Qu.:74.00 | 3rd Qu.: 504.25 | 3rd Qu.: 33.0 | 3rd Qu.: 232.0 | 3rd Qu.: 50.00 | 3rd Qu.: 33.00 | 3rd Qu.: 56.00 | 3rd Qu.: 3.000 | 3rd Qu.: 6.000 | 3rd Qu.: 4.000 | 3rd Qu.: 8.00 | 3rd Qu.: 7.000 | |
| Max. :666666 | Max. :99.00 | Max. :1493.00 | Max. :199.0 | Max. :1725.0 | Max. :259.00 | Max. :263.00 | Max. :362.00 | Max. :15.000 | Max. :27.000 | Max. :28.000 | Max. :13.00 | Max. :20.000 |
5. Tratamiento de valores anómalos
Se identifica un valor de 666666 en Income.
Se realiza una nueva imputación utilizando la mediana de los valores
inferiores a 600000.
DF1 <- DF1 |>
mutate(
Income = if_else(
Income == 666666,
median(
Income[Income < 600000],
na.rm = TRUE
),
Income
)
)También se realiza el tratamiento de los valores anómalos
identificados en Year_Birth.
DF1 <- DF1 |>
mutate(
Year_Birth = if_else(
Year_Birth < 1940,
median(Year_Birth[Year_Birth >= 1940]),
Year_Birth
)
)Se vuelven a calcular los estadísticos descriptivos.
DESCRIPT_CUANTI <- DF1 |>
select(
Income,
Recency,
starts_with("Mnt"),
starts_with("Num")
) |>
summary()
knitr::kable(
DESCRIPT_CUANTI,
digits = 2,
format = "html",
align = "c"
) |>
kableExtra::kable_styling(
bootstrap_options = c("striped", "hover", "responsive"),
full_width = TRUE,
position = "center",
font_size = 11
) |>
kableExtra::row_spec(
0,
bold = TRUE
)| Income | Recency | MntWines | MntFruits | MntMeatProducts | MntFishProducts | MntSweetProducts | MntGoldProds | NumDealsPurchases | NumWebPurchases | NumCatalogPurchases | NumStorePurchases | NumWebVisitsMonth | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Min. : 1730 | Min. : 0.00 | Min. : 0.00 | Min. : 0.0 | Min. : 0.0 | Min. : 0.00 | Min. : 0.00 | Min. : 0.00 | Min. : 0.000 | Min. : 0.000 | Min. : 0.000 | Min. : 0.00 | Min. : 0.000 | |
| 1st Qu.: 35539 | 1st Qu.:24.00 | 1st Qu.: 23.75 | 1st Qu.: 1.0 | 1st Qu.: 16.0 | 1st Qu.: 3.00 | 1st Qu.: 1.00 | 1st Qu.: 9.00 | 1st Qu.: 1.000 | 1st Qu.: 2.000 | 1st Qu.: 0.000 | 1st Qu.: 3.00 | 1st Qu.: 3.000 | |
| Median : 51382 | Median :49.00 | Median : 173.50 | Median : 8.0 | Median : 67.0 | Median : 12.00 | Median : 8.00 | Median : 24.00 | Median : 2.000 | Median : 4.000 | Median : 2.000 | Median : 5.00 | Median : 6.000 | |
| Mean : 51963 | Mean :49.11 | Mean : 303.94 | Mean : 26.3 | Mean : 166.9 | Mean : 37.53 | Mean : 27.06 | Mean : 44.02 | Mean : 2.325 | Mean : 4.085 | Mean : 2.662 | Mean : 5.79 | Mean : 5.317 | |
| 3rd Qu.: 68276 | 3rd Qu.:74.00 | 3rd Qu.: 504.25 | 3rd Qu.: 33.0 | 3rd Qu.: 232.0 | 3rd Qu.: 50.00 | 3rd Qu.: 33.00 | 3rd Qu.: 56.00 | 3rd Qu.: 3.000 | 3rd Qu.: 6.000 | 3rd Qu.: 4.000 | 3rd Qu.: 8.00 | 3rd Qu.: 7.000 | |
| Max. :162397 | Max. :99.00 | Max. :1493.00 | Max. :199.0 | Max. :1725.0 | Max. :259.00 | Max. :263.00 | Max. :362.00 | Max. :15.000 | Max. :27.000 | Max. :28.000 | Max. :13.00 | Max. :20.000 |
6. Tablas de frecuencia
Se calculan las frecuencias para las variables de educación y estado civil.
FRECUENCIAS <- list(
Educacion = DF1 |>
dplyr::count(Education, sort = TRUE) |>
mutate(Pct = round(n / sum(n) * 100, 2)),
Estado_Civil = DF1 |>
dplyr::count(Marital_Status, sort = TRUE) |>
mutate(Pct = round(n / sum(n) * 100, 2))
)
# Tabla de frecuencia: Educación
knitr::kable(
FRECUENCIAS$Educacion,
format = "html",
align = "c",
caption = "Distribución de los clientes según nivel educativo"
) |>
kableExtra::kable_styling(
bootstrap_options = c("striped", "hover", "bordered"),
full_width = FALSE,
position = "center",
font_size = 14
) |>
kableExtra::row_spec(
0,
bold = TRUE
)| Education | n | Pct |
|---|---|---|
| Graduation | 1127 | 50.31 |
| PhD | 486 | 21.70 |
| Master | 370 | 16.52 |
| 2n Cycle | 203 | 9.06 |
| Basic | 54 | 2.41 |
# Tabla de frecuencia: Estado civil
knitr::kable(
FRECUENCIAS$Estado_Civil,
format = "html",
align = "c",
caption = "Distribución de los clientes según estado civil"
) |>
kableExtra::kable_styling(
bootstrap_options = c("striped", "hover", "bordered"),
full_width = FALSE,
position = "center",
font_size = 14
) |>
kableExtra::row_spec(
0,
bold = TRUE
)| Marital_Status | n | Pct |
|---|---|---|
| Married | 864 | 38.57 |
| Together | 580 | 25.89 |
| Single | 480 | 21.43 |
| Divorced | 232 | 10.36 |
| Widow | 77 | 3.44 |
| Alone | 3 | 0.13 |
| Absurd | 2 | 0.09 |
| YOLO | 2 | 0.09 |
Se calculan también los porcentajes correspondientes a las variables binarias relacionadas con conversión de campañas y quejas.
BINARIO <- DF1 |>
summarise(
across(
c(
starts_with("Accepted"),
Response,
Complain
),
\(x) round(mean(x) * 100, 2)
)
) |>
pivot_longer(
cols = everything(),
names_to = "Indicador",
values_to = "Tasa_Porcentaje"
)
knitr::kable(
BINARIO,
digits = 2,
format = "html",
align = "c"
) |>
kableExtra::kable_styling(
bootstrap_options = c("striped", "hover", "responsive"),
full_width = TRUE,
position = "center",
font_size = 14
) |>
kableExtra::row_spec(
0,
bold = TRUE
)| Indicador | Tasa_Porcentaje |
|---|---|
| AcceptedCmp3 | 7.28 |
| AcceptedCmp4 | 7.46 |
| AcceptedCmp5 | 7.28 |
| AcceptedCmp1 | 6.43 |
| AcceptedCmp2 | 1.34 |
| Response | 14.91 |
| Complain | 0.94 |
Fase 2. Análisis exploratorio de datos
1. Creación de nuevas variables
A partir de la información disponible se crean variables relacionadas con la edad, antigüedad, gasto total, frecuencia de compras y número de personas menores en el hogar.
DF2 <- DF1 |>
mutate(
# Edad del cliente
Age = 2014 - Year_Birth,
# Antigüedad del cliente
Tenure_Days = as.numeric(
max(Dt_Customer, na.rm = TRUE) - Dt_Customer
),
# Gasto total en las seis categorías
Total_Spent = MntWines +
MntFruits +
MntMeatProducts +
MntFishProducts +
MntSweetProducts +
MntGoldProds,
# Frecuencia total de compras
Total_Purchases = NumWebPurchases +
NumCatalogPurchases +
NumStorePurchases +
NumDealsPurchases,
# Total de niños y adolescentes en el hogar
Total_Children = Kidhome + Teenhome
)
Tb2 <- colSums(is.na(DF2))
knitr::kable(
Tb2,
digits = 2,
format = "html",
align = "c"
) |>
kableExtra::kable_styling(
bootstrap_options = c("striped", "hover", "responsive"),
full_width = TRUE,
position = "center",
font_size = 14
) |>
kableExtra::row_spec(
0,
bold = TRUE
)| x | |
|---|---|
| ID | 0 |
| Year_Birth | 0 |
| Education | 0 |
| Marital_Status | 0 |
| Income | 0 |
| Kidhome | 0 |
| Teenhome | 0 |
| Dt_Customer | 0 |
| Recency | 0 |
| MntWines | 0 |
| MntFruits | 0 |
| MntMeatProducts | 0 |
| MntFishProducts | 0 |
| MntSweetProducts | 0 |
| MntGoldProds | 0 |
| NumDealsPurchases | 0 |
| NumWebPurchases | 0 |
| NumCatalogPurchases | 0 |
| NumStorePurchases | 0 |
| NumWebVisitsMonth | 0 |
| AcceptedCmp3 | 0 |
| AcceptedCmp4 | 0 |
| AcceptedCmp5 | 0 |
| AcceptedCmp1 | 0 |
| AcceptedCmp2 | 0 |
| Complain | 0 |
| Response | 0 |
| Age | 0 |
| Tenure_Days | 0 |
| Total_Spent | 0 |
| Total_Purchases | 0 |
| Total_Children | 0 |
library(tidyverse)
library(patchwork)
library(ggplot2)
# 1. Preparación de variables calculadas para visualización
df_visual <- DF1 |>
mutate(
Age = 2014 - Year_Birth,
Total_Spent = MntWines + MntFruits + MntMeatProducts +
MntFishProducts + MntSweetProducts + MntGoldProds
)
# 2. Gráfico Nivel Educativo
g_edu <- ggplot(df_visual, aes(x = fct_infreq(Education), fill = Education)) +
geom_bar(show.legend = FALSE, alpha = 0.85) +
geom_text(stat = "count", aes(label = after_stat(count)), vjust = -0.4, size = 5, fontface = "bold") +
scale_y_continuous(expand = expansion(mult = c(0.05, 0.18))) +
scale_fill_viridis_d(option = "mako") +
labs(title = "Nivel Educativo", x = NULL, y = "Frecuencia (n)") +
theme_minimal(base_size = 14) +
theme(
plot.title = element_text(size = 16, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 13, face = "bold"),
axis.text.x = element_text(angle = 25, hjust = 1, face = "bold", size = 12),
axis.text.y = element_text(size = 12, face = "bold")
)
# 3. Gr Estado Civil
g_marital <- ggplot(df_visual, aes(x = fct_infreq(Marital_Status), fill = Marital_Status)) +
geom_bar(show.legend = FALSE, alpha = 0.85) +
geom_text(stat = "count", aes(label = after_stat(count)), vjust = -0.4, size = 5, fontface = "bold") +
scale_y_continuous(expand = expansion(mult = c(0.05, 0.18))) +
scale_fill_viridis_d(option = "turbo") +
labs(title = "Estado Civil", x = NULL, y = "Frecuencia (n)") +
theme_minimal(base_size = 14) +
theme(
plot.title = element_text(size = 16, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 13, face = "bold"),
axis.text.x = element_text(angle = 25, hjust = 1, face = "bold", size = 12),
axis.text.y = element_text(size = 12, face = "bold")
)
# 4. histograma edad Edad
library(tidyverse)
# 1. Extracción funcional del estadístico de tendencia central robusto (Q2)
mediana_edad <- median(df_visual$Age, na.rm = TRUE)
# 2. Histograma de edad con referencia de mediana en rojo
g_age <- ggplot(df_visual, aes(x = Age)) +
geom_histogram(binwidth = 2, fill = "aquamarine", color = "white", alpha = 0.85) +
geom_vline(xintercept = mediana_edad, color = "#d73027", linetype = "dashed", linewidth = 1.1) +
scale_y_continuous(expand = expansion(mult = c(0, 0.15))) +
labs(
title = "Distribución de Edad",
x = "Edad (Años)",
y = "Frecuencia (n)"
) +
theme_minimal(base_size = 14) +
theme(
plot.title = element_text(size = 16, face = "bold", hjust = 0.5),
plot.subtitle = element_text(size = 12, hjust = 0.5, color = "gray30"),
axis.title.x = element_text(size = 13, face = "bold"),
axis.title.y = element_text(size = 13, face = "bold"),
axis.text.x = element_text(size = 12, face = "bold"),
axis.text.y = element_text(size = 12, face = "bold")
)
# 5. Boxplot Gastos
g_spent <- ggplot(df_visual, aes(y = Total_Spent)) +
geom_boxplot(fill = "#35b779", color = "#1f2d3d", alpha = 0.75, width = 0.4, outlier.color = "red") +
labs(title = "Total de Gastos", y = "Monto Total ($)", x = NULL) +
theme_minimal(base_size = 14) +
theme(
plot.title = element_text(size = 16, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 14, face = "bold"),
axis.text.y = element_text(size = 13, face = "bold", color = "black"),
axis.text.x = element_blank()
)
g_edu 
g_marital
g_age 
g_spent
2. Distribución de las nuevas variables
Se agrupan las variables creadas para facilitar su visualización mediante histogramas.
df_long <- DF2 |>
select(
Age,
Tenure_Days,
Total_Spent,
Total_Purchases,
Total_Children
) |>
pivot_longer(
cols = everything(),
names_to = "Variable",
values_to = "Valor"
)
medianas <- df_long |>
summarise(
Q2 = median(Valor),
.by = Variable
)
medianas## # A tibble: 5 × 2
## Variable Q2
## <chr> <dbl>
## 1 Age 44
## 2 Tenure_Days 513
## 3 Total_Spent 396
## 4 Total_Purchases 15
## 5 Total_Children 1ggplot(
df_long,
aes(
x = Valor,
fill = Variable
)
) +
geom_histogram(
bins = 30,
color = "white",
alpha = 0.85,
show.legend = FALSE
) +
geom_vline(
data = medianas,
aes(xintercept = Q2),
color = "red",
linetype = "dashed",
linewidth = 0.8
) +
facet_wrap(
~ Variable,
scales = "free",
ncol = 3
) +
scale_fill_viridis_d(option = "mako") +
labs(
title = "Variables agrupadas (Q2)",
subtitle = "Agrupamiento de variables para análisis general (N = 2,240)",
x = "Valor de la variable",
y = "Frecuencia absoluta"
) +
theme_minimal(base_size = 11) +
theme(
strip.text = element_text(face = "bold")
)
3. Correlación entre variables
Se calcula una matriz de correlación entre las principales variables cuantitativas utilizadas en el análisis.
DF2 |>
select(
Income,
Total_Spent,
Age,
Recency,
Total_Purchases,
Tenure_Days,
Total_Children
) |>
cor(
use = "pairwise.complete.obs"
) |>
as.data.frame() |>
rownames_to_column(var = "Var1") |>
pivot_longer(
-Var1,
names_to = "Var2",
values_to = "r"
) |>
ggplot(
aes(
x = Var1,
y = Var2,
fill = r
)
) +
geom_tile() +
geom_text(
aes(label = round(r, 2)),
size = 3.5
) +
scale_fill_gradient2(
low = "red",
high = "green",
mid = "white",
midpoint = 0,
limits = c(-1, 1)
) +
theme_minimal() +
theme(
axis.text.x = element_text(
angle = 45,
hjust = 1
)
)
Fase 3. Clusterización
1. Escalado de las variables
Se seleccionan las variables cuantitativas utilizadas para la clusterización y se realiza su estandarización mediante Z-Score.
DF3 <- DF2 |>
select(
Income,
Recency,
Age,
Tenure_Days,
Total_Spent,
Total_Purchases,
Total_Children
) |>
mutate(
across(
everything(),
~ as.vector(scale(.x))
)
)
DF3## # A tibble: 2,240 × 7
## Income Recency Age Tenure_Days Total_Spent Total_Purchases Total_Children
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0.288 0.307 1.02 1.98 1.68 1.32 -1.26
## 2 -0.263 -0.384 1.27 -1.67 -0.961 -1.15 1.40
## 3 0.918 -0.798 0.334 -0.172 0.283 0.800 -1.26
## 4 -1.18 -0.798 -1.29 -1.93 -0.918 -0.894 0.0659
## 5 0.296 1.55 -1.03 -0.823 -0.305 0.539 0.0659
## 6 0.493 -1.14 0.163 -0.254 0.183 0.930 0.0659
## 7 0.172 -0.522 -0.179 1.04 -0.0262 0.800 0.0659
## 8 -0.865 -0.591 -1.38 -0.104 -0.725 -0.633 0.0659
## 9 -1.01 -1.04 -0.436 0.155 -0.930 -1.15 0.0659
## 10 -2.16 0.652 1.62 -1.05 -0.925 -1.68 1.40
## # ℹ 2,230 more rows2. Ajuste del modelo GMM
Se ajusta un modelo de mezcla gaussiana (GMM) utilizando diferentes cantidades de grupos y se emplea el criterio BIC para evaluar los modelos.
set.seed(123)
modelo_gmm <- Mclust(
DF3,
G = 1:9
)
summary(modelo_gmm)## ----------------------------------------------------
## Gaussian finite mixture model fitted by EM algorithm
## ----------------------------------------------------
##
## Mclust VEV (ellipsoidal, equal shape) model with 7 components:
##
## log-likelihood n df BIC ICL
## -11994.65 2240 215 -25647.86 -25693.52
##
## Clustering table:
## 1 2 3 4 5 6 7
## 65 147 488 119 262 35 11243. Evaluación mediante BIC
plot(
modelo_gmm,
what = "BIC"
)
4. Asignación de clústeres
Se incorporan a la base original los clústeres identificados por el modelo y el nivel de incertidumbre asociado a cada observación.
DF4 <- DF2 |>
mutate(
Cluster = factor(modelo_gmm$classification),
Uncertainty = modelo_gmm$uncertainty
)
DF4## # A tibble: 2,240 × 34
## ID Year_Birth Education Marital_Status Income Kidhome Teenhome Dt_Customer
## <dbl> <dbl> <chr> <chr> <dbl> <dbl> <dbl> <date>
## 1 5524 1957 Graduati… Single 58138 0 0 2012-04-09
## 2 2174 1954 Graduati… Single 46344 1 1 2014-08-03
## 3 4141 1965 Graduati… Together 71613 0 0 2013-08-21
## 4 6182 1984 Graduati… Together 26646 1 0 2014-10-02
## 5 5324 1981 PhD Married 58293 1 0 2014-01-19
## 6 7446 1967 Master Together 62513 0 1 2013-09-09
## 7 965 1971 Graduati… Divorced 55635 0 1 2012-11-13
## 8 6177 1985 PhD Married 33454 1 0 2013-08-05
## 9 4855 1974 PhD Together 30351 1 0 2013-06-06
## 10 5899 1950 PhD Together 5648 1 1 2014-03-13
## # ℹ 2,230 more rows
## # ℹ 26 more variables: Recency <dbl>, MntWines <dbl>, MntFruits <dbl>,
## # MntMeatProducts <dbl>, MntFishProducts <dbl>, MntSweetProducts <dbl>,
## # MntGoldProds <dbl>, NumDealsPurchases <dbl>, NumWebPurchases <dbl>,
## # NumCatalogPurchases <dbl>, NumStorePurchases <dbl>,
## # NumWebVisitsMonth <dbl>, AcceptedCmp3 <dbl>, AcceptedCmp4 <dbl>,
## # AcceptedCmp5 <dbl>, AcceptedCmp1 <dbl>, AcceptedCmp2 <dbl>, …Se resumen el número de clientes y los niveles de incertidumbre por clúster.
DF4 |>
summarise(
N_Clientes = n(),
Incertidumbre_Prom = round(
mean(Uncertainty),
4
),
Incertidumbre_Max = round(
max(Uncertainty),
4
),
.by = Cluster
) |>
arrange(Cluster)## # A tibble: 7 × 4
## Cluster N_Clientes Incertidumbre_Prom Incertidumbre_Max
## <fct> <int> <dbl> <dbl>
## 1 1 65 0.0538 0.480
## 2 2 147 0.0129 0.418
## 3 3 488 0.0031 0.431
## 4 4 119 0.037 0.451
## 5 5 262 0.0274 0.484
## 6 6 35 0.0004 0.0064
## 7 7 1124 0.0008 0.0785. Visualización de los clústeres
Se realiza una proyección PCA para visualizar los grupos identificados en dos dimensiones.
pca_coords <- prcomp(
DF3,
center = FALSE,
scale. = FALSE
)$x[, 1:2] |>
as_tibble()
df_plot_gmm <- DF4 |>
bind_cols(pca_coords)ggplot(
df_plot_gmm,
aes(
x = PC1,
y = PC2,
color = Cluster
)
) +
geom_point(
aes(size = Uncertainty),
alpha = 0.65
) +
stat_ellipse(
type = "norm",
level = 0.68,
linewidth = 0.9,
linetype = "solid"
) +
scale_size_continuous(
range = c(1, 4),
name = "Incertidumbre (u)"
) +
scale_color_viridis_d(
option = "turbo",
name = "Clúster GMM"
) +
labs(
title = "Segmentación probabilística GMM",
subtitle = "Proyección en PC1-PC2 con elipses de covarianza al 68% y diagnóstico de incertidumbre",
x = "Componente principal 1",
y = "Componente principal 2"
) +
theme_minimal(base_size = 11) +
theme(
legend.position = "right"
)
Fase 4. Perfilamiento de clientes
1. Caracterización de los clústeres
Se calculan los centroides Z-Score de cada clúster para identificar las características de los grupos encontrados.
matriz_incidencia <- DF3 |>
mutate(
Cluster = DF4$Cluster
) |>
group_by(Cluster) |>
summarise(
across(
everything(),
mean
)
) |>
pivot_longer(
-Cluster,
names_to = "Variable",
values_to = "Z_Score"
)2. Mapa de calor
ggplot(
matriz_incidencia,
aes(
x = Cluster,
y = Variable,
fill = Z_Score
)
) +
geom_tile(
color = "white",
linewidth = 0.6
) +
geom_text(
aes(
label = sprintf("%.2f", Z_Score)
),
color = "black",
size = 3.8,
fontface = "bold"
) +
scale_fill_gradient2(
low = "#d73027",
mid = "#ffffbf",
high = "#1a9850",
midpoint = 0,
limits = c(-2, 2),
oob = scales::squish,
name = "Z-Score"
) +
labs(
title = "Matriz de incidencia: caracterización de clusters (GMM)",
subtitle = "Centroides tipificados por segmento sobre el espacio multivariado (N = 2,240, G = 7)",
x = "Grupos identificados (Clusters)",
y = "Variables del modelo"
) +
theme_minimal(base_size = 11) +
theme(
axis.text = element_text(
face = "bold",
color = "black"
),
panel.grid = element_blank(),
legend.position = "right"
)
3. Tabla de perfilamiento
Se construye una tabla consolidada con los perfiles identificados, su frecuencia, porcentaje de la población y estrategia asociada.
tabla_estrategica <- tibble(
Cluster = factor(1:7),
Nombre_Perfil = c(
"Premium Tradicional / VIP Senior",
"Digital Activo / Alto Valor",
"Familias Estables / Ticket Medio",
"Cazadores de Ofertas / Sensibles al Precio",
"Clientes en Riesgo / Tiempo desde la Última Compra",
"Nicho Joven / Nuevos Ingresos",
"Consumidor Base / Masa Crítica"
),
Frecuencia_N = c(
65,
147,
488,
119,
262,
35,
1124
),
Pct_Poblacion = scales::percent(
c(
65,
147,
488,
119,
262,
35,
1124
) / nrow(DF4),
accuracy = 0.1
),
Estrategia_Clave = c(
"Fortalecer la fidelización y aumentar la compra de productos gourmet.",
"Incrementar la frecuencia y el valor de las compras mediante los canales digitales.",
"Promociones familiares y volumen en tienda física",
"Ofertas flash y descuentos dirigidos",
"Recuperar clientes que han dejado de comprar.",
"Favorecer la segunda compra y fortalecer la relación inicial con la empresa.",
"Mantener la frecuencia de compra y fortalecer la relación con la empresa."
)
)
knitr::kable(
tabla_estrategica,
caption = "Tabla de perfilamiento de clientes"
)| Cluster | Nombre_Perfil | Frecuencia_N | Pct_Poblacion | Estrategia_Clave |
|---|---|---|---|---|
| 1 | Premium Tradicional / VIP Senior | 65 | 2.9% | Fortalecer la fidelización y aumentar la compra de productos gourmet. |
| 2 | Digital Activo / Alto Valor | 147 | 6.6% | Incrementar la frecuencia y el valor de las compras mediante los canales digitales. |
| 3 | Familias Estables / Ticket Medio | 488 | 21.8% | Promociones familiares y volumen en tienda física |
| 4 | Cazadores de Ofertas / Sensibles al Precio | 119 | 5.3% | Ofertas flash y descuentos dirigidos |
| 5 | Clientes en Riesgo / Tiempo desde la Última Compra | 262 | 11.7% | Recuperar clientes que han dejado de comprar. |
| 6 | Nicho Joven / Nuevos Ingresos | 35 | 1.6% | Favorecer la segunda compra y fortalecer la relación inicial con la empresa. |
| 7 | Consumidor Base / Masa Crítica | 1124 | 50.2% | Mantener la frecuencia de compra y fortalecer la relación con la empresa. |
Conclusiones
El análisis permite identificar grupos de clientes mediante un modelo de mezcla gaussiana (GMM), así como caracterizar los segmentos a partir de las variables utilizadas en el modelo.