Cohort Retention Analysis — How Well Do You Keep Your 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))

compute_shared <- function(df, params, col_map = list()) {
  # === SHARED EXPORTS ===
  #   initial_rows/final_rows/rows_removed  $ row accounting
  #   cust_h / date_h        $ humanized user column names
  #   n_customers            $ unique customers analysed
  #   cohort_labels          $ character — "YYYY-MM" per cohort (chronological)
  #   cohort_sizes_vec       $ integer — new customers per cohort
  #   n_excluded_cohorts     $ cohorts older than the 24-cohort cap
  #   date_min / date_max    $ Date — observed activity range
  #   matrix_df              $ data.frame(cohort, month_number, retention_pct) — observable cells only
  #   curve_df               $ data.frame(month_label, avg_retention_pct) — right-censoring-aware
  #   sizes_df               $ data.frame(cohort, new_customers)
  #   comparison_df          $ data.frame(cohort, size, m1/m3/m6_retention_pct) — NA when unobservable
  #   m1_overall/m3_overall/m6_overall $ weighted avg retention (NA if unobservable)
  #   m1_by_cohort           $ numeric — per-cohort M1 retention (NA if unobservable)
  #   best_cohort/worst_cohort + _m1   $ best/worst cohort at month 1
  #   trend_word/trend_first/trend_second/trend_n $ first-half vs second-half M1 verdict
  #   metrics / json_output
  # === /SHARED EXPORTS ===

  MAX_MONTHS  <- 12L   # retention horizon: M0..M12
  MAX_COHORTS <- 24L   # keep the most recent 24 cohorts

  initial_rows <- nrow(df)
  cust_h <- humanize_semantic("customer_id", col_map)
  date_h <- humanize_semantic("activity_date", col_map)

if (!("customer_id" %in% names(df)) || !("activity_date" %in% names(df))) {
    stop(sprintf("Cohort retention needs both a customer column(%s) and an activity date column(%s) mapped.",
                 cust_h, date_h))
  }
  cust <- trimws(as.character(df$customer_id))
  raw_dates <- df$activity_date
  dts <- parse_activity_dates(raw_dates)
  n_nonblank <- sum(!is.na(raw_dates) & trimws(as.character(raw_dates)) != "")
  if (n_nonblank == 0 || sum(!is.na(dts)) < 0.95 * n_nonblank) {
    stop(sprintf("The %s column could not be read as dates — expected values like 2024-01-31 or 1/31/2024.",
                 date_h))
  }

  keep <- !is.na(dts) & !is.na(cust) & cust != ""
  cust <- cust[keep]
  dts  <- dts[keep]
  rows_bad <- initial_rows - sum(keep)
  if (length(dts) < 2) {
    stop(sprintf("Too few usable rows after cleaning — check %s and %s for blanks.", cust_h, date_h))
  }

act_idx <- month_index(dts)
  cohort_by_cust <- tapply(act_idx, cust, min)   # named: customer -> cohort month index
  all_cohorts <- sort(unique(as.integer(cohort_by_cust)))

n_excluded_cohorts <- 0L
  if (length(all_cohorts) > MAX_COHORTS) {
    n_excluded_cohorts <- length(all_cohorts) - MAX_COHORTS
    all_cohorts <- tail(all_cohorts, MAX_COHORTS)
  }
  cust_cohort <- as.integer(cohort_by_cust[cust])  # per-row cohort of the row's customer
  in_scope <- cust_cohort %in% all_cohorts
  cust <- cust[in_scope]; dts <- dts[in_scope]
  act_idx <- act_idx[in_scope]; cust_cohort <- cust_cohort[in_scope]

  final_rows <- length(cust)
  rows_removed <- initial_rows - final_rows
  max_idx <- max(act_idx)
  date_min <- min(dts); date_max <- max(dts)

if (length(all_cohorts) < 2) {
    stop(sprintf("Cohort retention needs customers arriving in at least two different calendar months — every %s in this data first appears in %s. A longer %s range is required.",
                 cust_h, month_label(all_cohorts[1]), date_h))
  }
  if (max_idx - min(all_cohorts) < 1) {
    stop(sprintf("The %s column spans a single calendar month — at least two months of activity are needed to measure retention.",
                 date_h))
  }

  cohort_labels <- month_label(all_cohorts)

cust_first <- tapply(act_idx, cust, min)
  cohort_sizes_vec <- as.integer(sapply(all_cohorts, function(cc)
    sum(as.integer(cust_first) == cc)))
  n_customers <- length(cust_first)

month_number <- act_idx - cust_cohort
  um <- unique(data.frame(cohort = cust_cohort, m = month_number, id = cust,
                          stringsAsFactors = FALSE))
  k <- length(all_cohorts)
  active_mat <- matrix(0L, nrow = k, ncol = MAX_MONTHS + 1L)  # counts, cols = M0..M12
  obs_mat    <- matrix(FALSE, nrow = k, ncol = MAX_MONTHS + 1L)
  for (i in seq_len(k)) {
    cc <- all_cohorts[i]
    max_obs_m <- min(MAX_MONTHS, max_idx - cc)   # right-censoring boundary
    for (m in 0:max_obs_m) {
      obs_mat[i, m + 1L] <- TRUE
      active_mat[i, m + 1L] <- sum(um$cohort == cc & um$m == m)
    }
  }
  ret_mat <- 100 * sweep(active_mat, 1, cohort_sizes_vec, "/")   # row-wise: cell / cohort size

cells <- which(obs_mat, arr.ind = TRUE)
  cells <- cells[order(cells[, 1], cells[, 2]), , drop = FALSE]
  matrix_df <- data.frame(
    cohort = cohort_labels[cells[, 1]],
    month_number = paste0("M", cells[, 2] - 1L),
    retention_pct = round(ret_mat[cells], 1),
    stringsAsFactors = FALSE
  )
  rownames(matrix_df) <- NULL

max_m <- min(MAX_MONTHS, max_idx - min(all_cohorts))
  curve_vals <- sapply(0:max_m, function(m) {
    elig <- which(obs_mat[, m + 1L])             # cohorts that have lived m months
    100 * sum(active_mat[elig, m + 1L]) / sum(cohort_sizes_vec[elig])
  })
  curve_df <- data.frame(
    month_label = paste0("M", 0:max_m),
    avg_retention_pct = round(curve_vals, 1),
    stringsAsFactors = FALSE
  )

  sizes_df <- data.frame(cohort = cohort_labels,
                         new_customers = cohort_sizes_vec,
                         stringsAsFactors = FALSE)

ret_at <- function(m) if (max_m >= m) round(curve_vals[m + 1L], 1) else NA_real_
  m1_overall <- ret_at(1); m3_overall <- ret_at(3); m6_overall <- ret_at(6)

  cohort_ret_at <- function(m) {
    v <- rep(NA_real_, k)
    obs <- obs_mat[, m + 1L]
    v[obs] <- round(ret_mat[obs, m + 1L], 1)
    v
  }
  m1_by_cohort <- cohort_ret_at(1)
  m3_by_cohort <- cohort_ret_at(3)
  m6_by_cohort <- cohort_ret_at(6)

obs1 <- which(!is.na(m1_by_cohort))
  best_cohort <- worst_cohort <- NA_character_
  best_cohort_m1 <- worst_cohort_m1 <- NA_real_
  if (length(obs1) > 0) {
    bi <- obs1[which.max(m1_by_cohort[obs1])]
    wi <- obs1[which.min(m1_by_cohort[obs1])]
    best_cohort <- cohort_labels[bi];  best_cohort_m1 <- m1_by_cohort[bi]
    worst_cohort <- cohort_labels[wi]; worst_cohort_m1 <- m1_by_cohort[wi]
  }

trend_word <- "not assessable"
  trend_first <- trend_second <- NA_real_
  trend_n <- length(obs1)
  if (trend_n >= 4) {
    m1s <- m1_by_cohort[obs1]                     # chronological (cohorts sorted)
    half <- floor(trend_n / 2)
    trend_first  <- round(mean(head(m1s, half)), 1)
    trend_second <- round(mean(tail(m1s, half)), 1)
    d <- trend_second - trend_first
    trend_word <- if (d >= 2) "improving" else if (d <= -2) "declining" else "stable"
  }

  comparison_df <- data.frame(
    cohort = cohort_labels,
    size = cohort_sizes_vec,
    m1_retention_pct = m1_by_cohort,
    m3_retention_pct = m3_by_cohort,
    m6_retention_pct = m6_by_cohort,
    stringsAsFactors = FALSE
  )

  metrics <- list(
    `Customers`            = n_customers,
    `Cohorts`              = k,
    `Month-1 Retention %`  = m1_overall,
    `Best Cohort(M1)`     = if (!is.na(best_cohort)) sprintf("%s(%.1f%%)", best_cohort, best_cohort_m1) else "n/a",
    `Retention Trend`      = trend_word
  )
  if (!is.na(m3_overall)) metrics$`Month-3 Retention %` <- m3_overall
  if (!is.na(m6_overall)) metrics$`Month-6 Retention %` <- m6_overall

  trend_phrase <- switch(trend_word,
    improving = sprintf("newer cohorts are retaining BETTER(month-1: %.1f%% recent vs %.1f%% early)", trend_second, trend_first),
    declining = sprintf("newer cohorts are retaining WORSE(month-1: %.1f%% recent vs %.1f%% early)", trend_second, trend_first),
    stable    = sprintf("retention is stable across cohorts(month-1: %.1f%% recent vs %.1f%% early)", trend_second, trend_first),
    "too few cohorts to assess a trend")

  json_output <- list(
    answer = paste0(
      "Monthly cohort retention on ", format(n_customers, big.mark = ","),
      " customers across ", k, " cohorts(", cohort_labels[1], " to ",
      cohort_labels[k], "): month-1 retention is ",
      if (!is.na(m1_overall)) paste0(m1_overall, "%") else "unobservable",
      if (!is.na(m3_overall)) paste0(", month-3 is ", m3_overall, "%") else "",
      "; ", trend_phrase, ". Best cohort at month 1: ",
      if (!is.na(best_cohort)) paste0(best_cohort, " (", best_cohort_m1, "%)") else "n/a", "."
    ),
    cards = lapply(
      c("tldr", "overview", "preprocessing", "retention_heatmap",
        "retention_curve", "cohort_sizes", "cohort_comparison"),
      function(cid) list(id = cid, metrics = metrics)
    )
  )

  list(
    initial_rows = initial_rows, final_rows = final_rows,
    rows_removed = rows_removed, rows_bad = rows_bad,
    cust_h = cust_h, date_h = date_h,
    n_customers = n_customers,
    cohort_labels = cohort_labels, cohort_sizes_vec = cohort_sizes_vec,
    n_excluded_cohorts = n_excluded_cohorts,
    date_min = date_min, date_max = date_max, max_m = max_m,
    matrix_df = matrix_df, curve_df = curve_df, sizes_df = sizes_df,
    comparison_df = comparison_df,
    m1_overall = m1_overall, m3_overall = m3_overall, m6_overall = m6_overall,
    m1_by_cohort = m1_by_cohort,
    best_cohort = best_cohort, best_cohort_m1 = best_cohort_m1,
    worst_cohort = worst_cohort, worst_cohort_m1 = worst_cohort_m1,
    trend_word = trend_word, trend_first = trend_first,
    trend_second = trend_second, trend_n = trend_n,
    metrics = metrics, json_output = json_output
  )
}

