Results

Introduction

We are data analysts at Regork, and we have been given the task of identifying a potential area of growth where the company could invest future resources to increase revenue and profits. One major week in the United States every year is Super Bowl week, and every Super Bowl there are commercials that stick in people’s minds for weeks to come. So we decided to ask the question…

How can we design the best promotions to suit the purchasing preferences of our customers the week after the Super Bowl?

With the data given to us we are able to see that Super Bowl promotions may work, however to increase sales we should package items together, and these items should be yogurt with chocolate milk.

Using the skills we have learned so far throughout this semester, we plan to analyze the data to see what demographics we should target with this deal, as well as making sure that this deal would make sense to create.

Packages Required

library(completejourney)
library(dplyr)
library(tidyverse)
library(lubridate)
library(ggplot2)

Data Preparation

#get the completejourney - transactions dataset
transactions <- transactions_sample
transactions
## # A tibble: 75,000 × 11
##    household_id store_id basket_id   product_id quantity sales_value retail_disc
##    <chr>        <chr>    <chr>       <chr>         <dbl>       <dbl>       <dbl>
##  1 2261         309      31625220889 940996            1        3.86        0.43
##  2 2131         368      32053127496 873902            1        1.59        0.9 
##  3 511          316      32445856036 847901            1        1           0.69
##  4 400          388      31932241118 13094913          2       11.9         2.9 
##  5 918          340      32074655895 1085604           1        1.29        0   
##  6 718          324      32614612029 883203            1        2.5         0.49
##  7 868          323      32074722463 9884484           1        3.49        0   
##  8 1688         450      34850403304 1028715           1        2           1.79
##  9 467          31782    31280745102 896613            2        6.55        4.44
## 10 1947         32004    32744181707 978497            1        3.99        0   
## # ℹ 74,990 more rows
## # ℹ 4 more variables: coupon_disc <dbl>, coupon_match_disc <dbl>, week <int>,
## #   transaction_timestamp <dttm>
# get the completejourney - products dataset
products
## # A tibble: 92,331 × 7
##    product_id manufacturer_id department    brand  product_category product_type
##    <chr>      <chr>           <chr>         <fct>  <chr>            <chr>       
##  1 25671      2               GROCERY       Natio… FRZN ICE         ICE - CRUSH…
##  2 26081      2               MISCELLANEOUS Natio… <NA>             <NA>        
##  3 26093      69              PASTRY        Priva… BREAD            BREAD:ITALI…
##  4 26190      69              GROCERY       Priva… FRUIT - SHELF S… APPLE SAUCE 
##  5 26355      69              GROCERY       Priva… COOKIES/CONES    SPECIALTY C…
##  6 26426      69              GROCERY       Priva… SPICES & EXTRAC… SPICES & SE…
##  7 26540      69              GROCERY       Priva… COOKIES/CONES    TRAY PACK/C…
##  8 26601      69              DRUG GM       Priva… VITAMINS         VITAMIN - M…
##  9 26636      69              PASTRY        Priva… BREAKFAST SWEETS SW GDS: SW …
## 10 26691      16              GROCERY       Priva… PNT BTR/JELLY/J… HONEY       
## # ℹ 92,321 more rows
## # ℹ 1 more variable: package_size <chr>
# get the completejourney - demographics dataset
demographics
## # A tibble: 801 × 8
##    household_id age   income    home_ownership marital_status household_size
##    <chr>        <ord> <ord>     <ord>          <ord>          <ord>         
##  1 1            65+   35-49K    Homeowner      Married        2             
##  2 1001         45-54 50-74K    Homeowner      Unmarried      1             
##  3 1003         35-44 25-34K    <NA>           Unmarried      1             
##  4 1004         25-34 15-24K    <NA>           Unmarried      1             
##  5 101          45-54 Under 15K Homeowner      Married        4             
##  6 1012         35-44 35-49K    <NA>           Married        5+            
##  7 1014         45-54 15-24K    <NA>           Married        4             
##  8 1015         45-54 50-74K    Homeowner      Unmarried      1             
##  9 1018         45-54 35-49K    Homeowner      Married        5+            
## 10 1020         45-54 25-34K    Homeowner      Married        2             
## # ℹ 791 more rows
## # ℹ 2 more variables: household_comp <ord>, kids_count <ord>

Dataframes

# Filtering for Transactions around the SB
transactions <- transactions %>%
  mutate(transaction_timestamp = as.Date(transaction_timestamp))

# Filtering for Transactions before the SB
start_date_before <- as.Date("2017-01-30")
end_date_before <- as.Date("2017-02-04")

