Teoría

El Market Basket Analysis es una técnica en el ámbito de análisis y minería de datos en el camo del comercio. Su objetivo rincial es descubrir patrones de asociación entre productos que suelen ser comprados juntos por los clientes.

Las 3 métricas principales para evaluar reglas de asoación son:

  • Confidence (Confianza): Probabilidad de comprar B sabiendo que se compró A. Ej. Pan –> Mantequilla 0.8 De cada 100 clientes que compraron pan, 80 compraron mantequilla también.
  • Lift (Elevación): Cuánto más probable es comprar B cuando se compra A en comparación de la probabilidad de comprar B sin saber si se compró A. Ej. Lift > 1 Compra A impulsa B. Lift = 1 No tienen relación de compra. Lift < 1 A reduce la compra de B.
  • Support (Soporte): Popularidad del producto dentro de las transacciones. Ej. Pan y Mantequilla 0.05 El 5% de todas las transacciones compraron estos dos productos juntos.

Contexto

Este caso de estudio utiliza el dataset real de Instacart en Kaggle, el cual registra más de 3 millones de pedidos de 200,000 usuarios con un catálogo de 50,000 productos, con el objetivo de descubrir los hábitos de consumo y predecir las compras repetidas de los clientes. A diferencia de un modelo inmobiliario tradicional, este ecosistema carece de datos de precios, por lo que se aborda mediante un Market Basket Analysis (Análisis de la Canasta de Compra) utilizando el algoritmo Apriori; esto permite conectar múltiples tablas relacionales para identificar reglas de asociación y combinaciones frecuentes de productos (como qué artículos se agregan juntos al carrito), información que las empresas de comercio electrónico utilizan estratégicamente para optimizar recomendaciones en la app, diseñar promociones y organizar sus inventarios.

Instalar paquetes y llamar librerías

# install.packages("tidyverse") # Paquete global para manipulación y análisis de datos
library(tidyverse)
# install.packages("janitor") # Examinar y limpiar bases de datos sucias
library(janitor)
# install.packages("Matrix") # Para trabajar con matrices
library(Matrix)
# install.packages("arules") # Genera reglas de asociación
library(arules)
# install.packages("arulesViz") # Visualizar reglas de asociación
library(arulesViz)
# install.packages("plyr")
library(plyr)

Importar la base de datos

# file.choose()
#order1 <- read.csv("C:\\Users\\raulc\\Downloads\\archive\\order_products__prior.csv")
order2 <- read.csv("C:\\Users\\raulc\\Downloads\\archive\\order_products__train.csv")
products <- read.csv("C:\\Users\\raulc\\Downloads\\archive\\products.csv")
#order <- rbind(order1,order2)
df <- left_join(order2, products, by = "product_id")

Entender la base de datos

summary(df)
##     order_id         product_id    add_to_cart_order   reordered     
##  Min.   :      1   Min.   :    1   Min.   : 1.000    Min.   :0.0000  
##  1st Qu.: 843370   1st Qu.:13380   1st Qu.: 3.000    1st Qu.:0.0000  
##  Median :1701880   Median :25298   Median : 7.000    Median :1.0000  
##  Mean   :1706298   Mean   :25556   Mean   : 8.758    Mean   :0.5986  
##  3rd Qu.:2568023   3rd Qu.:37940   3rd Qu.:12.000    3rd Qu.:1.0000  
##  Max.   :3421070   Max.   :49688   Max.   :80.000    Max.   :1.0000  
##     product_name        aisle_id     department_id  
##  Length   :1384617   Min.   :  1.0   Min.   : 1.00  
##  N.unique :  39123   1st Qu.: 31.0   1st Qu.: 4.00  
##  N.blank  :      0   Median : 83.0   Median : 8.00  
##  Min.nchar:      3   Mean   : 71.3   Mean   : 9.84  
##  Max.nchar:    159   3rd Qu.:107.0   3rd Qu.:16.00  
##                      Max.   :134.0   Max.   :21.00
str(df)
## 'data.frame':    1384617 obs. of  7 variables:
##  $ order_id         : int  1 1 1 1 1 1 1 1 36 36 ...
##  $ product_id       : int  49302 11109 10246 49683 43633 13176 47209 22035 39612 19660 ...
##  $ add_to_cart_order: int  1 2 3 4 5 6 7 8 1 2 ...
##  $ reordered        : int  1 1 0 0 1 0 0 1 0 1 ...
##  $ product_name     : chr  "Bulgarian Yogurt" "Organic 4% Milk Fat Whole Milk Cottage Cheese" "Organic Celery Hearts" "Cucumber Kirby" ...
##  $ aisle_id         : int  120 108 83 83 95 24 24 21 2 115 ...
##  $ department_id    : int  16 16 4 4 15 4 4 16 16 7 ...
top10 <- df %>% 
  dplyr::count(product_name, sort = TRUE) %>% 
  head(10)