no_m1 <- shared$cohort_labels[is.na(shared$m1_by_cohort)]
  censor_note <- if (length(no_m1) > 0) {
    paste0(" ", paste(no_m1, collapse = ", "),
           if (length(no_m1) == 1) " is" else " are",
           " too recent to have observable month-1 retention yet.")
  } else ""
  list(
    title = "New Customers per Cohort",
    description = "Acquisition volume: unique new customers by first-activity month.",
    text = paste0(
      "Cohort intake ranges from ", format(min(sz), big.mark = ","), " (",
      shared$cohort_labels[si], ") to ", format(max(sz), big.mark = ","), " (",
      shared$cohort_labels[bi], "), averaging ", format(round(mean(sz)), big.mark = ","),
      " new customers per month. Comparing the first and last cohorts(",
      format(first_v, big.mark = ","), " vs ", format(last_v, big.mark = ","),
      "), acquisition is ", acq_word, ". Retention percentages elsewhere in this report are relative ",
      "to these sizes — a small cohort with high retention can still matter less than a large one ",
      "with average retention.", censor_note
    ),
    chart_labels = list(
      cohort = "Acquisition cohort(first-activity month)",
      new_customers = "New customers"
    ),
    data = list(cohort_sizes = shared$sizes_df)
  )
}