transactions_before_sb <- transactions %>%
  filter(transaction_timestamp >= start_date_before & transaction_timestamp <= end_date_before)

# Filtering for Transactions after the SB
start_date_after <- as.Date("2017-02-06")
end_date_after <- as.Date("2017-02-11")

transactions_after_sb <- transactions %>%
  filter(transaction_timestamp >= start_date_after & transaction_timestamp <= end_date_after)

# Only using products in the GROCERY department
grocery_products <- filter(products, department == "GROCERY")


# Finding the top ten items sold in the set dates
merged_data <- inner_join(transactions_after_sb, grocery_products, by = "product_id")

top_selling_products <- merged_data %>%
  group_by(product_type) %>%
  summarize(total_quantity = sum(quantity)) %>%
  arrange(desc(total_quantity)) %>%
  head(10)
  
# Using the top selling item, what else was bought with it
yogurt_products_with <- filter(grocery_products, product_type == "YOGURT NOT MULTI-PACKS")  

yogurt_and_co_purchased <- inner_join(transactions_after_sb, yogurt_products_with, by = "product_id") 

yogurt_basket_ids <- unique(yogurt_and_co_purchased$basket_id) 

co_purchased_items <- transactions_after_sb %>% 
  filter(basket_id %in% yogurt_basket_ids) %>% 
  filter(!product_id %in% yogurt_products_with$product_id)

co_purchased_items <- inner_join(co_purchased_items, grocery_products, by = "product_id")

top_selling_with_yogurt <- co_purchased_items %>% 
  group_by(product_type) %>% 
  summarize(total_quantity = sum(quantity)) %>% 
  arrange(desc(total_quantity)) %>% 
  head(5)



# Finding the Average Weekly Expenditure
merged_data_2 <- inner_join(transactions, products, by="product_id")

grocery_sales <- filter(merged_data_2, department == "GROCERY")

weekly_spending <- grocery_sales %>%
  group_by(week) %>%
  summarize(total_spending = sum(sales_value))

average_weekly_spending <- mean(weekly_spending$total_spending)



#Finding the average weekly expenditure before the superbowl
merged_data_3 <- inner_join(transactions_before_sb, products, by = "product_id")

sales_before_sb <- filter(merged_data_3, department == "GROCERY")

weekly_spending_before_sb <- sum(sales_before_sb$sales_value)

#Finding the weekly expenditure after the superbowl
sales_after_sb <- filter(merged_data, department == "GROCERY")

weekly_spending_after_sb <- sum(sales_after_sb$sales_value)

#Finding the expenditure on the day of the superbowl
sb_day_data <- transactions %>%
  filter(transaction_timestamp == as.Date("2017-02-05"))

merged_data_4 <- inner_join(sb_day_data, products, by = "product_id")

sales_on_sb <- filter(merged_data_4, department == "GROCERY")

spending_on_sb <- sum(sales_on_sb$sales_value)


# Finding the demographics of people buying yogurt after the sb
merged_data <- merged_data %>%
  inner_join(demographics, by = "household_id")

demo_after_sb <- merged_data %>%
  filter(product_type == "YOGURT NOT MULTI-PACKS")

count_demo_after_sb <- demo_after_sb %>%
  group_by(age) %>%
  summarize(count = n())


# Finding the demographics of people buying yogurt before the sb
merged_data_3 <- merged_data_3 %>%
  inner_join(demographics, by = "household_id")

demo_before_sb <- merged_data_3 %>%
  filter(product_type == "YOGURT NOT MULTI-PACKS")

count_demo_before_sb <- demo_before_sb %>%
  group_by(age) %>%
  summarize(count = n())


# Finding the top 10 products people bought before the sb
merged_data_5 <- inner_join(transactions_before_sb, grocery_products, "product_id")

top_selling_products_before <- merged_data_5 %>%
  group_by(product_type) %>%
  summarize(total_quantity = sum(quantity)) %>%
  arrange(desc(total_quantity)) %>%
  head(10)


# Finding what each age demographic bought most after the superbowl
transactions_after_sb <- merged_data

top_products_by_age_after <- transactions_after_sb %>%
  group_by(age, product_id, product_type) %>%
  summarize(total_quantity = sum(quantity)) %>%
  arrange(age, desc(total_quantity)) %>%
  group_by(age) %>%
  slice_head(n = 1)


# Finding what each age demographic bought most before the superbowl
sales_before_sb <- sales_before_sb %>%
  inner_join(demographics, by = "household_id")

transactions_before_sb <- sales_before_sb

