Market Basket — What Sells Together

suppressPackageStartupMessages(library(DT))
suppressPackageStartupMessages(library(htmlwidgets))
suppressPackageStartupMessages(library(arrow))
suppressPackageStartupMessages(library(knitr))
suppressPackageStartupMessages(library(rmarkdown))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(tidyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(stringr))
suppressPackageStartupMessages(library(lubridate))
suppressPackageStartupMessages(library(broom))
suppressPackageStartupMessages(library(Matrix))
suppressPackageStartupMessages(library(cluster))
suppressPackageStartupMessages(library(data.table))

initial_rows <- nrow(df)
  for (k in c("order_id", "item")) {
    if (!k %in% names(df)) {
      stop(sprintf("column_mapping must map &#x27;%s' to a column in the transaction log.", k))
    }
  }
  name_order <- humanize_semantic("order_id", col_map)
  name_item  <- humanize_semantic("item", col_map)

oid <- trimws(as.character(df[["order_id"]]))
  itm <- trimws(as.character(df[["item"]]))
  bad <- is.na(oid) | oid == "" | is.na(itm) | itm == ""
  n_bad_rows <- sum(bad)
  oid <- oid[!bad]; itm <- itm[!bad]
  final_rows <- length(oid)
  rows_removed <- initial_rows - final_rows
  if (final_rows < 1) {
    stop(sprintf("No usable rows: every row was missing an %s or an %s.",
                 name_order, name_item))
  }

basket_list <- split(itm, oid)
  basket_list <- lapply(basket_list, unique)
  basket_list <- basket_list[lengths(basket_list) >= 1]
  n_orders <- length(basket_list)
  if (n_orders < 10) {
    stop(sprintf("Only %s reconstructed from %s — market basket analysis needs at least 10 orders.",
                 plural(n_orders, "basket"), name_order))
  }

all_items <- unlist(basket_list, use.names = FALSE)   # each item once per basket (deduped)
  item_freq0 <- sort(table(all_items), decreasing = TRUE)
  n_distinct_items <- length(item_freq0)                # original distinct count
  if (n_distinct_items < 2) {
    stop(sprintf("Only one distinct %s appears across the orders — pairing needs at least two distinct items.",
                 name_item))
  }

MAX_ITEMS <- 40
  keep_items <- names(item_freq0)[seq_len(min(MAX_ITEMS, n_distinct_items))]
  lumped_items <- setdiff(names(item_freq0), keep_items)
  n_lumped <- length(lumped_items)
  if (n_lumped > 0) {
    basket_list <- lapply(basket_list, function(b) {
      b[b %in% lumped_items] <- "Other"
      unique(b)
    })
  }

all_items2 <- unlist(basket_list, use.names = FALSE)
  item_freq <- sort(table(all_items2), decreasing = TRUE)
  avg_basket <- mean(lengths(basket_list))

  item_freq_df <- data.frame(
    item = names(item_freq),
    orders_pct = round(100 * as.integer(item_freq) / n_orders, 1),
    stringsAsFactors = FALSE
  )
  top_items_df <- head(item_freq_df, 15)

real_freq_df <- item_freq_df[item_freq_df$item != "Other", , drop = FALSE]
  top_item <- real_freq_df$item[1]
  top_item_pct <- real_freq_df$orders_pct[1]

pairable <- setdiff(names(item_freq), "Other")
  pairable <- pairable[seq_len(min(MAX_ITEMS, length(pairable)))]
  k <- length(pairable)

M <- matrix(0L, nrow = n_orders, ncol = k, dimnames = list(NULL, pairable))
  for (o in seq_len(n_orders)) {
    hit <- basket_list[[o]][basket_list[[o]] %in% pairable]
    if (length(hit)) M[o, hit] <- 1L
  }
  Co <- crossprod(M)            # k x k co-occurrence; diagonal = item basket count
  cnt <- diag(Co)               # baskets containing each pairable item

min_support_orders <- max(2L, as.integer(ceiling(0.005 * n_orders)))

