RFM Customer Segmentation — Who Are Your Best Customers?

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))

parse_dates_multi <- function(x) {
  if (inherits(x, "Date")) return(x)
  if (inherits(x, "POSIXct") || inherits(x, "POSIXlt")) return(as.Date(x))
  s <- trimws(as.character(x))
  s[is.na(s) | s == ""] <- NA_character_
  fmts <- c("%Y-%m-%d", "%Y/%m/%d", "%m/%d/%Y", "%d/%m/%Y", "%m-%d-%Y",
            "%d-%m-%Y", "%d.%m.%Y", "%b %d, %Y", "%B %d, %Y",
            "%d %b %Y", "%d %B %Y")
  parsed <- lapply(fmts, function(f) suppressWarnings(as.Date(s, format = f)))
  counts <- vapply(parsed, function(p) sum(!is.na(p)), integer(1))
  best <- parsed[[which.max(counts)]]   # counts is never all-NA (integer counts)
  for (p in parsed[order(-counts)]) {
    fill <- is.na(best) & !is.na(p)
    if (any(fill)) best[fill] <- p[fill]
  }
  best
}

score_quintile <- function(x, higher_is_better = TRUE) {
  n <- length(x)
  ux <- unique(x)
  if (length(ux) <= 1) return(rep(3L, n))
  sc <- NULL
  if (length(ux) >= 5) {
    br <- quantile(x, probs = seq(0, 1, 0.2), type = 1, na.rm = TRUE)
    if (length(unique(br)) == 6) {
      sc <- as.integer(cut(x, breaks = br, include.lowest = TRUE, labels = FALSE))
    }
  }
  if (is.null(sc)) {
    r <- rank(x, ties.method = "average")
    sc <- as.integer(ceiling(r * 5 / n))
  }
  sc <- pmin(pmax(sc, 1L), 5L)
  if (!higher_is_better) sc <- 6L - sc
  sc
}

assign_segments <- function(R, F_) {
  seg <- rep("Need Attention", length(R))
  seg[R <= 2 & F_ <= 2] <- "Hibernating"
  seg[R <= 2 & F_ >= 3] <- "At Risk"
  seg[R == 1 & F_ >= 4] <- "Can&#x27;t Lose Them"
  seg[R >= 4 & F_ == 1] <- "New Customers"
  seg[R >= 4 & F_ %in% 2:3] <- "Potential Loyalist"
  seg[R >= 3 & F_ >= 4] <- "Loyal"
  seg[R >= 4 & F_ >= 4] <- "Champions"
  seg
}

SEGMENT_ORDER <- c("Champions", "Loyal", "Potential Loyalist", "New Customers",
                   "At Risk", "Can&#x27;t Lose Them", "Need Attention", "Hibernating")