top_products_by_age_before <- transactions_before_sb %>%
  group_by(age, product_id, product_type) %>%
  summarize(total_quantity = sum(quantity)) %>%
  arrange(age, desc(total_quantity)) %>%
  group_by(age) %>%
  slice_head(n = 1)

Exploratory Data Analysis

We began analyzing the data by looking at the top products in terms of volume sold during the week after the SuperBowl. Yogurt that is not in a multi-pack was the top selling item for the week, followed closely by milk as well as ramen noodles. This analysis will determine the effect SuperBowl advertising will have on spending habits of people at Regork.

# Convert product_type to factor with proper ordering 

top_selling_products$product_type <- factor(top_selling_products$product_type,  

                                            levels = top_selling_products$product_type[order(-top_selling_products$total_quantity)]) 

  

# Create a horizontal bar chart without legend 

ggplot(top_selling_products, aes(y = product_type, x = total_quantity, fill = product_type)) + 

  geom_bar(stat = "identity") + 

  labs(y = "Product Type", x = "Total Quantity Sold", title = "Top 10 Products Sold After Superbowl",  

       subtitle = "Top products sold in the week after the Super Bowl with Yogurt & Milk having the most purchases") + 

  theme(axis.text.y = element_text(angle = 0, hjust = 1),  # Adjust y-axis label alignment 

        legend.position = "none")

We then began to compare the top items that were also sold along with the yogurt. As you can see the number one item sold when yogurt was bought was chocolate milk at a third of the items. This diagram helped us to see which item to possibly bundle with the top selling item.

# Calculate percentage of total quantity sold for each product type 

top_selling_with_yogurt <- top_selling_with_yogurt %>% 

  mutate(percent_of_total = total_quantity / sum(total_quantity) * 100) 

  

# Create a pie chart with labels indicating the quantity in percentage 

ggplot(top_selling_with_yogurt, aes(x = "", y = total_quantity, fill = product_type)) + 

  geom_bar(stat = "identity", width = 1) +  # Create a bar chart 

  coord_polar("y", start = 0) +  # Convert the chart to a polar coordinate system to create a pie chart 

  geom_text(aes(label = paste0(round(percent_of_total, 1), "%")), position = position_stack(vjust = 0.5)) +  # Add text labels for percentages 

  labs(title = "Top Products Sold with Yogurt", subtitle = "Chocolate milk was the most purchased product along with Yogurt") +  # Add title 

  theme_void() +  # Remove background and gridlines 

  theme(legend.position = "right")  # Position legend

We then decided we should look at how people spend their money before the SuperBowl to see if that may have an effect on sales the following week. As seen in the graph, sales begin to increase at a rapid rate as the days get closer to the SuperBowl. This shows us that many people may do their shopping before which could cause different items to be sold the week following the SuperBowl.

# Filter transactions for the week before the Superbowl 

transactions_before_sb_week <- transactions_before_sb %>% 

  mutate(transaction_date = as.Date(transaction_timestamp)) %>% 

  filter(transaction_date >= start_date_before & transaction_date <= end_date_before) 

  

# Group by transaction date and calculate total spending for each day 

daily_spending_before_sb <- transactions_before_sb_week %>% 

  group_by(transaction_date) %>% 

  summarize(total_spending = sum(sales_value)) 

  

# Create a line graph for daily spending before the Superbowl 

ggplot(daily_spending_before_sb, aes(x = transaction_date, y = total_spending)) + 

  geom_line() + 

  labs(title = "Daily Spending Before Superbowl", subtitle = "Daily spending drastically increases the day before the Super Bowl", 

       x = "Date", y = "Total Spending") + 

  theme_minimal()

We then decided to look at total sales both in the week before, day of, and week after the SuperBowl. The week before had the highest sales, and the day of the SuperBowl was around the average expenditure around those two weeks. However, the main takeaway we had from this graph is that spending the day after the SuperBowl is extremely low, however as the week goes on sales seem to increase.

transactions_around_sb <- transactions %>% 

  mutate(transaction_date = as.Date(transaction_timestamp)) %>% 

  filter(transaction_date >= start_date_before & transaction_date <= end_date_after) 

  

# Group by transaction date and calculate total spending for each day 

daily_spending_around_sb <- transactions_around_sb %>% 

  group_by(transaction_date) %>% 

  summarize(total_spending = sum(sales_value)) 

  

# Create a line graph for daily spending around the SuperBowl 

  