a_vec <- character(0); b_vec <- character(0); co_vec <- integer(0)
  if (k >= 2) {
    for (i in seq_len(k - 1)) {
      for (j in (i + 1):k) {
        co_ij <- Co[i, j]
        if (co_ij >= min_support_orders) {
          a_vec <- c(a_vec, pairable[i])
          b_vec <- c(b_vec, pairable[j])
          co_vec <- c(co_vec, co_ij)
        }
      }
    }
  }
  n_qual <- length(co_vec)
  no_assoc <- n_qual == 0

  empty_rules <- data.frame(item_a = character(0), item_b = character(0),
                            support_pct = numeric(0), confidence_pct = numeric(0),
                            lift = numeric(0), stringsAsFactors = FALSE)
  empty_cross <- data.frame(if_they_buy = character(0), recommend = character(0),
                            confidence_pct = numeric(0), lift = numeric(0),
                            stringsAsFactors = FALSE)

  if (no_assoc) {
    pairs_all <- NULL
    rules_df <- empty_rules
    cross_sell_df <- empty_cross
    top_pair <- NULL
  } else {
    cnt_a <- as.integer(cnt[a_vec]); cnt_b <- as.integer(cnt[b_vec])
    support <- co_vec / n_orders
    conf_ab <- co_vec / cnt_a       # P(item_b | item_a)
    conf_ba <- co_vec / cnt_b       # P(item_a | item_b)
    lift    <- (co_vec * n_orders) / (cnt_a * cnt_b)

swap <- conf_ba > conf_ab
    ia <- ifelse(swap, b_vec, a_vec)
    ib <- ifelse(swap, a_vec, b_vec)
    conf_dir <- pmax(conf_ab, conf_ba)

    pairs_all <- data.frame(
      item_a = ia, item_b = ib,
      support = support,
      support_pct = round(100 * support, 2),
      confidence = conf_dir,
      confidence_pct = round(100 * conf_dir, 1),
      lift = round(lift, 2),
      co = as.integer(co_vec),
      stringsAsFactors = FALSE
    )

pairs_all <- pairs_all[order(-pairs_all$lift, -pairs_all$support), , drop = FALSE]
    rownames(pairs_all) <- NULL
    rules_df <- head(pairs_all[, c("item_a", "item_b", "support_pct",
                                   "confidence_pct", "lift")], 15)
    rownames(rules_df) <- NULL

top_pair <- pairs_all[1, , drop = FALSE]

dir_df <- data.frame(
      if_they_buy = c(a_vec, b_vec),
      recommend   = c(b_vec, a_vec),
      confidence_pct = round(100 * c(conf_ab, conf_ba), 1),
      lift = round(c(lift, lift), 2),
      stringsAsFactors = FALSE
    )
    dir_df <- dir_df[dir_df$lift > 1, , drop = FALSE]
    if (nrow(dir_df) > 0) {
      dir_df <- dir_df[order(-dir_df$confidence_pct, -dir_df$lift), , drop = FALSE]
      cross_sell_df <- head(dir_df, 15)
    } else {
      cross_sell_df <- empty_cross
    }
    rownames(cross_sell_df) <- NULL
  }

metrics <- list(
    `Orders`            = as.integer(n_orders),
    `Distinct Items`    = as.integer(n_distinct_items),
    `Avg Basket Size`   = round(avg_basket, 2),
    `Qualifying Pairs`  = as.integer(n_qual),
    `Top Pairing`       = if (no_assoc) "none" else paste0(top_pair$item_a, " + ", top_pair$item_b),
    `Top Pairing Lift`  = if (no_assoc) 0 else top_pair$lift
  )

  json_output <- list(
    answer = if (no_assoc) {
      paste0(
        "Across ", plural(n_orders, "order"), " (average basket ",
        round(avg_basket, 1), " items), no product pair cleared the support floor of ",
        plural(min_support_orders, "basket"),
        ", so no strong associations were found. The most-bought ", name_item,
        " is ", top_item, ", in ", top_item_pct, "% of orders."
      )
    } else {
      paste0(
        "Across ", plural(n_orders, "order"), ", the strongest product pairing is ",
        top_pair$item_a, " and ", top_pair$item_b, ": shoppers who buy ",
        top_pair$item_a, " also buy ", top_pair$item_b, " ", top_pair$confidence_pct,
        "% of the time, a lift of ", top_pair$lift, " (bought together ", top_pair$lift,
        " times more often than chance). ", plural(n_qual, "pair"),
        " cleared the support floor. The most-bought ", name_item, " is ",
        top_item, ", in ", top_item_pct, "% of orders."
      )
    },
    cards = lapply(
      c("tldr", "overview", "preprocessing", "top_items",
        "association_rules", "cross_sell"),
      function(cid) list(id = cid, metrics = metrics)
    )
  )

  list(
    initial_rows = initial_rows, final_rows = final_rows, rows_removed = rows_removed,
    name_order = name_order, name_item = name_item,
    n_orders = n_orders, n_distinct_items = n_distinct_items,
    avg_basket = avg_basket, n_bad_rows = n_bad_rows, n_lumped = n_lumped,
    item_freq_df = item_freq_df, top_items_df = top_items_df,
    top_item = top_item, top_item_pct = top_item_pct,
    pairs_all = pairs_all, rules_df = rules_df, cross_sell_df = cross_sell_df,
    top_pair = top_pair, no_assoc = no_assoc,
    min_support_orders = min_support_orders,
    metrics = metrics, json_output = json_output
  )
}

# Card: tldr (tldr)
card_tldr <- function(shared, df, params) {
  if (shared$no_assoc) {
    text <- paste0(
      "Across ", plural(shared$n_orders, "order"), " (average basket ",
      round(shared$avg_basket, 1), " items), no product pair appeared together in at least ",
      plural(shared$min_support_orders, "basket"),
      ", so no strong co-purchase associations were found. The single most-bought ",
      shared$name_item, " is ", shared$top_item, ", appearing in ",
      shared$top_item_pct, "% of orders. With more transactions or a more ",
      "concentrated catalog, clearer pairings tend to emerge."
    )
  } else {
    tp <- shared$top_pair
    text <- paste0(
      "Across ", plural(shared$n_orders, "order"), " with an average basket of ",
      round(shared$avg_basket, 1), " items, the strongest product pairing is ",
      tp$item_a, " and ", tp$item_b, ": shoppers who buy ", tp$item_a,
      " also buy ", tp$item_b, " ", tp$confidence_pct, "% of the time, a lift of ",
      tp$lift, " — they land in the same basket ", tp$lift,
      " times more often than if the two were bought independently. The most-bought ",
      shared$name_item, " overall is ", shared$top_item, ", in ",
      shared$top_item_pct, "% of orders. These are co-purchase patterns to act on for ",
      "cross-sell, bundling, and layout; they show what sells together, not proof that one item drives the other."
    )
  }
  list(
    title = "Executive Summary",
    description = paste0("What sells together across ", plural(shared$n_orders, "order"), "."),
    metrics = shared$metrics,
    text = text
  )
}