#Load necessary libraries
library(completejourney)
## Welcome to the completejourney package! Learn more about these data
## sets at http://bit.ly/completejourney.
library(ggplot2)
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ lubridate 1.9.4 ✔ tibble 3.3.0
## ✔ purrr 1.1.0 ✔ tidyr 1.3.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
library(arules)
## Loading required package: Matrix
##
## Attaching package: 'Matrix'
##
## The following objects are masked from 'package:tidyr':
##
## expand, pack, unpack
##
##
## Attaching package: 'arules'
##
## The following object is masked from 'package:dplyr':
##
## recode
##
## The following objects are masked from 'package:base':
##
## abbreviate, write
library(arulesViz)
library(knitr)
library(lubridate)
# Load transaction data
transactions <- get_transactions()
head(transactions)
## # A tibble: 6 × 11
## household_id store_id basket_id product_id quantity sales_value retail_disc
## <chr> <chr> <chr> <chr> <dbl> <dbl> <dbl>
## 1 900 330 31198570044 1095275 1 0.5 0
## 2 900 330 31198570047 9878513 1 0.99 0.1
## 3 1228 406 31198655051 1041453 1 1.43 0.15
## 4 906 319 31198705046 1020156 1 1.5 0.29
## 5 906 319 31198705046 1053875 2 2.78 0.8
## 6 906 319 31198705046 1060312 1 5.49 0.5
## # ℹ 4 more variables: coupon_disc <dbl>, coupon_match_disc <dbl>, week <int>,
## # transaction_timestamp <dttm>
# Prepare visualization for answer WHAT is most purchased
viz1 <- transactions %>%
inner_join(products, by = "product_id") %>%
group_by(product_type) %>%
summarize(Count = n(), .groups = 'drop') %>%
arrange(desc(Count)) %>%
slice(1:10) %>%
ggplot(aes(x = reorder(product_type, Count), y = Count, fill = product_type)) +
geom_bar(stat = 'identity') +
coord_flip() +
ggtitle('WHAT is the most frequently bought items?') +
labs(x = 'Product Type', y = 'Frequency of Purchases') + # Change the axis labels here
scale_fill_brewer(palette = "Set3") +
theme(legend.position = "none")
print(viz1)
# Prepare visualization for answer WHO is purchasing milk
milk_purchases <- transactions %>%
inner_join(products, by = "product_id") %>%
inner_join(demographics, by = "household_id") %>%
filter(product_type == "FLUID MILK WHITE ONLY") # Filter for milk purchases
# Summarize by demographic factors (e.g., income level, gender)
demographic_summary <- milk_purchases %>%
group_by(income, age) %>%
summarize(purchase_count = n(), .groups = 'drop') %>%
arrange(desc(purchase_count))
# Plotting the demographics of milk purchasers
ggplot(demographic_summary, aes(x = income, y = purchase_count, fill = age)) +
geom_bar(stat = 'identity', position = 'dodge') +
labs(
title = "WHO is buying milk?",
subtitle = "Comparison of Milk Purchases by Income Level and Age",
x = "Income Level",
y = "Number of Milk Purchases"
) +
scale_fill_brewer(palette = "Set1") +
theme_minimal() +
theme(
axis.text.x = element_text(angle = 45, hjust = 1), # Rotate x-axis text for better readability
legend.title = element_blank() # Remove legend title for cleaner appearance
)
# What about the top purchases of the top product, what other relationships occur in those purchases?
baskets <- transactions %>%
inner_join(products, by = "product_id") %>%
inner_join(demographics, by = "household_id") %>%
filter(age == "25-34" | age == "35-44" | age == "45-54") %>%
filter(income == "35-49K" | income == "50-74K" | income == "75-99K") %>%
group_by(basket_id) %>%
summarise(items = list(product_type), .groups = 'drop')
# Convert the list to a transactions object
transactions_arules <- as(baskets$items, "transactions")
## Warning in asMethod(object): removing duplicated items in transactions
# Apriori analysis
rules <- apriori(transactions_arules, parameter = list(supp = 0.03, conf = 0.3), target='rules')
## Apriori
##
## Parameter specification:
## confidence minval smax arem aval originalSupport maxtime support minlen
## 0.3 0.1 1 none FALSE TRUE 5 0.03 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: 1077
##
## set item appearances ...[0 item(s)] done [0.00s].
## set transactions ...[2001 item(s), 35925 transaction(s)] done [0.07s].
## sorting and recoding items ... [50 item(s)] done [0.00s].
## creating transaction tree ... done [0.01s].
## checking subsets of size 1 2 3 done [0.00s].
## writing ... [12 rule(s)] done [0.00s].
## creating S4 object ... done [0.00s].
# Filter the rules
filtered_rules <- subset(rules, subset = lift > 2.5)
# Graphical network of rules
p <- plot(filtered_rules, method = "graph")
p + ggtitle("Why might these people be buying milk?",
subtitle = "Arrow = if/then, Lift = Strength of Correlation, Support = How Often)")