compute_shared <- function(df, params, col_map = list()) {
  # === SHARED EXPORTS ===
  #   initial_rows/final_rows/rows_removed   $ row accounting
  #   n_missing_id / n_bad_dates / n_missing_value / n_negative  $ preprocessing counts
  #   negative_total    $ numeric — summed value of negative (refund) orders
  #   id_name/date_name/value_name  $ humanized user column names
  #   ref_date / date_min / date_max $ Date — reference + observed range
  #   customer_df       $ data.frame(customer, recency_days, frequency,
  #                       monetary, recency_score, frequency_score,
  #                       monetary_score, segment) — one row per customer
  #   seg_stats         $ data.frame(segment, customers, share_pct,
  #                       total_value, avg_value, avg_recency_days)
  #   segment_sizes_df / segment_value_df / rf_grid_df / monetary_by_segment_df
  #   n_customers       $ integer
  #   total_revenue     $ numeric — sum of all order values
  #   biggest_segment / biggest_share          $ by customer count
  #   top_rev_segment / top_rev_share          $ revenue concentration
  #   at_risk_revenue / at_risk_rev_share      $ At Risk + Can't Lose Them
  #   metrics / json_output
  # === /SHARED EXPORTS ===

initial_rows <- nrow(df)
  id_name    <- humanize_semantic("customer_id", col_map)[1]
  date_name  <- humanize_semantic("order_date", col_map)[1]
  value_name <- humanize_semantic("order_value", col_map)[1]
  for (need in c("customer_id", "order_date", "order_value")) {
    if (!need %in% names(df)) {
      stop(sprintf("Required column &#x27;%s' is not mapped.",
                   humanize_semantic(need, col_map)[1]))
    }
  }

cid <- trimws(as.character(df$customer_id))
  keep_id <- !is.na(cid) & cid != ""
  n_missing_id <- sum(!keep_id)
  df <- df[keep_id, , drop = FALSE]
  cid <- cid[keep_id]

dts <- parse_dates_multi(df$order_date)
  n_bad_dates <- sum(is.na(dts))
  if (nrow(df) > 0 && n_bad_dates / nrow(df) > 0.05) {
    stop(sprintf(
      paste0("Could not read %s of %s values in &#x27;%s' as dates (%.1f%%). ",
             "More than 5%% of the order dates are unparseable — please ",
             "check the date format of that column."),
      format(n_bad_dates, big.mark = ","), format(nrow(df), big.mark = ","),
      date_name, 100 * n_bad_dates / nrow(df)))
  }
  keep_dt <- !is.na(dts)
  df <- df[keep_dt, , drop = FALSE]
  cid <- cid[keep_dt]
  dts <- dts[keep_dt]

val <- df$order_value
  if (!is.numeric(val)) {
    conv <- suppressWarnings(as.numeric(as.character(val)))
    n_orig <- sum(!is.na(val) & trimws(as.character(val)) != "")
    if (n_orig == 0 || sum(!is.na(conv)) < 0.95 * n_orig) {
      stop(sprintf(
        "Column &#x27;%s' is not numeric enough to use as an order amount — fewer than 95%% of its values could be read as numbers.",
        value_name))
    }
    val <- conv
  }
  keep_val <- !is.na(val)
  n_missing_value <- sum(!keep_val)
  cid <- cid[keep_val]
  dts <- dts[keep_val]
  val <- val[keep_val]
  n_negative <- sum(val < 0)
  negative_total <- if (n_negative > 0) sum(val[val < 0]) else 0

  final_rows <- length(val)
  rows_removed <- initial_rows - final_rows
  if (final_rows < 30) {
    stop(sprintf(
      "Only %d usable orders remain after cleaning &#x27;%s', '%s', and '%s' — need at least 30.",
      final_rows, id_name, date_name, value_name))
  }

ref_date <- max(dts)
  date_min <- min(dts)
  date_max <- ref_date

  tx <- data.frame(customer = cid, order_date = dts, order_value = val,
                   stringsAsFactors = FALSE)
  customer_df <- tx %>%
    group_by(customer) %>%
    summarise(
      recency_days = as.numeric(ref_date - max(order_date)),
      frequency    = n(),
      monetary     = sum(order_value),
      .groups = "drop"
    ) %>%
    as.data.frame(stringsAsFactors = FALSE)

  n_customers <- nrow(customer_df)
  if (n_customers < 5) {
    stop(sprintf(
      "Only %d distinct customers found in &#x27;%s' — RFM segmentation needs at least 5.",
      n_customers, id_name))
  }

customer_df$recency_score   <- score_quintile(customer_df$recency_days,
                                                higher_is_better = FALSE)
  customer_df$frequency_score <- score_quintile(customer_df$frequency)
  customer_df$monetary_score  <- score_quintile(customer_df$monetary)
  customer_df$segment <- assign_segments(customer_df$recency_score,
                                         customer_df$frequency_score)

total_revenue <- sum(customer_df$monetary)
  seg_stats <- customer_df %>%
    group_by(segment) %>%
    summarise(
      customers        = n(),
      total_value      = round(sum(monetary), 2),
      avg_value        = round(mean(monetary), 2),
      avg_recency_days = round(mean(recency_days), 1),
      .groups = "drop"
    ) %>%
    mutate(share_pct = round(100 * customers / n_customers, 1)) %>%
    as.data.frame(stringsAsFactors = FALSE)
  seg_stats$segment <- factor(seg_stats$segment, levels = SEGMENT_ORDER)
  seg_stats <- seg_stats[order(seg_stats$segment), , drop = FALSE]
  seg_stats$segment <- as.character(seg_stats$segment)
  rownames(seg_stats) <- NULL

by_size <- seg_stats[order(-seg_stats$customers), , drop = FALSE]
  biggest_segment <- by_size$segment[1]
  biggest_share   <- by_size$share_pct[1]
  by_rev <- seg_stats[order(-seg_stats$total_value), , drop = FALSE]
  top_rev_segment <- by_rev$segment[1]
  top_rev_share   <- if (total_revenue != 0)
    round(100 * by_rev$total_value[1] / total_revenue, 1) else NA_real_
  at_risk_segments <- c("At Risk", "Can&#x27;t Lose Them")
  at_risk_revenue  <- round(sum(seg_stats$total_value[
    seg_stats$segment %in% at_risk_segments]), 2)
  at_risk_rev_share <- if (total_revenue != 0)
    round(100 * at_risk_revenue / total_revenue, 1) else NA_real_

segment_value_df$total_value <- format(round(segment_value_df$total_value, 0),
                                         big.mark = ",", scientific = FALSE,
                                         trim = TRUE)
  segment_value_df$avg_value <- format(round(segment_value_df$avg_value, 0),
                                       big.mark = ",", scientific = FALSE,
                                       trim = TRUE)
  rownames(segment_value_df) <- NULL

  grid <- expand.grid(r = 1:5, f = 1:5)
  rf_grid_df <- data.frame(
    recency_score   = paste0("R", grid$r),
    frequency_score = paste0("F", grid$f),
    customers = mapply(function(r, f) {
      sum(customer_df$recency_score == r & customer_df$frequency_score == f)
    }, grid$r, grid$f),
    stringsAsFactors = FALSE
  )

  monetary_by_segment_df <- seg_stats[, c("segment", "avg_value")]
  names(monetary_by_segment_df) <- c("segment", "avg_customer_value")
  monetary_by_segment_df <- monetary_by_segment_df[
    order(-monetary_by_segment_df$avg_customer_value), , drop = FALSE]
  rownames(monetary_by_segment_df) <- NULL

  metrics <- list(
    `Customers`             = n_customers,
    `Orders`                = final_rows,
    `Segments`              = nrow(seg_stats),
    `Biggest Segment`       = biggest_segment,
    `Top Segment Revenue %` = top_rev_share,
    `At-Risk Revenue`       = at_risk_revenue
  )

  json_output <- list(
    answer = paste0(
      "RFM segmentation of ", format(n_customers, big.mark = ","),
      " customers across ", format(final_rows, big.mark = ","),
      " orders(", format(date_min), " to ", format(date_max), "): ",
      "the biggest segment is ", biggest_segment, " (", biggest_share,
      "% of customers); ", top_rev_segment, " concentrates ", top_rev_share,
      "% of total revenue; ",
      format(round(at_risk_revenue), big.mark = ","), " (",
      at_risk_rev_share, "% of revenue) sits with At Risk / Can&#x27;t Lose Them ",
      "customers and is the immediate win-back opportunity."
    ),
    cards = lapply(
      c("tldr", "overview", "preprocessing", "segment_sizes",
        "segment_value", "rf_grid", "monetary_by_segment"),
      function(cid) list(id = cid, metrics = metrics)
    )
  )

  list(
    initial_rows = initial_rows, final_rows = final_rows,
    rows_removed = rows_removed,
    n_missing_id = n_missing_id, n_bad_dates = n_bad_dates,
    n_missing_value = n_missing_value,
    n_negative = n_negative, negative_total = negative_total,
    id_name = id_name, date_name = date_name, value_name = value_name,
    ref_date = ref_date, date_min = date_min, date_max = date_max,
    customer_df = customer_df, seg_stats = seg_stats,
    segment_sizes_df = segment_sizes_df,
    segment_value_df = segment_value_df,
    rf_grid_df = rf_grid_df,
    monetary_by_segment_df = monetary_by_segment_df,
    n_customers = n_customers, total_revenue = total_revenue,
    biggest_segment = biggest_segment, biggest_share = biggest_share,
    top_rev_segment = top_rev_segment, top_rev_share = top_rev_share,
    at_risk_revenue = at_risk_revenue, at_risk_rev_share = at_risk_rev_share,
    metrics = metrics, json_output = json_output
  )
}