# Card: cohort_comparison (table)
card_cohort_comparison <- function(shared, df, params) {
  n_m3 <- sum(!is.na(shared$comparison_df$m3_retention_pct))
  n_m6 <- sum(!is.na(shared$comparison_df$m6_retention_pct))
  list(
    title = "Cohort Comparison",
    description = "Every cohort&#x27;s size and month-1/3/6 retention side by side; blank cells are months the cohort has not reached yet.",
    text = paste0(
      "Of ", length(shared$cohort_labels), " cohorts, ", sum(!is.na(shared$m1_by_cohort)),
      " have reached month 1, ", n_m3, " month 3, and ", n_m6, " month 6 — blank cells mean the cohort ",
      "is too recent to observe that month, not that retention is zero. ",
      if (!is.na(shared$best_cohort)) paste0("At month 1, ", shared$best_cohort, " leads(",
        shared$best_cohort_m1, "%) and ", shared$worst_cohort, " trails(", shared$worst_cohort_m1,
        "%). ") else "",
      switch(shared$trend_word,
        improving = paste0("Reading down the month-1 column, newer cohorts are clearly retaining better(",
                           shared$trend_second, "% recent vs ", shared$trend_first, "% early)."),
        declining = paste0("Reading down the month-1 column, newer cohorts are retaining worse(",
                           shared$trend_second, "% recent vs ", shared$trend_first, "% early)."),
        stable    = "Month-1 retention is broadly stable from the earliest to the latest cohorts.",
        "Too few cohorts have observable month-1 retention to compare halves.")
    ),
    data = list(cohort_comparison = shared$comparison_df)
  )
}