top10
##              product_name     n
## 1                  Banana 18726
## 2  Bag of Organic Bananas 15480
## 3    Organic Strawberries 10894
## 4    Organic Baby Spinach  9784
## 5             Large Lemon  8135
## 6         Organic Avocado  7409
## 7    Organic Hass Avocado  7293
## 8            Strawberries  6494
## 9                   Limes  6033
## 10    Organic Raspberries  5546
head(df)
##   order_id product_id add_to_cart_order reordered
## 1        1      49302                 1         1
## 2        1      11109                 2         1
## 3        1      10246                 3         0
## 4        1      49683                 4         0
## 5        1      43633                 5         1
## 6        1      13176                 6         0
##                                    product_name aisle_id department_id
## 1                              Bulgarian Yogurt      120            16
## 2 Organic 4% Milk Fat Whole Milk Cottage Cheese      108            16
## 3                         Organic Celery Hearts       83             4
## 4                                Cucumber Kirby       83             4
## 5          Lightly Smoked Sardines in Olive Oil       95            15
## 6                        Bag of Organic Bananas       24             4

Generar Basket

# Ordenar de menor a mayor la columna Ticket
df <- df[order(df$order_id), ] 

# Generar Basket
basket <- ddply(df, c("order_id"), function(df)paste(df$product_name, collapse=","))

# Eliminar número de ticket
basket$order_id <- NULL

# Cambiar el título de la columna V1 por Marca
colnames(basket) <- c("Producto")

# Exportar basket
write.csv(basket, "basket2.csv", quote = FALSE, row.names = FALSE)

Market Basket Analysis

# file.choose()
tr <- read.transactions("C:\\Users\\raulc\\OneDrive\\Escritorio\\basket2.csv", format = "basket", sep=",")

reglas.asociacion <- apriori(tr, parameter = list(supp=0.001, conf=0.2, maxlen=10))
## Apriori
## 
## Parameter specification:
##  confidence minval smax arem  aval originalSupport maxtime support minlen
##         0.2    0.1    1 none FALSE            TRUE       5   0.001      1
##  maxlen target  ext
##      10  rules TRUE
## 
## Algorithmic control:
##  filter tree heap memopt load sort verbose
##     0.1 TRUE TRUE  FALSE TRUE    2    TRUE
## 
## Absolute minimum support count: 131 
## 
## set item appearances ...[0 item(s)] done [0.00s].
## set transactions ...[49936 item(s), 131210 transaction(s)] done [0.61s].
## sorting and recoding items ... [1813 item(s)] done [0.01s].
## creating transaction tree ... done [0.05s].
## checking subsets of size 1 2 3 4 done [0.05s].
## writing ... [1339 rule(s)] done [0.00s].
## creating S4 object  ... done [0.01s].
#summary(reglas.asociacion)
#inspect(reglas.asociacion)

reglas.asociacion <- sort(reglas.asociacion, by= "confidence", decreasing = TRUE)
#summary(reglas.asociacion)
#inspect(reglas.asociacion)

