Churn Analysis

The code that produced every figure in this report, exactly as it ran. Fingerprint 593e19e2271c3c71. The same code on the same data gives the same report.

`standard_churn_v2` <- function(pf) {
  `%||%` <- function(a, b) if (!is.null(a)) a else b
  #' Readable figures (LAT-3180, LAT-3181): whole numbers from a thousand up, one decimal from a hundred, two from
  #' one, three significant figures below one. A cell carries what the value needs, not what R prints.
  tidy <- function(x) {
    x <- as.numeric(x)
    ifelse(is.na(x), NA_real_,
      ifelse(abs(x) >= 1000, round(x, 0),
        ifelse(abs(x) >= 100, round(x, 1),
          ifelse(abs(x) >= 1, round(x, 2), signif(x, 3)))))
  }
  p_text <- function(p) vapply(p, function(q) if (is.na(q)) "" else if (q < 1e-4) "<0.0001" else format(signif(q, 3)), character(1))
  inputs <- pf$taskList$inputs
  params <- inputs$module_parameters %||% list()
  # THE QUESTION this tool answers: the customer's objective, verbatim, when given.
  question <- (inputs$userContext %||% list())$objective %||%
    "How many customers churn, how long do they stay, and what separates those who leave?"

  #' ## Column mapping
  #' One row per customer: `churn_status` (a cancel date with blank meaning still active, a 0/1 flag, or yes/no text),
  #' and the dates or tenure that say how long each stayed: `start_date` (signup), optionally `end_date` (when a cancelled
  #' customer left, when the status is a flag) or `tenure` (time stayed, when there are no dates). `attribute_1..8`
  #' optionally name what to compare churn by (a plan, a region, a number of support tickets).
  col_map <- inputs$column_mapping %||% list()
  df <- renderObject.taskFunction.init(inputs, col_map)   # df has SEMANTIC names
  human <- function(sem) {
    v <- col_map[[sem]]
    if (is.null(v) || !nzchar(as.character(v))) sem else as.character(v)
  }
  if (!("churn_status" %in% names(df))) stop(sprintf("column_mapping must map 'churn_status' (%s was not found).", human("churn_status")))
  status_name <- human("churn_status")
  has_start <- "start_date" %in% names(df); has_end <- "end_date" %in% names(df); has_tenure <- "tenure" %in% names(df)
  attr_cols <- grep("^attribute_[0-9]+$", names(df), value = TRUE)
  attr_cols <- attr_cols[order(as.integer(sub("^attribute_", "", attr_cols)))]
  n_in <- nrow(df)

  raw_names <- local({
    ds <- inputs$dataset %||% inputs$df
    if (is.data.frame(ds)) return(names(ds))
    if (is.list(ds) && length(ds) > 0) {
      rows <- ds[seq_len(min(length(ds), 50))]
      nm <- unique(unlist(lapply(rows, function(r) if (is.list(r)) names(r) else NULL)))
      if (length(nm)) return(nm)
      if (!is.null(names(ds)) && all(nzchar(names(ds)))) return(names(ds))
    }
    character(0)
  })
  mapped_actual <- unique(as.character(unlist(col_map)))
  ignored_cols <- setdiff(raw_names, unique(c(mapped_actual, make.names(mapped_actual))))

  parse_d <- function(x) {
    if (inherits(x, "Date")) return(x)
    if (inherits(x, "POSIXt")) return(as.Date(x))
    s <- trimws(as.character(x)); s[s == "" | is.na(s)] <- NA
    if (all(is.na(s))) return(as.Date(rep(NA, length(s))))
    as.Date(suppressWarnings(lubridate::parse_date_time(s, orders = c("Ymd", "mdY", "dmY", "Ymd HMS", "Ymd HM", "mdY HMS", "dmY HMS"), quiet = TRUE)))
  }

  #' ## Parameters
  #' `reference_date`: the date the data describes (customers without a cancel date were still active on it); blank uses
  #' the latest date in the data.
  ref_param <- trimws(as.character(params$reference_date %||% ""))

  #' ## Churn status: a cancel date (blank = still active), a 0/1 or TRUE/FALSE flag, or yes/no text
  raw <- df$churn_status; chr <- trimws(as.character(raw)); blank <- is.na(chr) | chr == ""
  churned <- rep(NA, n_in); churn_date <- as.Date(rep(NA, n_in)); mode <- NULL
  cd <- parse_d(raw)
  if (sum(!blank) > 0 && sum(!is.na(cd)) >= 0.8 * sum(!blank)) {
    mode <- "date"; churned <- !is.na(cd); churn_date <- cd
  } else if (is.logical(raw)) {
    mode <- "flag"; churned <- raw
  } else {
    num <- suppressWarnings(as.numeric(chr))
    if (sum(!blank) > 0 && sum(!is.na(num[!blank])) >= 0.95 * sum(!blank) && all(num[!is.na(num)] %in% c(0, 1))) {
      mode <- "flag"; churned <- ifelse(blank, NA, num == 1)
    } else {
      lo <- tolower(chr)
      yes <- c("yes", "y", "true", "churned", "churn", "cancelled", "canceled", "cancel", "inactive", "lost", "closed", "left", "ended")
      no <- c("no", "n", "false", "active", "current", "retained", "open", "subscribed", "live")
      mapped <- ifelse(lo %in% yes, TRUE, ifelse(lo %in% no, FALSE, NA))
      if (sum(!blank) > 0 && sum(!is.na(mapped[!blank])) >= 0.8 * sum(!blank)) { mode <- "text"; churned <- mapped } else
        stop(sprintf("%s could not be read as churn: expected a cancel date (blank when still active), a 0/1 flag, or yes/no text such as Active/Cancelled.", status_name))
    }
  }

  #' ## How long each customer stayed (right-censored at the reference date for customers still active)
  start <- if (has_start) parse_d(df$start_date) else as.Date(rep(NA, n_in))
  end_d <- if (has_end) parse_d(df$end_date) else as.Date(rep(NA, n_in))
  all_dates <- c(start, churn_date, end_d); all_dates <- all_dates[!is.na(all_dates)]
  ref <- if (nzchar(ref_param)) parse_d(ref_param) else if (length(all_dates)) max(all_dates) else as.Date(NA)
  if (nzchar(ref_param) && is.na(ref)) stop("module_parameters$reference_date could not be read as a date.")
  tenure <- rep(NA_real_, n_in); t_unit <- NULL; t_source <- NULL
  if (has_tenure) {
    tenure <- suppressWarnings(as.numeric(trimws(as.character(df$tenure)))); t_unit <- human("tenure"); t_source <- sprintf("the %s column", human("tenure"))
  } else if (has_start && sum(!is.na(start)) >= 0.5 * n_in) {
    stop_d <- if (mode == "date") ifelse(churned %in% TRUE, churn_date, ref) else if (has_end) ifelse(churned %in% TRUE, end_d, ref) else rep(NA_real_, n_in)
    if (mode == "date" || has_end) {
      tenure <- (as.numeric(stop_d) - as.numeric(start)) / 30.4375; t_unit <- "months"
      t_source <- if (mode == "date") sprintf("%s to %s (or to %s when still active)", human("start_date"), status_name, format(ref)) else sprintf("%s to %s (or to %s when still active)", human("start_date"), human("end_date"), format(ref))
    }
  }
  has_time <- !is.null(t_unit)
  keep <- !is.na(churned) & (if (has_time) !is.na(tenure) & tenure >= 0 else TRUE)
  n_bad <- sum(!keep)
  w <- data.frame(churned = churned[keep], tenure = tenure[keep], start = start[keep], stringsAsFactors = FALSE)
  for (a in attr_cols) w[[a]] <- df[[a]][keep]
  n <- nrow(w); n_ch <- sum(w$churned); n_act <- n - n_ch
  if (n < 30) stop(sprintf("Only %d customers have a readable churn status%s; churn analysis needs at least 30.", n, if (has_time) " and a time stayed" else ""))
  if (n_ch < 5) stop(sprintf("Only %d churned customers in %s; at least 5 are needed to analyse churn.", n_ch, status_name))
  if (has_time && sum(w$tenure > 0) < 10) has_time <- FALSE

  #' ## Kaplan-Meier survival of customer lifetime, and the lifetime table at round checkpoints
  surv_df <- NULL; life_df <- NULL; med <- NA_real_; fit <- NULL
  if (has_time) {
    fit <- survival::survfit(survival::Surv(w$tenure, w$churned) ~ 1, conf.type = "log-log")
    tmax <- max(w$tenure)
    grid <- unique(sort(c(0, seq(0, tmax, length.out = 40))))
    sg <- summary(fit, times = grid, extend = TRUE)
    surv_df <- data.frame(time = rep(round(sg$time, 1), 3), survival_pct = round(100 * c(sg$surv, sg$lower, sg$upper), 1),
                          series = rep(c("All customers", "Lower 95%", "Upper 95%"), each = length(sg$time)), stringsAsFactors = FALSE)
    surv_df <- surv_df[!is.na(surv_df$survival_pct), , drop = FALSE]
    med <- unname(summary(fit)$table["median"])
    cps <- if (t_unit == "months") c(1, 3, 6, 12, 18, 24, 36, 48) else pretty(c(0, tmax), n = 6)[-1]
    cps <- cps[cps <= tmax]
    if (length(cps)) {
      sc <- summary(fit, times = cps, extend = TRUE)
      life_df <- data.frame(time = sc$time, still_customers_pct = round(100 * sc$surv, 1), low = round(100 * sc$lower, 1),
                            high = round(100 * sc$upper, 1), at_risk = as.integer(sc$n.risk), stringsAsFactors = FALSE)
    }
  }

  #' ## Churn by signup cohort, compared fairly: the share that churned within the same number of months after signing
  #' up (6, or 3 when fewer than three cohorts have been watched 6 months), for cohorts watched at least that long. A
  #' "churned so far" share favours young cohorts by construction, and run 1 read it as recent improvement (LAT-3190).
  coh_df <- NULL; coh_unit <- "month"; horizon <- NA_real_
  if (has_start && has_time && t_unit == "months" && sum(!is.na(w$start)) >= 30) {
    cs <- w$start; ok <- !is.na(cs)
    lab <- format(cs, "%Y-%m")
    if (length(unique(lab[ok])) > 24) { coh_unit <- "quarter"; lab <- paste0(format(cs, "%Y"), "-Q", (as.integer(format(cs, "%m")) - 1) %/% 3 + 1) }
    if (length(unique(lab[ok])) > 24) { coh_unit <- "year"; lab <- format(cs, "%Y") }
    watched <- (as.numeric(ref) - as.numeric(cs)) / 30.4375
    for (hz in c(6, 3)) {
      elig <- ok & watched >= hz
      qual <- names(which(table(lab[elig]) >= 10))
      if (length(qual) >= 3) { horizon <- hz; break }
    }
    if (!is.na(horizon)) {
      elig <- ok & watched >= horizon & lab %in% qual
      within <- w$churned & w$tenure <= horizon
      tb <- tapply(within[elig], lab[elig], mean)
      coh_df <- data.frame(cohort = names(tb), churned_within_pct = round(100 * as.numeric(tb), 1), stringsAsFactors = FALSE)
      coh_df <- coh_df[order(coh_df$cohort), , drop = FALSE]
    }
  }

  #' ## What separates those who leave: churn by each attribute, a log-rank test on lifetime (or a chi-square on the churn
  #' share when there is no time stayed). A numeric attribute with many values is cut at its quartiles.
  tests <- list(); levels_by <- list()
  for (a in attr_cols) {
    nm <- human(a); v <- w[[a]]; ch <- trimws(as.character(v)); nb <- !is.na(ch) & ch != ""
    num <- suppressWarnings(as.numeric(ch))
    if (sum(nb) >= 30 && sum(!is.na(num[nb])) >= 0.95 * sum(nb) && length(unique(num[!is.na(num)])) > 6) {
      br <- unique(stats::quantile(num, c(0, 0.25, 0.5, 0.75, 1), na.rm = TRUE))
      if (length(br) < 3) next
      lv <- cut(num, br, include.lowest = TRUE, dig.lab = 4)
      #' whole-number attributes read as '0 to 1' and '2 to 6', not '[0,1]' and '(1,6]'
      labs <- if (all(abs(num[!is.na(num)] - round(num[!is.na(num)])) < 1e-9))
        vapply(seq_len(length(br) - 1), function(i) { lo <- if (i == 1) br[i] else floor(br[i]) + 1; hi <- floor(br[i + 1]); if (lo >= hi) format(hi) else paste(format(lo), "to", format(hi)) }, character(1)) else levels(lv)
      g <- ifelse(is.na(lv), NA, paste0(nm, ": ", labs[as.integer(lv)]))
    } else {
      top <- names(sort(table(ch[nb]), decreasing = TRUE))[seq_len(min(8, length(unique(ch[nb]))))]
      g <- ifelse(!nb, NA, paste0(nm, ": ", ifelse(ch %in% top, ch, "Other")))
    }
    okg <- !is.na(g)
    if (length(unique(g[okg])) < 2) next
    tabn <- table(g[okg])
    small <- names(tabn)[tabn < 5]
    okg <- okg & !(g %in% small)
    if (length(unique(g[okg])) < 2) next
    if (has_time) {
      sd <- tryCatch(survival::survdiff(survival::Surv(w$tenure[okg], w$churned[okg]) ~ g[okg]), error = function(e) NULL)
      stat <- if (!is.null(sd)) sd$chisq else NA_real_; dfree <- length(unique(g[okg])) - 1; test <- "log-rank"
    } else {
      ct <- tryCatch(suppressWarnings(stats::chisq.test(table(g[okg], w$churned[okg]))), error = function(e) NULL)
      stat <- if (!is.null(ct)) unname(ct$statistic) else NA_real_; dfree <- length(unique(g[okg])) - 1; test <- "chi-square"
    }
    rates <- tapply(w$churned[okg], g[okg], mean); sizes <- tapply(w$churned[okg], g[okg], length)
    tests[[nm]] <- list(attribute = nm, levels = length(rates), test = test, statistic = stat, p = if (is.na(stat)) NA_real_ else stats::pchisq(stat, dfree, lower.tail = FALSE),
                        hi = names(which.max(rates)), hi_pct = 100 * max(rates), lo = names(which.min(rates)), lo_pct = 100 * min(rates), min_n = min(sizes))
    levels_by[[nm]] <- list(g = g, ok = okg, rates = rates)
  }
  tests_df <- NULL; attr_df <- NULL; surv_attr_df <- NULL; strongest <- NULL
  if (length(tests)) {
    tests_df <- do.call(rbind, lapply(tests, function(t) data.frame(attribute = t$attribute, groups = t$levels, test = t$test, statistic = tidy(t$statistic),
      p_value = p_text(t$p), highest_churn = sub("^[^:]*: ", "", t$hi), highest_pct = round(t$hi_pct, 1), lowest_churn = sub("^[^:]*: ", "", t$lo), lowest_pct = round(t$lo_pct, 1), stringsAsFactors = FALSE)))
    ps <- sapply(tests, `[[`, "p"); ps[is.na(ps)] <- 1
    tests_df <- tests_df[order(ps), , drop = FALSE]
    strongest <- names(tests)[which.min(ps)]
    lb <- levels_by[[strongest]]
    attr_df <- data.frame(group = names(lb$rates), churn_pct = round(100 * as.numeric(lb$rates), 1), stringsAsFactors = FALSE)
    attr_df <- attr_df[order(-attr_df$churn_pct), , drop = FALSE]
    if (has_time) {
      fg <- survival::survfit(survival::Surv(w$tenure[lb$ok], w$churned[lb$ok]) ~ lb$g[lb$ok])
      grid <- unique(sort(c(0, seq(0, max(w$tenure), length.out = 30))))
      sgg <- summary(fg, times = grid, extend = TRUE)
      surv_attr_df <- data.frame(time = round(sgg$time, 1), survival_pct = round(100 * sgg$surv, 1), group = sub("^lb\\$g\\[lb\\$ok\\]=", "", as.character(sgg$strata)), stringsAsFactors = FALSE)
      surv_attr_df <- surv_attr_df[!is.na(surv_attr_df$survival_pct), , drop = FALSE]
    }
  }

  #' ## Assumption checks (LAT-3138)
  act_share <- n_act / n
  min_group <- if (length(tests)) min(sapply(tests, `[[`, "min_n")) else NA
  checks_df <- data.frame(
    check = c("Enough churn events", "Still-active customers recorded", "Time stayed available", "Compared groups large enough", "Rows complete"),
    statistic = c(sprintf("%d churned customers", n_ch), sprintf("%s%% of customers still active", format(round(100 * act_share, 1))),
                  if (has_time) sprintf("from %s", t_source) else "no dates or tenure to measure time stayed",
                  if (is.na(min_group)) "no attributes compared" else sprintf("smallest group: %d customers", as.integer(min_group)),
                  sprintf("%d of %d rows excluded", n_bad, n_in)),
    p_value = "",
    verdict = c(if (n_ch >= 50) "holds" else if (n_ch >= 10) "strained" else "violated",
                if (act_share == 0) "violated" else if (act_share < 0.05 || act_share > 0.95) "strained" else "holds",
                if (has_time) "holds" else "strained",
                if (is.na(min_group) || min_group >= 30) "holds" else if (min_group >= 10) "strained" else "violated",
                if (n_bad / n_in <= 0.05) "holds" else if (n_bad / n_in <= 0.15) "strained" else "violated"),
    note = c("few churn events make the survival curve and every comparison uncertain",
             "a file with no active customers usually leaves out current ones, which overstates churn",
             "without dates or tenure only the share who churned can be measured, not how long customers stay",
             "a small group's churn share swings by several points on a few customers",
             "rows whose status or time stayed could not be read are left out"),
    stringsAsFactors = FALSE)

  #' ## Method, assumptions, answer
  excluded <- if (n_bad > 0) sprintf("%d row%s with an unreadable status or time stayed", n_bad, if (n_bad > 1) "s" else "") else character(0)
  method <- paste0(
    "Churn for ", n, " customers: ", status_name, " read as ", switch(mode, date = "a cancel date, blank meaning still active", flag = "a churn flag", text = "text (for example Active or Cancelled)"),
    if (has_time) paste0("; time stayed from ", t_source, " in ", t_unit, ", with still-active customers counted as not yet churned (right-censored) in a Kaplan-Meier survival curve with log-log 95% intervals") else "; no time stayed, so no survival curve",
    if (!is.null(coh_df)) sprintf("; churned within %d months of signing up by signup %s, for cohorts of ten or more watched at least that long", as.integer(horizon), coh_unit) else "",
    if (length(tests)) sprintf("; churn compared by %s with %s tests (numeric attributes cut at their quartiles)", paste(names(tests), collapse = ", "), if (has_time) "log-rank" else "chi-square") else "",
    if (length(excluded)) paste0("; excluded: ", paste(excluded, collapse = "; ")) else "",
    if (length(ignored_cols)) paste0("; not used: ", paste(utils::head(ignored_cols, 12), collapse = ", "), " (not mapped)") else "", ".")
  assumptions <- list(
    "A customer still active on the reference date has not churned yet; the survival curve counts them only up to that date.",
    "Cohorts are compared on churn within the same number of months after signing up; the newest cohorts are left out until they have been watched that long.",
    "An attribute that separates churn is associated with leaving, not shown to cause it.",
    "Customers who churned and came back count once, by the status given.",
    "The median lifetime is not reached when more than half of the customers are still active at the longest time observed.")
  answer <- list(customers = n, churned = n_ch, churn_rate_pct = round(100 * n_ch / n, 1), status_mode = mode,
                 median_lifetime = if (has_time && !is.na(med)) tidy(med) else NULL, time_unit = t_unit,
                 strongest_attribute = strongest, n = n)

  results <- list()
  #' The verdict and the headline are NOT places of a library tool (LAT-3130): the last mile writes them.
  sm <- list(customers = n, churned = n_ch, churn_rate_pct = round(100 * n_ch / n, 1), still_active = n_act)
  if (has_time && !is.na(med)) sm$median_lifetime <- tidy(med)
  results$summary_metrics <- place_metric(sm, lead = "churn_rate_pct", place = "summary_metrics")
  if (!is.null(surv_df)) {
    results$survival_curve <- place_trend(surv_df, x = "time", y = "survival_pct", series = "series", place = "survival_curve")
  } else {
    results$survival_curve <- place_dropped("no signup dates with cancel or end dates, and no tenure column, so how long customers stay cannot be measured", place = "survival_curve")
  }
  if (!is.null(coh_df)) {
    results$churn_by_cohort <- place_comparison(coh_df, category = "cohort", value = "churned_within_pct", place = "churn_by_cohort")
  } else {
    results$churn_by_cohort <- place_dropped(if (!has_start) "no readable signup date was mapped, so churn cannot be split by signup cohort" else
      "fewer than three signup cohorts of ten or more customers have been watched three months, so cohorts cannot be compared fairly", place = "churn_by_cohort")
  }
  if (!is.null(attr_df)) {
    results$attribute_churn <- place_comparison(attr_df, category = "group", value = "churn_pct", place = "attribute_churn")
    results$attribute_tests <- place_table(tests_df, place = "attribute_tests")
  } else {
    results$attribute_churn <- place_dropped("no attribute with two or more groups of five customers was mapped, so churn is not compared between groups", place = "attribute_churn")
    results$attribute_tests <- place_dropped("no attribute with two or more groups of five customers was mapped, so churn is not compared between groups", place = "attribute_tests")
  }
  if (!is.null(surv_attr_df)) {
    results$survival_by_attribute <- place_trend(surv_attr_df, x = "time", y = "survival_pct", series = "group", place = "survival_by_attribute")
  } else {
    results$survival_by_attribute <- place_dropped(if (!has_time) "no time stayed was measurable, so survival cannot be compared between groups" else "no attribute with two or more groups was mapped, so survival is not compared between groups", place = "survival_by_attribute")
  }
  if (!is.null(life_df)) {
    results$lifetime_table <- place_table(life_df, place = "lifetime_table")
  } else {
    results$lifetime_table <- place_dropped("no time stayed was measurable, so there is no lifetime table", place = "lifetime_table")
  }
  results$assumption_checks <- place_table(checks_df, place = "assumption_checks")
  results$churn_method <- list(kind = "metric", values = list(
    method = method, n_in = n_in, n_used = n, excluded = as.list(excluded), assumptions = assumptions,
    x_column = status_name, y_column = if (has_time) t_unit else "churned"),
    value_order = list("n_used", "n_in"))

  objects <- list()   # filled by the object layer, not here
  list(answer = answer, method = method, n = n, results = results, objects = objects,
       json_output = list(answer = answer, method = method, n = n))
}