ggplot(daily_spending_around_sb, aes(x = transaction_date, y = total_spending, color = factor(case_when( 

  transaction_date < start_date_after ~ "Before SuperBowl", 

  transaction_date == start_date_after ~ "Day of SuperBowl", 

  transaction_date > start_date_after ~ "After SuperBowl" 

)))) + 

  geom_line() + 

  geom_point(data = filter(daily_spending_around_sb, transaction_date == start_date_after),  

             aes(x = transaction_date, y = total_spending),  

             size = 5, shape = 21, fill = "red") +  # Add big dot for the day of SuperBowl 

  labs(title = "Daily Spending Around SuperBowl", subtitle = "Daily spending declines the day of the Super Bowl but climbs after", 

       x = "Date", y = "Total Spending", color = "Period") + 

  theme_minimal() + 

  scale_color_manual(values = c("Before SuperBowl" = "black", "Day of SuperBowl" = "red", "After SuperBowl" = "black"), 

                     labels = c("Before SuperBowl", "Day of SuperBowl", "After SuperBowl"), 

                     breaks = c("Before SuperBowl", "Day of SuperBowl", "After SuperBowl"), 

                     guide = guide_legend(override.aes = list(shape = c(NA, 21, NA))))

After this we decided to see what was being sold the week leading up to the SuperBowl in order to see if there was a common trend between the two weeks. As you can see from the chart the top selling product the week before was 12 packs of soft drinks, and yogurt was only the seventh highest item on the list.

# Convert product_type to factor with proper ordering 

top_selling_products_before$product_type <- factor(top_selling_products_before$product_type,  

                                                   levels = top_selling_products_before$product_type[order(-top_selling_products_before$total_quantity)]) 

# Create a horizontal bar chart 

ggplot(top_selling_products_before, aes(y = product_type, x = total_quantity, fill = product_type)) + 

  geom_bar(stat = "identity") + 

  labs(y = "Product Type", subtitle = "Top products sold in the week after the Super Bowl with Soft Drinks & Ramen having the most purchases", 

       x = "Total Quantity Sold", title = "Top 10 Products Bought Before Superbowl") + 

  theme(axis.text.y = element_text(size = 8)) +  # Adjust text size for y-axis labels 

  theme(legend.position = "none")  # Remove legend

We then decided to look at the quantity of products each age range bought both before and after the SuperBowl to see which age range to target in which promotions. As seen in the data the age range 35-44 had the highest sales in the week before the SuperBowl, but they had a drastic drop the week after the SuperBowl. This leads us to believe that it is important to shift our focus from that age group to the 25-34 and 45-54 years old age groups.

# Combine the top products bought before and after the SuperBowl for each age demographic 

combined_top_products <- rbind( 

  mutate(top_products_by_age_before, Period = "Before Superbowl"), 

  mutate(top_products_by_age_after, Period = "After Superbowl") 

) 

  

# Reorder the levels of the Period factor 

combined_top_products$Period <- factor(combined_top_products$Period, levels = c("Before Superbowl", "After Superbowl")) 

  

# Create a grouped bar chart with "Before Superbowl" on the left and "After SuperBowl" on the right 

ggplot(combined_top_products, aes(x = age, y = total_quantity, fill = Period)) + 

  geom_bar(stat = "identity", position = "dodge") + 

  labs( 

    x = "Age", 

    y = "Total Quantity", 

    title = "Top Products Bought Before and After Superbowl by Age Demographic", 

    subtitle = "Comparison of top products bought before and after Superbowl for each age group" 

  ) + 

  theme_minimal()

Summary

Overall, we found that yogurt was the top selling product after the SuperBowl, as seen in Top 10 Products Sold After the SuperBowl. We can also see that chocolate milk is the top product bought when yogurt is bought, as seen in Top Products Sold With Yogurt. Because of this data we believe that pairing yogurt with chocolate milk in a deal can increase sales for Regork.

Who is buying these products? Well we found that the age groups 35-44 and 45-54 are the age groups who bought yogurt the most during the week after the SuperBowl.

However, in the chart Daily Spending Around SuperBowl we were able to see that the day after the SuperBowl sales are very low, but after that there is a steady increase throughout the week.

Our recommendations are to: make sure inventory is up to capacity for high demand products leading up to the super bowl, create product bundles with the popular items with limited time offers and promotions, and offer additional promotion for the week after the Super Bowl to reduce inventory and keep customer / sales retention on pace.

The implications this will have for customers is: customers will have access to items during a period with high demand, customers will be more likely to return to Regork and continue to give their business, and there will be an incentive to the customer to buy more top selling items giving Regork more revenue.

The limitations of this are: products only were from grocery store items, customers could have purchased Super Bowl items weeks in advanced, and customers could have purchased items regardless if the Super Bowl was held.

Our conclusion is that SuperBowl ads may have a little bit of a sway on people, but not enough to warrant creating a deal based on the ads seen in between the game.