top10reglas <- head(reglas.asociacion, n=10, by="confidence")
plot(top10reglas, method= "graph", engine = "htmlwidget")
LS0tDQp0aXRsZTogIkNhc28gMSBJbnN0YWNhcnQiDQphdXRob3I6ICJSYXVsIENhbnR1IEEwMTA4NzY4MyINCmRhdGU6ICIyMDI2LTA4LTE5Ig0Kb3V0cHV0OiANCiAgaHRtbF9kb2N1bWVudDoNCiAgICB0b2M6IFRSVUUNCiAgICB0b2NfZmxvYXQ6IFRSVUUNCiAgICBjb2RlX2Rvd25sb2FkOiBUUlVFDQogICAgdGhlbWU6IGpvdXJuYWwgDQotLS0NCg0KIVtdKGh0dHBzOi8vc3RhZmZpbmdhbWVyaWNhbGF0aW5hLmNvbS93cC1jb250ZW50L3VwbG9hZHMvMjAyMy8wOC9pbnN0YWNhcnQtbG9nby13b3JkbWFyay00MDAweDE2MDAtZTRmM2M2Zi0xLmpwZykNCg0KIyA8c3BhbiBzdHlsZT0iY29sb3I6IGdyZWVuIj5UZW9yw61hPC9zcGFuPg0KRWwgKipNYXJrZXQgQmFza2V0IEFuYWx5c2lzKiogZXMgdW5hIHTDqWNuaWNhIGVuIGVsIMOhbWJpdG8gZGUgYW7DoWxpc2lzIHkgbWluZXLDrWEgZGUgZGF0b3MgZW4gZWwgY2FtbyBkZWwgY29tZXJjaW8uIFN1IG9iamV0aXZvIHJpbmNpYWwgZXMgZGVzY3VicmlyIHBhdHJvbmVzIGRlIGFzb2NpYWNpw7NuIGVudHJlIHByb2R1Y3RvcyBxdWUgc3VlbGVuIHNlciBjb21wcmFkb3MganVudG9zIHBvciBsb3MgY2xpZW50ZXMuICANCg0KTGFzIDMgbcOpdHJpY2FzIHByaW5jaXBhbGVzIHBhcmEgZXZhbHVhciByZWdsYXMgZGUgYXNvYWNpw7NuIHNvbjogIA0KDQoqICpDb25maWRlbmNlKiAoQ29uZmlhbnphKTogUHJvYmFiaWxpZGFkIGRlIGNvbXByYXIgQiBzYWJpZW5kbyBxdWUgc2UgY29tcHLDsyBBLiBFai4gUGFuIC0tPiBNYW50ZXF1aWxsYSAwLjggRGUgY2FkYSAxMDAgY2xpZW50ZXMgcXVlIGNvbXByYXJvbiBwYW4sIDgwIGNvbXByYXJvbiBtYW50ZXF1aWxsYSB0YW1iacOpbi4gIA0KKiAqTGlmdCogKEVsZXZhY2nDs24pOiBDdcOhbnRvIG3DoXMgcHJvYmFibGUgZXMgY29tcHJhciBCIGN1YW5kbyBzZSBjb21wcmEgQSBlbiBjb21wYXJhY2nDs24gZGUgbGEgcHJvYmFiaWxpZGFkIGRlIGNvbXByYXIgQiBzaW4gc2FiZXIgc2kgc2UgY29tcHLDsyBBLiBFai4gTGlmdCA+IDEgQ29tcHJhIEEgaW1wdWxzYSBCLiBMaWZ0ID0gMSBObyB0aWVuZW4gcmVsYWNpw7NuIGRlIGNvbXByYS4gTGlmdCA8IDEgQSByZWR1Y2UgbGEgY29tcHJhIGRlIEIuICANCiogKlN1cHBvcnQqIChTb3BvcnRlKTogUG9wdWxhcmlkYWQgZGVsIHByb2R1Y3RvIGRlbnRybyBkZSBsYXMgdHJhbnNhY2Npb25lcy4gRWouIFBhbiB5IE1hbnRlcXVpbGxhIDAuMDUgRWwgNSUgZGUgdG9kYXMgbGFzIHRyYW5zYWNjaW9uZXMgY29tcHJhcm9uIGVzdG9zIGRvcyBwcm9kdWN0b3MganVudG9zLiAgDQoNCiFbXShodHRwczovL21lZGlhLmxpY2RuLmNvbS9kbXMvaW1hZ2UvdjIvRDREMTJBUUZsTkNQMVlZZFBsdy9hcnRpY2xlLWNvdmVyX2ltYWdlLXNocmlua183MjBfMTI4MC9CNERadGFuX3BoS29BSS0vMC8xNzY2NzUyMDA1NTc3P2U9MjE0NzQ4MzY0NyZ2PWJldGEmdD1PYjN2QktwQ1NsMnBWRkNxT2FPNHJ4LXEtYzloZXJsWGZ4QUI1bjFWNnR3KQ0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjogZ3JlZW4iPkNvbnRleHRvPC9zcGFuPg0KRXN0ZSBjYXNvIGRlIGVzdHVkaW8gdXRpbGl6YSBlbCBkYXRhc2V0IHJlYWwgZGUgKipJbnN0YWNhcnQqKiBlbiBLYWdnbGUsIGVsIGN1YWwgcmVnaXN0cmEgbcOhcyBkZSAzIG1pbGxvbmVzIGRlIHBlZGlkb3MgZGUgMjAwLDAwMCB1c3VhcmlvcyBjb24gdW4gY2F0w6Fsb2dvIGRlIDUwLDAwMCBwcm9kdWN0b3MsIGNvbiBlbCBvYmpldGl2byBkZSBkZXNjdWJyaXIgbG9zIGjDoWJpdG9zIGRlIGNvbnN1bW8geSBwcmVkZWNpciBsYXMgY29tcHJhcyByZXBldGlkYXMgZGUgbG9zIGNsaWVudGVzLiBBIGRpZmVyZW5jaWEgZGUgdW4gbW9kZWxvIGlubW9iaWxpYXJpbyB0cmFkaWNpb25hbCwgZXN0ZSBlY29zaXN0ZW1hIGNhcmVjZSBkZSBkYXRvcyBkZSBwcmVjaW9zLCBwb3IgbG8gcXVlIHNlIGFib3JkYSBtZWRpYW50ZSB1biAqKk1hcmtldCBCYXNrZXQgQW5hbHlzaXMqKiAoQW7DoWxpc2lzIGRlIGxhIENhbmFzdGEgZGUgQ29tcHJhKSB1dGlsaXphbmRvIGVsIGFsZ29yaXRtbyBBcHJpb3JpOyBlc3RvIHBlcm1pdGUgY29uZWN0YXIgbcO6bHRpcGxlcyB0YWJsYXMgcmVsYWNpb25hbGVzIHBhcmEgaWRlbnRpZmljYXIgcmVnbGFzIGRlIGFzb2NpYWNpw7NuIHkgY29tYmluYWNpb25lcyBmcmVjdWVudGVzIGRlIHByb2R1Y3RvcyAoY29tbyBxdcOpIGFydMOtY3Vsb3Mgc2UgYWdyZWdhbiBqdW50b3MgYWwgY2Fycml0byksIGluZm9ybWFjacOzbiBxdWUgbGFzIGVtcHJlc2FzIGRlIGNvbWVyY2lvIGVsZWN0csOzbmljbyB1dGlsaXphbiBlc3RyYXTDqWdpY2FtZW50ZSBwYXJhIG9wdGltaXphciByZWNvbWVuZGFjaW9uZXMgZW4gbGEgYXBwLCBkaXNlw7FhciBwcm9tb2Npb25lcyB5IG9yZ2FuaXphciBzdXMgaW52ZW50YXJpb3MuDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBncmVlbiI+SW5zdGFsYXIgcGFxdWV0ZXMgeSBsbGFtYXIgbGlicmVyw61hczwvc3Bhbj4NCmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9DQojIGluc3RhbGwucGFja2FnZXMoInRpZHl2ZXJzZSIpICMgUGFxdWV0ZSBnbG9iYWwgcGFyYSBtYW5pcHVsYWNpw7NuIHkgYW7DoWxpc2lzIGRlIGRhdG9zDQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCiMgaW5zdGFsbC5wYWNrYWdlcygiamFuaXRvciIpICMgRXhhbWluYXIgeSBsaW1waWFyIGJhc2VzIGRlIGRhdG9zIHN1Y2lhcw0KbGlicmFyeShqYW5pdG9yKQ0KIyBpbnN0YWxsLnBhY2thZ2VzKCJNYXRyaXgiKSAjIFBhcmEgdHJhYmFqYXIgY29uIG1hdHJpY2VzDQpsaWJyYXJ5KE1hdHJpeCkNCiMgaW5zdGFsbC5wYWNrYWdlcygiYXJ1bGVzIikgIyBHZW5lcmEgcmVnbGFzIGRlIGFzb2NpYWNpw7NuDQpsaWJyYXJ5KGFydWxlcykNCiMgaW5zdGFsbC5wYWNrYWdlcygiYXJ1bGVzVml6IikgIyBWaXN1YWxpemFyIHJlZ2xhcyBkZSBhc29jaWFjacOzbg0KbGlicmFyeShhcnVsZXNWaXopDQojIGluc3RhbGwucGFja2FnZXMoInBseXIiKQ0KbGlicmFyeShwbHlyKQ0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBncmVlbiI+SW1wb3J0YXIgbGEgYmFzZSBkZSBkYXRvczwvc3Bhbj4NCmBgYHtyfQ0KIyBmaWxlLmNob29zZSgpDQojb3JkZXIxIDwtIHJlYWQuY3N2KCJDOlxcVXNlcnNcXHJhdWxjXFxEb3dubG9hZHNcXGFyY2hpdmVcXG9yZGVyX3Byb2R1Y3RzX19wcmlvci5jc3YiKQ0Kb3JkZXIyIDwtIHJlYWQuY3N2KCJDOlxcVXNlcnNcXHJhdWxjXFxEb3dubG9hZHNcXGFyY2hpdmVcXG9yZGVyX3Byb2R1Y3RzX190cmFpbi5jc3YiKQ0KcHJvZHVjdHMgPC0gcmVhZC5jc3YoIkM6XFxVc2Vyc1xccmF1bGNcXERvd25sb2Fkc1xcYXJjaGl2ZVxccHJvZHVjdHMuY3N2IikNCiNvcmRlciA8LSByYmluZChvcmRlcjEsb3JkZXIyKQ0KZGYgPC0gbGVmdF9qb2luKG9yZGVyMiwgcHJvZHVjdHMsIGJ5ID0gInByb2R1Y3RfaWQiKQ0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBncmVlbiI+RW50ZW5kZXIgbGEgYmFzZSBkZSBkYXRvczwvc3Bhbj4NCmBgYHtyfQ0Kc3VtbWFyeShkZikNCnN0cihkZikNCnRvcDEwIDwtIGRmICU+JSANCiAgZHBseXI6OmNvdW50KHByb2R1Y3RfbmFtZSwgc29ydCA9IFRSVUUpICU+JSANCiAgaGVhZCgxMCkNCnRvcDEwDQpoZWFkKGRmKQ0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBncmVlbiI+R2VuZXJhciBCYXNrZXQ8L3NwYW4+DQpgYGB7cn0NCiMgT3JkZW5hciBkZSBtZW5vciBhIG1heW9yIGxhIGNvbHVtbmEgVGlja2V0DQpkZiA8LSBkZltvcmRlcihkZiRvcmRlcl9pZCksIF0gDQoNCiMgR2VuZXJhciBCYXNrZXQNCmJhc2tldCA8LSBkZHBseShkZiwgYygib3JkZXJfaWQiKSwgZnVuY3Rpb24oZGYpcGFzdGUoZGYkcHJvZHVjdF9uYW1lLCBjb2xsYXBzZT0iLCIpKQ0KDQojIEVsaW1pbmFyIG7Dum1lcm8gZGUgdGlja2V0DQpiYXNrZXQkb3JkZXJfaWQgPC0gTlVMTA0KDQojIENhbWJpYXIgZWwgdMOtdHVsbyBkZSBsYSBjb2x1bW5hIFYxIHBvciBNYXJjYQ0KY29sbmFtZXMoYmFza2V0KSA8LSBjKCJQcm9kdWN0byIpDQoNCiMgRXhwb3J0YXIgYmFza2V0DQp3cml0ZS5jc3YoYmFza2V0LCAiYmFza2V0Mi5jc3YiLCBxdW90ZSA9IEZBTFNFLCByb3cubmFtZXMgPSBGQUxTRSkNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjogZ3JlZW4iPk1hcmtldCBCYXNrZXQgQW5hbHlzaXM8L3NwYW4+DQpgYGB7ciBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQ0KIyBmaWxlLmNob29zZSgpDQp0ciA8LSByZWFkLnRyYW5zYWN0aW9ucygiQzpcXFVzZXJzXFxyYXVsY1xcT25lRHJpdmVcXEVzY3JpdG9yaW9cXGJhc2tldDIuY3N2IiwgZm9ybWF0ID0gImJhc2tldCIsIHNlcD0iLCIpDQoNCnJlZ2xhcy5hc29jaWFjaW9uIDwtIGFwcmlvcmkodHIsIHBhcmFtZXRlciA9IGxpc3Qoc3VwcD0wLjAwMSwgY29uZj0wLjIsIG1heGxlbj0xMCkpDQojc3VtbWFyeShyZWdsYXMuYXNvY2lhY2lvbikNCiNpbnNwZWN0KHJlZ2xhcy5hc29jaWFjaW9uKQ0KDQpyZWdsYXMuYXNvY2lhY2lvbiA8LSBzb3J0KHJlZ2xhcy5hc29jaWFjaW9uLCBieT0gImNvbmZpZGVuY2UiLCBkZWNyZWFzaW5nID0gVFJVRSkNCiNzdW1tYXJ5KHJlZ2xhcy5hc29jaWFjaW9uKQ0KI2luc3BlY3QocmVnbGFzLmFzb2NpYWNpb24pDQoNCnRvcDEwcmVnbGFzIDwtIGhlYWQocmVnbGFzLmFzb2NpYWNpb24sIG49MTAsIGJ5PSJjb25maWRlbmNlIikNCnBsb3QodG9wMTByZWdsYXMsIG1ldGhvZD0gImdyYXBoIiwgZW5naW5lID0gImh0bWx3aWRnZXQiKQ0KYGBgDQoNCg==