Causal Impact (Interrupted Time Series)
Shows whether a change such as a launch, a price change or a policy moved a measured series: the jump at the change, the change in trend after it, and the effect against the path the series was expected to follow without the change, each with a 95% interval.
RUN DATE · 15 September 2026
DATA · 104 rows
Did the pricing page relaunch lift weekly signups, and by how much?
- Summary MetricsThe few supporting numbers, read at a glance.
- Effect Over TimeWhich way it is going, and since when.
- Change IntervalThe range, and whether it crosses zero.
- Observed Vs ExpectedWhich way it is going, and since when.
- Segment FitWhich way it is going, and since when.
- Period ComparisonWhich group is larger, and by how much.
- Model TableThe actual numbers, in full.
- Assumption ChecksWhich assumptions hold, which are strained, and which are violated, each with the test behind it.
- Impact MethodHow it was produced, and what would make it wrong.
The effect of the change
Relaunch lifts signups, effect persists
Signups rose above the model prediction after relaunch and stayed clearly above zero throughout the period.
The effect line stays well above the lower confidence bound across all weeks, showing consistent positive separation from expected signups.
Relaunch lifts signups, effect persists
The effect line runs consistently above zero from the relaunch onward, with the lower confidence bound also remaining above zero throughout the entire period. This shows observed signups exceeded the model's prediction across all weeks after the change, with the separation holding steady rather than fading. The effect fluctuates within a band but never crosses zero, making the lift clear and sustained.
The effect line stays well above the lower confidence bound across all weeks, showing consistent positive separation from expected signups.
Pricing page relaunch lifts signups clearly
Both the immediate jump and sustained weekly effect exclude zero, showing the relaunch lifted signups.
The average effect per week row shows the sustained lift, with its interval well clear of zero.
Pricing page relaunch lifts signups clearly
The jump at the relaunch date and the average effect per week after both have intervals that exclude zero, indicating effects beyond chance. The sustained weekly effect is the key finding: signups rose and stayed elevated. All assumption checks hold, so the result is credible.
The average effect per week row shows the sustained lift, with its interval well clear of zero.
Observed against expected
Observed rises clearly above expected trend
Weekly signups rise substantially above the before-trend after the relaunch, with the gap widening over time.
The observed line from late February onwards sits well above the expected line, with separation growing through the year.
Observed rises clearly above expected trend
From the relaunch point onward, observed weekly signups run clearly above the expected path set by the before-period trend. The gap opens immediately and widens steadily through the rest of the window, with observed values consistently higher across spring, summer, and fall. All checks hold, including normality and no change before the change date, which supports the clarity of this lift.
The observed line from late February onwards sits well above the expected line, with separation growing through the year.
Signups rise after pricing page relaunch
Weekly signups jumped upward at the relaunch and continued climbing at a steeper rate thereafter.
Compare where the fitted before line ends to where the fitted after line begins, then compare the slopes of both lines.
Signups rise after pricing page relaunch
The fitted line before the relaunch shows a gentle upward climb through early 2024. At the relaunch point, the fitted after line starts clearly higher than where the before line ended, marking a distinct upward jump. The after line then climbs more steeply than the before line did, indicating an acceleration in the growth rate. All assumption checks hold, supporting the clarity of this pattern.
Compare where the fitted before line ends to where the fitted after line begins, then compare the slopes of both lines.
The numbers
After period mean rises above before
Weekly signups rise after the relaunch, but raw means cannot isolate the relaunch effect from existing trend.
The after mean stands higher than the before mean in the table, showing an upward shift in the period average.
After period mean rises above before
The after period mean rises clearly above the before period mean. However, the brief notes that a series already rising will show a higher after mean even without change, so this raw difference does not measure the relaunch's effect. The other cards, which account for trend, will show whether the relaunch itself lifted signups beyond the expected path. All checks hold, supporting the reliability of both periods.
The after mean stands higher than the before mean in the table, showing an upward shift in the period average.
The numbers
Pricing page relaunch lifted signups sharply
Weekly signups rose substantially at the relaunch date and stayed elevated, clearly answering yes to lift.
The change in trend after the relaunch was much smaller than the jump itself, showing the lift came from a one-time shift, not acceleration.
Pricing page relaunch lifted signups sharply
The jump at the relaunch date stands out as the decisive term, accompanied by a tighter confidence interval and near-zero p-value. The average effect per week after the change confirms the elevation persisted. The trend before the change was upward but gentler; after the change, the trend flattened slightly, suggesting the jump captured most of the lift. All assumption checks hold, so the timing is credible.
The change in trend after the relaunch was much smaller than the jump itself, showing the lift came from a one-time shift, not acceleration.
Assumptions
All five checks hold
All five assumption checks hold, so nothing here limits how far the results can be trusted.
Holding: the change date is known, enough points on each side, serial correlation accounted for, no change before the change, and one more.
All five checks hold
The checks that hold: the change date is known, enough points on each side, serial correlation accounted for, no change before the change, residuals roughly normal.
Holding: the change date is known, enough points on each side, serial correlation accounted for, no change before the change, and one more.
How it was done
Interrupted time series by segmented regression (generalised least squares with AR(1) errors, estimated lag-1 correlation 0.34) of weekly_signups on time, a jump at the change and a change in trend after it: 104 time points, about one per week (60 before and 44 after), from 104 rows, 2023-01-02 to 2024-12-23. The change took effect on 2024-02-26 (given): points on or after it count as after the change. The expected path without the change is the before-period straight line projected forward with 95% prediction intervals; the effect is observed minus expected, averaged and summed over the after period, its interval from the projection's uncertainty and the before-period noise inflated for serial correlation. Intervals are 95%; p-values are two-sided and unadjusted. Columns not used: notes, phase, region.
104 of 104 rows · week_start → weekly_signups
caveatThe method assumes the trend before the change continues unchanged; all checks held.
Interrupted time series regression modelled weekly_signups as a straight line before the relaunch, then estimated a jump at the change date and a change in trend after it. The model accounted for serial correlation in the residuals and used all available points. The critical assumption is that without the relaunch, the pre-change trend would have persisted unchanged; if the trend was already bending or shifting, the expected path would be wrong and the effect would be misestimated. All five checks held, including the assumption that no change occurred before the stated date. Seasonality was not modelled; if signups follow a seasonal cycle, the effect estimate could be biased.
The code behind this report
The code that produced every figure in this report, exactly as it ran. Fingerprint a39f71cbcb37a223. The same code on the same data gives the same report.
`standard_causal_impact_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.
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)))))
}
fmtn <- function(v) format(tidy(v), big.mark = ",", trim = TRUE, scientific = FALSE)
#' A p-value under 0.0001 leaves as 1e-12 so the four-decimal serializer does not print 0 (LAT-3181).
p_cell <- function(p) { p <- as.numeric(p); ifelse(is.na(p), NA_real_, ifelse(p < 1e-4, 1e-12, signif(p, 3))) }
fmt_p <- function(p) if (is.na(p)) "" else if (p < 1e-4) "<0.0001" else as.character(signif(p, 3))
lag1 <- function(e) { e <- e - mean(e); if (length(e) < 3 || sum(e^2) == 0) NA_real_ else sum(e[-length(e)] * e[-1]) / sum(e^2) }
inputs <- pf$taskList$inputs
params <- inputs$module_parameters %||% list()
question <- (inputs$userContext %||% list())$objective %||%
"Did the change move the series, by how much, and how sure are we?"
#' ## Column mapping
#' `date` (the time axis) and `value` (the measure the change should have moved) are required; `period` is optional:
#' a column holding two values that mark before and after the change (before launch / after launch, 0 / 1).
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)
}
date_name <- human("date"); value_name <- human("value")
for (sem in c("date", "value"))
if (!(sem %in% names(df))) stop(sprintf("column_mapping must map '%s' (%s was not found).", sem, human(sem)))
has_period <- "period" %in% names(df)
period_name <- if (has_period) human("period") else ""
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))))
ignored_note <- if (length(ignored_cols)) sprintf("Columns not used: %s.", paste(ignored_cols, collapse = ", ")) else ""
#' ## Parameters
#' `intervention_date`: when the change took effect (points on or after it count as after). Ignored when a period
#' column is mapped. Without either, the change is ASSUMED at the middle of the series and the checks say so.
#' `model`: auto (the default: AR(1) errors when the residuals are serially correlated), ols or ar1.
model_param <- tolower(as.character(params$model %||% "auto"))
if (!(model_param %in% c("auto", "ols", "ar1"))) stop("module_parameters$model must be auto, ols or ar1")
#' ## The time axis: real dates (the format that reads the most values), else a sortable number
parse_dates <- function(v) {
s <- trimws(as.character(v)); s[is.na(s) | !nzchar(s)] <- NA_character_
fmts <- c("%Y-%m-%d", "%Y/%m/%d", "%m/%d/%Y", "%d/%m/%Y", "%d-%m-%Y", "%Y-%m", "%b %Y", "%B %Y")
best <- rep(as.Date(NA), length(s)); best_n <- -1
for (ff in fmts) {
ss <- if (ff == "%Y-%m") paste0(s, "-01") else if (ff %in% c("%b %Y", "%B %Y")) paste("01", s) else s
f2 <- if (ff == "%Y-%m") "%Y-%m-%d" else if (ff %in% c("%b %Y", "%B %Y")) paste("%d", ff) else ff
d <- suppressWarnings(as.Date(ss, format = f2))
if (sum(!is.na(d)) > best_n) { best <- d; best_n <- sum(!is.na(d)) }
}
best
}
n_nonblank <- sum(!is.na(df$date) & nzchar(trimws(as.character(df$date))))
d <- parse_dates(df$date)
if (n_nonblank > 0 && sum(!is.na(d)) >= 0.8 * n_nonblank) {
t_raw <- as.numeric(d); seq_kind <- "date"
} else {
num <- suppressWarnings(as.numeric(as.character(df$date)))
if (n_nonblank > 0 && sum(!is.na(num)) >= 0.95 * n_nonblank) { t_raw <- num; seq_kind <- "index" }
else stop(sprintf("The '%s' column could not be read as dates or as a sortable number such as a week index; the series has to be put in time order.", date_name))
}
#' ## Data preparation
#' The value is coerced to numeric (95% rule). Rows with an unreadable time, a blank or non-finite value, or (when a
#' period column is mapped) a blank period are excluded and counted; repeated time points are averaged.
mv <- df$value
if (!is.numeric(mv)) {
conv <- suppressWarnings(as.numeric(as.character(mv)))
n_orig <- sum(!is.na(mv) & nzchar(as.character(mv)))
if (n_orig > 0 && sum(!is.na(conv)) >= 0.95 * n_orig) mv <- conv
else stop(sprintf("The '%s' column is not numeric; the analysis needs a numeric measure the change could have moved.", value_name))
}
mv <- as.numeric(mv)
per <- if (has_period) { p <- trimws(as.character(df$period)); p[is.na(p) | !nzchar(p)] <- NA_character_; p } else rep(NA_character_, n_in)
ok_time <- is.finite(t_raw); ok_value <- is.finite(mv); ok_period <- !has_period | !is.na(per)
n_bad_time <- sum(!ok_time); n_bad_value <- sum(ok_time & !ok_value); n_bad_period <- sum(ok_time & ok_value & !ok_period)
keep <- ok_time & ok_value & ok_period
tk <- t_raw[keep]; xk <- mv[keep]; pk <- per[keep]
o <- order(tk); tk <- tk[o]; xk <- xk[o]; pk <- pk[o]
t_num <- unique(tk)
grp <- factor(tk, levels = t_num)
x <- as.numeric(vapply(split(xk, grp), mean, numeric(1)))
pl <- as.character(vapply(split(pk, grp), function(v) v[1], character(1)))
n_dup <- length(tk) - length(t_num)
n_points <- length(x); n_used <- n_points
if (n_points < 16) stop(sprintf("Only %d usable time points of '%s' over '%s'; at least 16 are needed, 8 on each side of the change.", n_points, value_name, date_name))
if (isTRUE(max(x) == min(x))) stop(sprintf("'%s' has no variation across its %d time points, so there is nothing a change could have moved.", value_name, n_points))
step <- stats::median(diff(t_num))
if (seq_kind == "date") {
period <- if (step <= 1.5) "day" else if (step >= 6 && step <= 8) "week" else if (step >= 13 && step <= 15) "fortnight"
else if (step >= 28 && step <= 31.5) "month" else if (step >= 84 && step <= 95) "quarter" else if (step >= 350 && step <= 380) "year"
else sprintf("%s-day period", format(round(step, 1)))
} else period <- "step"
lbl <- function(t) if (seq_kind == "date") format(as.Date(t, origin = "1970-01-01")) else format(t)
periods <- vapply(t_num, lbl, character(1))
#' ## Where the change took effect
if (has_period) {
levs <- unique(pl)
if (length(levs) != 2) stop(sprintf("'%s' must hold exactly two values marking before and after the change; it holds %d (%s).",
period_name, length(levs), paste(utils::head(levs, 5), collapse = ", ")))
mean_t <- vapply(levs, function(l) mean(t_num[pl == l]), numeric(1))
after_level <- levs[which.max(mean_t)]; before_level <- levs[which.min(mean_t)]
post <- pl == after_level
if (max(t_num[!post]) >= min(t_num[post]))
stop(sprintf("'%s' marks '%s' and '%s' on overlapping dates; the before and after periods must not interleave.", period_name, before_level, after_level))
t_int <- min(t_num[post])
split_rule <- sprintf("The change point is where %s switches from '%s' to '%s' (%s).", period_name, before_level, after_level, lbl(t_int))
date_source <- "period"
} else {
ip <- trimws(as.character(params$intervention_date %||% params$event_date %||% params$treatment_date %||% ""))
if (nzchar(ip)) {
t_int <- if (seq_kind == "date") as.numeric(parse_dates(ip)) else suppressWarnings(as.numeric(ip))
if (!is.finite(t_int)) stop(sprintf("intervention_date '%s' could not be read as a %s.", ip, if (seq_kind == "date") "date" else "number on the time axis"))
split_rule <- sprintf("The change took effect on %s (given): points on or after it count as after the change.", lbl(t_int))
date_source <- "given"
} else {
t_int <- t_num[floor(n_points / 2) + 1]
split_rule <- sprintf("No intervention date was given and no period column was mapped, so the change was ASSUMED at the middle of the series (%s); give the real date for a result that means something.", lbl(t_int))
date_source <- "assumed"
}
post <- t_num >= t_int
}
n_before <- sum(!post); n_after <- sum(post)
if (n_before < 8) stop(sprintf("Only %d time point%s of '%s' fall before the change (%s); at least 8 on each side are needed to tell a jump from the trend.", n_before, if (n_before == 1) "" else "s", value_name, lbl(t_int)))
if (n_after < 8) stop(sprintf("Only %d time point%s of '%s' fall on or after the change (%s); at least 8 on each side are needed to tell a jump from the trend.", n_after, if (n_after == 1) "" else "s", value_name, lbl(t_int)))
pre_i <- which(!post); post_i <- which(post)
#' ## Segmented regression: value = level + trend + a jump at the change + a change in trend after it
tt <- (t_num - t_num[1]) / step
tt0 <- (t_int - t_num[1]) / step
dat <- data.frame(x = x, tt = tt, post = as.numeric(post), since = ifelse(post, tt - tt0, 0))
fit_ols <- stats::lm(x ~ tt + post + since, data = dat)
e <- stats::residuals(fit_ols)
r1 <- lag1(e)
use_ar1 <- model_param == "ar1" || (model_param == "auto" && is.finite(r1) && r1 > 0.2)
fit <- fit_ols; model_label <- "ordinary least squares"; phi <- NA_real_
if (use_ar1) {
g <- tryCatch(nlme::gls(x ~ tt + post + since, data = dat, correlation = nlme::corAR1(form = ~ 1), method = "ML"),
error = function(err) NULL)
if (!is.null(g)) {
fit <- g; model_label <- "generalised least squares with AR(1) errors"
phi <- as.numeric(stats::coef(g$modelStruct$corStruct, unconstrained = FALSE))
} else use_ar1 <- FALSE
}
cf <- stats::coef(fit); V <- stats::vcov(fit); se <- sqrt(diag(V))
dfree <- n_points - 4; tq <- stats::qt(0.975, dfree)
term_row <- function(k) {
est <- as.numeric(cf[[k]]); s <- as.numeric(se[[k]])
c(est = est, se = s, low = est - tq * s, high = est + tq * s, p = 2 * stats::pt(-abs(est / s), dfree))
}
b0 <- term_row("(Intercept)"); b1 <- term_row("tt"); lv <- term_row("post"); sl <- term_row("since")
#' ## The expected path without the change: the before-period line projected over the after period
fit_pre <- stats::lm(x ~ tt, data = dat[pre_i, ])
pr <- stats::predict(fit_pre, newdata = dat[post_i, ], interval = "prediction", level = 0.95)
cf_post <- as.numeric(pr[, "fit"])
eff <- x[post_i] - cf_post
eff_lo <- x[post_i] - as.numeric(pr[, "upr"]); eff_hi <- x[post_i] - as.numeric(pr[, "lwr"])
np <- length(post_i)
r_pre <- lag1(stats::residuals(fit_pre))
infl <- if (is.finite(r_pre) && r_pre > 0) { rr <- min(r_pre, 0.95); (1 + rr) / (1 - rr) } else 1
Xp <- cbind(1, dat$tt[post_i]); wbar <- rep(1 / np, np)
var_mean_fit <- as.numeric(t(wbar) %*% Xp %*% stats::vcov(fit_pre) %*% t(Xp) %*% wbar)
var_mean_noise <- summary(fit_pre)$sigma^2 / np * infl
se_avg <- sqrt(var_mean_fit + var_mean_noise)
df_pre <- length(pre_i) - 2; tq_pre <- stats::qt(0.975, df_pre)
avg_eff <- mean(eff); avg_lo <- avg_eff - tq_pre * se_avg; avg_hi <- avg_eff + tq_pre * se_avg
avg_p <- 2 * stats::pt(-abs(avg_eff / se_avg), df_pre)
cum_eff <- sum(eff); cum_lo <- np * avg_lo; cum_hi <- np * avg_hi
cf_mean <- mean(cf_post)
rel_pct <- if (abs(cf_mean) > 1e-12) 100 * avg_eff / abs(cf_mean) else NA_real_
#' ## Checks: a false change in the before period, and the residuals
placebo_p <- NA_real_
if (n_before >= 16) {
pd <- dat[pre_i, c("x", "tt")]
k0 <- pd$tt[floor(nrow(pd) / 2) + 1]
pd$post <- as.numeric(pd$tt >= k0); pd$since <- ifelse(pd$post == 1, pd$tt - k0, 0)
placebo_p <- tryCatch(summary(stats::lm(x ~ tt + post + since, data = pd))$coefficients["post", 4], error = function(err) NA_real_)
}
shapiro_p <- tryCatch(if (n_points <= 5000) stats::shapiro.test(e)$p.value else NA_real_, error = function(err) NA_real_)
verdict_p <- function(p) if (is.na(p)) "unknown" else if (p >= 0.05) "holds" else if (p >= 0.001) "strained" else "violated"
change_lbl <- lbl(t_int)
significant <- is.finite(avg_p) && avg_p < 0.05
direction <- if (avg_eff > 0) "up" else if (avg_eff < 0) "down" else "flat"
excluded_rows <- c(if (n_bad_value > 0) sprintf("%d row%s with a blank, non-numeric or non-finite %s", n_bad_value, if (n_bad_value > 1) "s" else "", value_name),
if (n_bad_time > 0) sprintf("%d row%s with an unreadable %s", n_bad_time, if (n_bad_time > 1) "s" else "", date_name),
if (n_bad_period > 0) sprintf("%d row%s with a blank %s", n_bad_period, if (n_bad_period > 1) "s" else "", period_name),
if (n_dup > 0) sprintf("%d repeated time point%s averaged into one", n_dup, if (n_dup > 1) "s" else ""))
method <- paste0(
"Interrupted time series by segmented regression (", model_label,
if (use_ar1 && is.finite(phi)) sprintf(", estimated lag-1 correlation %s", round(phi, 2)) else "", ") of ", value_name,
" on time, a jump at the change and a change in trend after it: ", n_points, " time points, about one per ", period, " (",
n_before, " before and ", n_after, " after), from ", n_in, " rows, ", periods[1], " to ", periods[n_points], ". ", split_rule, " ",
if (length(excluded_rows)) paste0("Excluded: ", paste(excluded_rows, collapse = "; "), ". ") else "",
"The expected path without the change is the before-period straight line projected forward with 95% prediction intervals; ",
"the effect is observed minus expected, averaged and summed over the after period, its interval from the projection's uncertainty ",
"and the before-period noise", if (infl > 1) " inflated for serial correlation" else "", ". ",
"Intervals are 95%; p-values are two-sided and unadjusted. ", ignored_note)
answer <- list(direction = direction, significant = significant, average_effect = round(avg_eff, 4),
average_effect_low = round(avg_lo, 4), average_effect_high = round(avg_hi, 4), average_effect_p = signif(avg_p, 3),
cumulative_effect = round(cum_eff, 4), relative_effect_pct = if (is.na(rel_pct)) NULL else round(rel_pct, 2),
level_change = round(lv[["est"]], 4), level_change_low = round(lv[["low"]], 4), level_change_high = round(lv[["high"]], 4),
level_change_p = signif(lv[["p"]], 3), slope_change_per_period = round(sl[["est"]], 4), period = period,
change_at = change_lbl, change_date_source = date_source, model = model_label, n_before = n_before, n_after = n_after)
# ── Results: one entry per place ──
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(
average_effect = tidy(avg_eff), relative_effect_pct = if (is.na(rel_pct)) NA_real_ else round(rel_pct, 1),
cumulative_effect = tidy(cum_eff), level_change = tidy(lv[["est"]]), slope_change_per_period = tidy(sl[["est"]]),
p_value = p_cell(avg_p), n_before = n_before, n_after = n_after), lead = "average_effect", place = "summary_metrics")
obs_exp <- rbind(data.frame(period = periods, value = tidy(x), series = "Observed", stringsAsFactors = FALSE),
data.frame(period = periods[post_i], value = tidy(cf_post), series = "Expected without the change", stringsAsFactors = FALSE))
results$observed_vs_expected <- place_trend(obs_exp, x = "period", y = "value", series = "series", place = "observed_vs_expected")
eff_df <- rbind(data.frame(period = periods[post_i], effect = tidy(eff), series = "Effect", stringsAsFactors = FALSE),
data.frame(period = periods[post_i], effect = tidy(eff_lo), series = "95% lower bound", stringsAsFactors = FALSE),
data.frame(period = periods[post_i], effect = tidy(eff_hi), series = "95% upper bound", stringsAsFactors = FALSE))
results$effect_over_time <- place_trend(eff_df, x = "period", y = "effect", series = "series", place = "effect_over_time")
#' One scale per chart (LAT-3180): the jump and the average effect are both in the value's units; the slope change is not.
int_df <- data.frame(term = c(sprintf("Jump at %s", change_lbl), sprintf("Average effect per %s after", period)),
estimate = tidy(c(lv[["est"]], avg_eff)), low = tidy(c(lv[["low"]], avg_lo)), high = tidy(c(lv[["high"]], avg_hi)),
stringsAsFactors = FALSE)
results$change_interval <- place_interval(int_df, term = "term", value = "estimate", low = "low", high = "high", place = "change_interval")
fitted_all <- as.numeric(stats::fitted(fit))
seg_df <- rbind(data.frame(period = periods, value = tidy(x), series = "Observed", stringsAsFactors = FALSE),
data.frame(period = periods[pre_i], value = tidy(fitted_all[pre_i]), series = "Fitted before", stringsAsFactors = FALSE),
data.frame(period = periods[post_i], value = tidy(fitted_all[post_i]), series = "Fitted after", stringsAsFactors = FALSE))
results$segment_fit <- place_trend(seg_df, x = "period", y = "value", series = "series", place = "segment_fit")
cmp_df <- data.frame(period = c("Before the change", "After the change"), mean = tidy(c(mean(x[pre_i]), mean(x[post_i]))),
stringsAsFactors = FALSE)
results$period_comparison <- place_comparison(cmp_df, category = "period", value = "mean", place = "period_comparison")
model_df <- data.frame(
term = c("Level at the start", sprintf("Trend before the change, per %s", period), sprintf("Jump at %s", change_lbl),
sprintf("Change in trend after, per %s", period), sprintf("Average effect per %s after", period), "Cumulative effect after"),
estimate = tidy(c(b0[["est"]], b1[["est"]], lv[["est"]], sl[["est"]], avg_eff, cum_eff)),
std_error = tidy(c(b0[["se"]], b1[["se"]], lv[["se"]], sl[["se"]], se_avg, np * se_avg)),
low = tidy(c(b0[["low"]], b1[["low"]], lv[["low"]], sl[["low"]], avg_lo, cum_lo)),
high = tidy(c(b0[["high"]], b1[["high"]], lv[["high"]], sl[["high"]], avg_hi, cum_hi)),
p_value = p_cell(c(b0[["p"]], b1[["p"]], lv[["p"]], sl[["p"]], avg_p, avg_p)),
stringsAsFactors = FALSE)
results$model_table <- place_table(model_df, place = "model_table")
checks_df <- data.frame(
check = c("The change date is known", "Enough points on each side", "Serial correlation accounted for", "No change before the change", "Residuals roughly normal"),
statistic = c(switch(date_source, given = "given as a parameter", period = paste0("read from ", period_name), assumed = "assumed at the middle of the series"),
sprintf("%d before, %d after", n_before, n_after),
sprintf("lag-1 autocorrelation = %s", round(r1, 2)),
if (is.na(placebo_p)) "not run: fewer than 16 points before the change" else "a false change at the middle of the before period",
"Shapiro-Wilk on the residuals"),
p_value = c("", "", "", fmt_p(placebo_p), fmt_p(shapiro_p)),
verdict = c(if (date_source == "assumed") "violated" else "holds",
if (min(n_before, n_after) >= 20) "holds" else "strained",
if (!is.finite(r1)) "unknown" else if (r1 <= 0.2 || use_ar1) "holds" else "violated",
verdict_p(placebo_p),
verdict_p(shapiro_p)),
note = c(if (date_source == "assumed") "the middle of the series stands in for the real date, so the effect may be misplaced" else "the before and after periods are split at the known change",
"few points on a side make the jump and the expected path uncertain",
if (use_ar1) "the errors are serially correlated and were modelled with AR(1) errors, so the intervals already allow for it" else if (is.finite(r1) && r1 > 0.2) "correlated errors fitted as independent make the intervals too narrow; run with model ar1" else "the errors show little serial correlation, so the intervals can be read at face value",
"a jump where nothing changed means the series moves on its own, so the real jump may not be the change",
"strongly non-normal residuals make the intervals approximate"),
stringsAsFactors = FALSE)
results$assumption_checks <- place_table(checks_df, place = "assumption_checks")
results$impact_method <- list(kind = "metric", values = list(
method = method, n_in = n_in, n_used = n_used, excluded = as.list(excluded_rows),
x_column = date_name, y_column = value_name,
assumptions = list(
"Without the change the series would have kept the straight-line trend it had before; a trend that was already bending makes the expected path wrong.",
"Nothing else changed at the same time; another event on the same date is folded into the effect.",
"The change took effect at the date given, not gradually before or after it.",
"Seasonality is not modelled; a seasonal series needs at least a full cycle on each side, or a seasonally adjusted value.",
"A difference from the expected path is an association in time, not proof that the change caused it.")))
objects <- list()
list(answer = answer, method = method, n = n_used, results = results, objects = objects,
json_output = list(answer = answer, method = method, n = n_used))
}