Price Elasticity of Demand

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

`standard_price_elasticity_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) if (is.na(p)) "" else if (p < 1e-4) "<0.0001" else format(signif(p, 3))
  inputs <- pf$taskList$inputs
  params <- inputs$module_parameters %||% list()
  question <- (inputs$userContext %||% list())$objective %||%
    "How much does demand move when the price moves, is it elastic or inelastic, does that differ by segment, and which way does revenue go?"

  #' ## Column mapping
  #' `price` and `quantity` (numeric, positive), an optional `segment`, and an optional `control_N` series (numeric or
  #' categorical) held constant in the fit. Semantic names inside; the customer's own headers live in `col_map`.
  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)
  }
  for (sem in c("price", "quantity"))
    if (!(sem %in% names(df))) stop(sprintf("column_mapping must map '%s' (%s was not found).", sem, human(sem)))
  price_h <- human("price"); qty_h <- human("quantity")
  has_seg <- "segment" %in% names(df); seg_h <- if (has_seg) human("segment") else NULL
  ctrl_cols <- grep("^control_[0-9]+$", names(df), value = TRUE)
  ctrl_cols <- ctrl_cols[order(as.integer(sub("^control_", "", ctrl_cols)))]
  n_in <- nrow(df)

  #' ## The columns this tool did not look at, read from the raw rows (init narrows `df` to the mapped columns)
  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))))

  #' ## Parameters
  max_segments <- suppressWarnings(as.integer(params$max_segments %||% 6L))
  if (is.na(max_segments) || max_segments < 2 || max_segments > 8) stop("module_parameters$max_segments must be an integer from 2 to 8")

  #' ## Data preparation
  #' Price and quantity coerced to numeric; a row with either missing or not positive is excluded and counted (a log
  #' needs a positive number). Controls: numeric when 95% of their values parse, else categorical; a control with one
  #' value is dropped and named. Segments trimmed; the largest `max_segments` kept and the rest folded into Other; a
  #' segment with fewer than 10 rows or fewer than 3 distinct prices is folded too. At least 30 rows and 3 distinct
  #' prices are required.
  p <- suppressWarnings(as.numeric(as.character(df$price)))
  q <- suppressWarnings(as.numeric(as.character(df$quantity)))
  keep <- !is.na(p) & !is.na(q) & p > 0 & q > 0
  n_excluded <- sum(!keep)
  dat <- data.frame(lp = log(p[keep]), lq = log(q[keep]), price = p[keep], qty = q[keep])
  if (nrow(dat) < 30) stop(sprintf("Only %d rows carry a positive %s and %s; the elasticity needs at least 30.", nrow(dat), price_h, qty_h))
  if (length(unique(dat$price)) < 3) stop(sprintf("%s takes fewer than 3 distinct positive values; the elasticity cannot be estimated without price variation.", price_h))
  ctrl_names <- character(0); ctrl_kind <- character(0); dropped_ctrl <- character(0)
  for (cc in ctrl_cols) {
    v <- df[[cc]][keep]; num <- suppressWarnings(as.numeric(as.character(v))); ok <- !is.na(v) & nzchar(trimws(as.character(v)))
    if (sum(ok) > 0 && sum(!is.na(num)) / sum(ok) >= 0.95 && length(unique(num[!is.na(num)])) > 2) {
      dat[[cc]] <- num; ctrl_kind <- c(ctrl_kind, "numeric")
    } else {
      f <- trimws(as.character(v)); f[is.na(f) | f == ""] <- NA
      if (length(unique(stats::na.omit(f))) < 2) { dropped_ctrl <- c(dropped_ctrl, human(cc)); next }
      dat[[cc]] <- factor(f); ctrl_kind <- c(ctrl_kind, "categorical")
    }
    ctrl_names <- c(ctrl_names, cc)
  }
  n_folded <- 0L; levs <- NULL
  if (has_seg) {
    g <- trimws(as.character(df$segment[keep])); g[is.na(g) | g == "" | tolower(g) %in% c("na", "n/a", "null", "nan")] <- "Other"
    tab <- sort(table(g), decreasing = TRUE)
    if (length(tab) > max_segments) { keep_l <- names(tab)[seq_len(max_segments - 1)]; n_folded <- length(tab) - length(keep_l); g[!(g %in% keep_l)] <- "Other" }
    for (l in unique(g)) if (l != "Other" && (sum(g == l) < 10 || length(unique(dat$price[g == l])) < 3)) { g[g == l] <- "Other"; n_folded <- n_folded + 1L }
    if (length(unique(g)) < 2) { has_seg <- FALSE; n_folded <- 0L } else { levs <- names(sort(table(g), decreasing = TRUE)); dat$seg <- factor(g, levels = levs) }
  }
  complete <- stats::complete.cases(dat)
  n_ctrl_missing <- sum(!complete); dat <- dat[complete, , drop = FALSE]; n <- nrow(dat)

  #' ## The fits: log quantity on log price (+ controls), and with the segment interaction when a segment is mapped
  rhs <- c("lp", ctrl_names)
  f_overall <- stats::lm(stats::reformulate(rhs, response = "lq"), data = dat)
  co <- summary(f_overall)$coefficients
  if (!("lp" %in% rownames(co)) || is.na(co["lp", 1])) stop(sprintf("The price term could not be estimated; %s may be fixed within the mapped controls.", price_h))
  e <- unname(co["lp", 1]); e_se <- unname(co["lp", 2]); e_p <- unname(co["lp", 4])
  e_ci <- suppressMessages(as.numeric(stats::confint(f_overall, "lp", level = 0.95)))
  r2 <- summary(f_overall)$r.squared
  f_nocontrol <- stats::lm(lq ~ lp, data = dat); e_raw <- unname(stats::coef(f_nocontrol)["lp"])
  reading <- if (e_ci[2] < -1) "elastic" else if (e_ci[1] > -1) "inelastic" else "undecided at -1"
  rev10 <- 100 * (1.1^(1 + e) - 1); rev10_lo <- 100 * (1.1^(1 + e_ci[1]) - 1); rev10_hi <- 100 * (1.1^(1 + e_ci[2]) - 1)
  seg_df <- NULL; f_seg <- NULL
  if (has_seg) {
    f_seg <- stats::lm(stats::reformulate(c("lp * seg", ctrl_names), response = "lq"), data = dat)
    b <- stats::coef(f_seg); V <- stats::vcov(f_seg); tcrit <- stats::qt(0.975, stats::df.residual(f_seg))
    rows <- lapply(levs, function(l) {
      cv <- stats::setNames(rep(0, length(b)), names(b)); cv["lp"] <- 1
      inter <- paste0("lp:seg", l); if (inter %in% names(b)) cv[inter] <- 1
      est <- sum(cv * b, na.rm = TRUE); se <- sqrt(as.numeric(t(cv) %*% V %*% cv))
      data.frame(segment = l, elasticity = est, ci_low = est - tcrit * se, ci_high = est + tcrit * se, stringsAsFactors = FALSE)
    })
    seg_df <- do.call(rbind, rows); seg_df <- seg_df[order(seg_df$elasticity), , drop = FALSE]; rownames(seg_df) <- NULL
    inter_p <- tryCatch({ f_add <- stats::lm(stats::reformulate(c("lp", "seg", ctrl_names), response = "lq"), data = dat); stats::anova(f_add, f_seg)$`Pr(>F)`[2] }, error = function(e) NA_real_)
  } else inter_p <- NA_real_

  #' ## The frames for the places
  interval_df <- data.frame(scope = "Overall", elasticity = round(e, 3), ci_low = round(e_ci[1], 3), ci_high = round(e_ci[2], 3), stringsAsFactors = FALSE)
  if (!is.null(seg_df)) interval_df <- rbind(interval_df, data.frame(scope = seg_df$segment, elasticity = round(seg_df$elasticity, 3), ci_low = round(seg_df$ci_low, 3), ci_high = round(seg_df$ci_high, 3), stringsAsFactors = FALSE))
  scatter <- data.frame(price = dat$price, qty = dat$qty, stringsAsFactors = FALSE)
  names(scatter) <- c(price_h, qty_h)
  if (has_seg) scatter[[seg_h]] <- as.character(dat$seg)
  if (nrow(scatter) > 1000) { set.seed(20260919); scatter <- scatter[sort(sample.int(nrow(scatter), 1000)), , drop = FALSE] }
  p_med <- stats::median(dat$price); grid <- seq(min(dat$price), max(dat$price), length.out = 25)
  q_idx <- 100 * (grid / p_med)^e; r_idx <- 100 * (grid / p_med)^(1 + e)
  curve_df <- data.frame(price = tidy(c(grid, grid)), index = tidy(c(q_idx, r_idx)), series = rep(c("Quantity", "Revenue"), each = length(grid)), stringsAsFactors = FALSE)
  fit_used <- if (!is.null(f_seg)) f_seg else f_overall
  cf <- summary(fit_used)$coefficients; ci_all <- suppressMessages(stats::confint(fit_used))
  term_label <- function(t) {
    t2 <- t
    t2 <- sub("^lp$", paste0("log ", price_h), t2)
    for (cc in ctrl_names) t2 <- sub(paste0("^", cc), human(cc), t2)
    if (has_seg) t2 <- sub("^seg", paste0(seg_h, " = "), t2); t2 <- sub(":seg", paste0(" x ", seg_h, " = "), t2)
    sub("^lp", paste0("log ", price_h), t2)
  }
  fit_df <- data.frame(term = vapply(rownames(cf), term_label, character(1), USE.NAMES = FALSE),
                       estimate = tidy(cf[, 1]), ci_low = tidy(ci_all[, 1]), ci_high = tidy(ci_all[, 2]),
                       p_value = vapply(cf[, 4], p_text, character(1)), stringsAsFactors = FALSE)
  fit_df <- fit_df[fit_df$term != "(Intercept)", , drop = FALSE]
  fit_df <- rbind(fit_df, data.frame(term = c("R squared", "Rows"), estimate = c(round(summary(fit_used)$r.squared, 3), n), ci_low = NA, ci_high = NA, p_value = "", stringsAsFactors = FALSE))
  rownames(fit_df) <- NULL

  #' ## Assumption checks (LAT-3138)
  n_prices <- length(unique(dat$price))
  within_ok <- if (has_seg) all(tapply(dat$price, dat$seg, function(x) length(unique(x))) >= 3) else TRUE
  lin_p <- tryCatch(stats::anova(f_overall, stats::lm(stats::reformulate(c("lp", "I(lp^2)", ctrl_names), response = "lq"), data = dat))$`Pr(>F)`[2], error = function(e) NA_real_)
  res <- stats::residuals(f_overall)
  sw_p <- if (n <= 5000) tryCatch(stats::shapiro.test(res)$p.value, error = function(e) NA_real_) else NA_real_
  bp_p <- tryCatch({ aux <- stats::lm(I(res^2) ~ lp, data = dat); s <- summary(aux); stats::pchisq(n * s$r.squared, df = 1, lower.tail = FALSE) }, error = function(e) NA_real_)
  top_share <- max(table(dat$price)) / n
  vif_max <- if (length(ctrl_names)) tryCatch({ aux <- stats::lm(stats::reformulate(ctrl_names, response = "lp"), data = dat); 1 / (1 - summary(aux)$r.squared) }, error = function(e) NA_real_) else NA_real_
  v3 <- function(p, hold = 0.05, strain = 0.01) if (is.na(p)) "strained" else if (p >= hold) "holds" else if (p >= strain) "strained" else "violated"
  checks_df <- data.frame(
    check = c("Enough distinct prices", "Price varies within each segment", "Linear in logs", "Residuals are normal", "Equal spread across the price range", "No single price dominates", "Price not collinear with the controls"),
    statistic = c(sprintf("%d distinct prices", n_prices), if (has_seg) "3 or more prices in every segment" else "no segment mapped",
                  if (is.na(lin_p)) "not estimable" else "added squared log-price term", if (is.na(sw_p)) sprintf("Shapiro-Wilk not run (n = %d)", n) else "Shapiro-Wilk on the residuals",
                  if (is.na(bp_p)) "not estimable" else "Breusch-Pagan on log price", sprintf("most common price holds %s%% of rows", format(round(100 * top_share, 1))),
                  if (length(ctrl_names) == 0) "no controls mapped" else if (is.na(vif_max)) "not estimable" else sprintf("variance inflation of log price = %s", format(tidy(vif_max)))),
    p_value = c("", "", p_text(lin_p), p_text(sw_p), p_text(bp_p), "", ""),
    verdict = c(if (n_prices >= 6) "holds" else if (n_prices >= 3) "strained" else "violated", if (within_ok) "holds" else "strained", v3(lin_p),
                if (is.na(sw_p)) "strained" else if (sw_p >= 0.05) "holds" else if (n >= 30) "strained" else "violated", v3(bp_p),
                if (top_share <= 0.4) "holds" else if (top_share <= 0.7) "strained" else "violated",
                if (length(ctrl_names) == 0) "holds" else if (is.na(vif_max)) "strained" else if (vif_max < 5) "holds" else if (vif_max < 10) "strained" else "violated"),
    note = c("with few price points the slope rests on a handful of levels", "a segment with one price has no elasticity of its own; it is folded",
             "a curved relation in logs means the elasticity changes along the price range", "with 30 or more rows the estimate tolerates non-normal residuals; the interval is approximate",
             "spread that grows with price makes the interval too narrow at one end", "one dominant price leaves the slope decided by the few rows at other prices",
             "a control that moves with price cannot be separated from it; the elasticity then absorbs both"),
    stringsAsFactors = FALSE)

  #' ## Method, assumptions, answer
  excluded <- c(if (n_excluded > 0) sprintf("%d row%s without a positive price and quantity", n_excluded, if (n_excluded == 1) "" else "s"),
                if (n_ctrl_missing > 0) sprintf("%d row%s missing a control", n_ctrl_missing, if (n_ctrl_missing == 1) "" else "s"),
                if (n_folded > 0) sprintf("%d segment%s folded into Other", n_folded, if (n_folded == 1) "" else "s"),
                if (length(dropped_ctrl)) sprintf("%d control%s dropped for having one value (%s)", length(dropped_ctrl), if (length(dropped_ctrl) == 1) "" else "s", paste(dropped_ctrl, collapse = ", ")))
  method <- paste0(
    "Price elasticity of demand from a log-log least-squares fit of ", qty_h, " on ", price_h, " over ", n, " rows of ", n_in,
    " with ", n_prices, " distinct prices from ", format(tidy(min(dat$price))), " to ", format(tidy(max(dat$price))),
    if (length(ctrl_names)) paste0(", holding constant ", paste(vapply(ctrl_names, human, character(1)), collapse = ", "), " (elasticity without them ", format(round(e_raw, 3)), ")") else "",
    if (has_seg) paste0("; ", seg_h, " entered with its interaction with log price so each of the ", length(levs), " segments (", paste(levs, collapse = ", "), ") has its own elasticity (interaction ", if (is.na(inter_p)) "not testable" else paste0("p = ", p_text(inter_p)), ")") else "",
    "; 95% intervals from the fit's standard errors; the elastic / inelastic reading from whether the interval lies beyond or short of -1; the revenue change per 10% price rise as 1.1 to the power (1 + elasticity), which for a constant elasticity is monotone in price and has no interior maximum",
    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(
    "The prices were set by the seller and the quantities responded; the elasticity is a correlation in observed prices, not the result of an experiment.",
    "Whatever moved price and quantity together (promotions, seasons, competitors) is either mapped as a control or absent; an unmapped one biases the elasticity.",
    "Demand has a constant elasticity across the observed range (a straight line in logs); the estimate says nothing about prices outside that range.",
    "Each row is one observation of the same market; rows from different markets pooled without a segment blend their elasticities.",
    "The revenue direction assumes costs do not change with the quantity sold.")
  answer <- list(elasticity = round(e, 3), elasticity_low = round(e_ci[1], 3), elasticity_high = round(e_ci[2], 3), reading = reading, p_value = p_text(e_p),
                 revenue_change_10pct = round(rev10, 2), revenue_change_10pct_low = round(min(rev10_lo, rev10_hi), 2), revenue_change_10pct_high = round(max(rev10_lo, rev10_hi), 2),
                 r_squared = round(r2, 3), n = n, n_prices = n_prices, elasticity_without_controls = if (length(ctrl_names)) round(e_raw, 3) else NULL,
                 segments = if (!is.null(seg_df)) as.list(stats::setNames(round(seg_df$elasticity, 3), seg_df$segment)) else NULL)

  results <- list()
  #' The verdict and the headline are NOT places of a library tool (LAT-3130): the last mile writes them.
  results$summary_metrics <- place_metric(list(elasticity = round(e, 3), elasticity_low = round(e_ci[1], 3), elasticity_high = round(e_ci[2], 3),
    reading = reading, revenue_change_10pct = round(rev10, 2), r_squared = round(r2, 3), n = n), lead = "elasticity", place = "summary_metrics")
  results$elasticity_interval <- place_interval(interval_df, term = "scope", value = "elasticity", low = "ci_low", high = "ci_high", place = "elasticity_interval")
  scatter_series <- if (has_seg) seg_h else NULL
  results$demand_scatter <- place_relationship(scatter, x = price_h, y = qty_h, series = scatter_series, draws = "dataset", place = "demand_scatter")
  results$demand_curve <- place_trend(curve_df, x = "price", y = "index", series = "series", place = "demand_curve")
  if (!is.null(seg_df)) {
    sd <- data.frame(segment = seg_df$segment, elasticity = round(seg_df$elasticity, 3), ci_low = round(seg_df$ci_low, 3), ci_high = round(seg_df$ci_high, 3), stringsAsFactors = FALSE)
    results$segment_elasticity <- place_comparison(sd, category = "segment", value = "elasticity", low = "ci_low", high = "ci_high", place = "segment_elasticity")
  } else {
    results$segment_elasticity <- place_dropped("no segment was mapped, so there is one elasticity for all the rows; map a channel, region or product line to see how it differs", place = "segment_elasticity")
  }
  results$fit_table <- place_table(fit_df, place = "fit_table")
  results$assumption_checks <- place_table(checks_df, place = "assumption_checks")
  results$pricing_method <- place_method(method = method, n_in = n_in, n_used = n, assumptions = assumptions, excluded = as.list(excluded), place = "pricing_method")

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