Forecast
Projects where a measure is heading from its own history, with a likely range, and checks the projection against recent periods it was not shown.
VERSION · v1.0.0
RUN DATE · 14 September 2026
DATA · 144 rows
RUN DATE · 14 September 2026
DATA · 144 rows
Objective
Where will monthly passenger numbers be a year from now?
This report contains
- SummaryWhere the measure is heading, by how much, and how accurate the projection was on recent periods.
- History and projectionThe measure over time, continued into the future with its likely range.
- Range for each future periodThe projected value for each period and how wide its likely range is.
- Tested against the pastHow close the projection came on recent periods it was not shown.
- Seasonal patternWhich parts of the cycle run above or below the usual level.
- Full projectionsEvery future period with its projected value and likely ranges.
- What the results rely onEach condition the analysis depends on, and whether it holds.
- How it was doneThe method, the data used, and what to keep in mind.
Forecast
Where it is heading
Passenger numbers continue rising steeply ahead
Forecast rises sharply continuing recent growth, with widening uncertainty band toward the horizon.
The forecast line climbs steeply from history's endpoint, and the gap between Lower and Upper bounds widens as time extends forward.
Passenger numbers continue rising steeply ahead
The projection clearly continues the strong upward pattern evident in recent history, with the forecast trajectory rising markedly. The confidence band widens toward the end of the forecast horizon, indicating growing uncertainty about the exact level further ahead. Seasonal swings remain visible in the projection, matching the oscillations shown in historical data. One check on residuals shows strain, so treat the band width as approximate rather than precise.
The forecast line climbs steeply from history's endpoint, and the gap between Lower and Upper bounds widens as time extends forward.
Forecast
Where it is heading
Forecast band widens steadily over twelve months
Uncertainty grows as the horizon extends, widening the range around each forecast.
Compare the gap between lower and upper bounds at the first period against the last period.
Forecast band widens steadily over twelve months
The confidence intervals widen clearly from the opening month through the final month, reflecting the model's increasing uncertainty about passenger numbers further ahead. Early months show tighter bounds while later months show substantially wider ranges. This widening is typical for forecasts and expected; however, residuals show a strained check that may limit confidence in the interval widths themselves. Readers should note that while the point forecasts follow a seasonal pattern, the growing bands mean actual outcomes could fall well outside early expectations.
Compare the gap between lower and upper bounds at the first period against the last period.
Forecast
How much to trust it
Projection tracks actual passengers closely
Predicted passenger numbers stay near actual values throughout the backtest period, supporting forecast reliability.
The predicted line hugs the actual line across all months, showing consistent tracking with no systematic drift.
Projection tracks actual passengers closely
The predicted series tracks the actual values closely through the entire backtest window, following the same seasonal pattern and magnitude. The fit is clearly tight, with deviations remaining small and balanced rather than drifting persistently in one direction. One check is strained: residuals show some correlation, which suggests the model may not fully capture all temporal dependencies. This limits confidence slightly, but the overall tracking quality remains strong enough to support the projection forward.
The predicted line hugs the actual line across all months, showing consistent tracking with no systematic drift.
Summer peaks, winter and spring valleys
Summer months run well above average, winter and spring well below; year-ahead forecast depends on the calendar month.
July and August show the largest uplifts; November and February show the deepest drops below the baseline.
Summer peaks, winter and spring valleys
July and August sit clearly above the seasonal baseline, with summer months from June onward running consistently higher. Winter and spring months, particularly November and February, fall clearly below. The swing from the deepest winter trough to the peak summer effect is substantial. One residual check is strained, which slightly limits confidence in the exact magnitudes, but the seasonal pattern itself is clear and consistent across the cycle.
July and August show the largest uplifts; November and February show the deepest drops below the baseline.
Forecast
The numbers
Passengers rise then fall through forecast year
Passenger numbers peak mid-year then decline, with widening uncertainty bands beyond the first months.
July stands as the highest forecast period, while November represents the lowest point across the entire year ahead.
Passengers rise then fall through forecast year
The forecast shows clear seasonal pattern: numbers rise from January through July, peak in July, then fall through December. The point forecasts carry this direction consistently across all rows. Uncertainty widens notably as the horizon extends, with the bands roughly doubling from January to December. One check is strained (residuals uncorrelated), which suggests the model may underestimate forecast error in later months. Look next at whether the seasonal pattern matches historical norms and whether the widening bands reflect acceptable limits for planning.
July stands as the highest forecast period, while November represents the lowest point across the entire year ahead.
Forecast
Assumptions and method
Checks: one strained, four hold
Strained: residuals uncorrelated.
Holding: enough history, checked against unseen periods, backtest error acceptable, model converged.
Checks: one strained, four hold
Residuals uncorrelated is strained: correlated residuals mean the model left a pattern in the data. The other four hold.
Holding: enough history, checked against unseen periods, backtest error acceptable, model converged.
Holt-Winters exponential smoothing (level, trend, additive seasonality) of #Passengers by Month: 144 monthly periods used of 144 rows in (0 dropped for a missing date or value; 0 rows sharing a date combined by sum; 0 missing periods interpolated linearly); horizon 24 months (a quarter of the history, capped at two cycles and 30); 80% and 95% prediction intervals from the fitted model; trend_per_period and seasonal_swing are the fitted model's terminal trend and seasonal states, which are smoothed CURRENT rates and not the average slope or the peak-to-trough amplitude of the whole history; backtest on the last 12 periods withheld: MAPE 2.5%, MAE 11.56.
144 of 144 rows · Month → #Passengers
caveatExponential smoothing assumes the recent pattern continues; residuals show some correlation, limiting confidence.
The forecast uses Holt-Winters exponential smoothing on a complete monthly history to project passenger numbers forward. The model assumes the observed level, trend, and seasonal pattern will persist unchanged, which may not hold if operations or demand shift structurally. The backtest on unseen periods shows acceptable error, and the model converged cleanly. However, the residuals exhibit some correlation, a strained check that suggests the model may not have fully captured the underlying dynamics and could underestimate forecast uncertainty. Readers should verify that the recent pattern remains valid before acting on projections at the edge of the prediction intervals.
Forecast
The code behind this report
The code that produced every figure in this report, exactly as it ran. Fingerprint 32c919b65550fd32. The same code on the same data gives the same report.
`standard_forecasting_v2` <- function(pf) {
#' Readable figures (LAT-3181, as LAT-3180): 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)))))
}
`%||%` <- function(a, b) if (!is.null(a)) a else b
compact <- function(l) l[!vapply(l, function(x) is.null(x) || (length(x) == 1 && is.na(x)), logical(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 %||%
"Where is this metric heading over the coming periods, and how sure can we be?"
#' ## Column mapping
#' The customer maps one `date` column and one numeric `value` column. Every
#' other column of the file is excluded by construction and named as such in
#' the method: a forecast of one metric from its own history uses nothing else.
col_map <- inputs$column_mapping %||% list()
raw <- inputs$dataset
raw_names <- if (is.data.frame(raw)) names(raw) else if (is.list(raw) && length(raw)) names(raw[[1]]) else character(0)
unmapped <- setdiff(raw_names, as.character(unlist(col_map)))
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")
#' ## Parameters
#' `aggregate`: how rows sharing one date are combined (sum, the default, for
#' transactional data; mean for a rate or a level). `horizon`: periods to
#' project; by default a quarter of the history, capped at two seasonal cycles
#' and thirty periods.
aggregate_fn <- tolower(as.character(params$aggregate %||% "sum"))
if (!aggregate_fn %in% c("sum", "mean")) stop(sprintf("module_parameters$aggregate must be 'sum' or 'mean', got '%s'", aggregate_fn))
horizon_param <- suppressWarnings(as.integer(params$horizon %||% NA))
if (!is.na(horizon_param) && (horizon_param < 2 || horizon_param > 60)) stop("module_parameters$horizon must be between 2 and 60 periods")
#' ## Data preparation
#' Dates are parsed against the common formats and the one that reads the most
#' values wins; more than 5% unreadable dates stops the tool. The value must be
#' numeric (95% rule). Rows with no date or no value are dropped; rows sharing a
#' date are aggregated; the cadence is inferred from the median gap; the series
#' is laid on a regular grid and small gaps are interpolated linearly.
n_in <- nrow(df)
if (!"date" %in% names(df)) stop("column_mapping must map a 'date' column (when each value was observed)")
if (!"value" %in% names(df)) stop("column_mapping must map a 'value' column (the numeric metric to forecast)")
if (n_in < 15) stop(sprintf("Only %d rows; forecasting '%s' needs at least 15 dated observations.", n_in, value_name))
parse_dates <- function(v) {
if (inherits(v, "Date")) return(v)
if (inherits(v, "POSIXt")) return(as.Date(v))
s <- trimws(as.character(v)); s[!nzchar(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", "%d %b %Y", "%Y%m%d", "%Y-%m")
best <- as.Date(rep(NA_character_, length(s))); best_n <- -1L
for (f in fmts) {
d <- suppressWarnings(as.Date(if (f == "%Y-%m") paste0(s, "-01") else s, format = if (f == "%Y-%m") "%Y-%m-%d" else f))
n_ok <- sum(!is.na(d))
if (n_ok > best_n) { best <- d; best_n <- n_ok }
}
best
}
raw_date <- df$date
non_blank <- !(is.na(raw_date) | !nzchar(trimws(as.character(raw_date))))
d <- parse_dates(raw_date)
if (sum(non_blank) == 0) stop(sprintf("The '%s' column is empty; there are no dates to forecast from.", date_name))
n_unparsed <- sum(non_blank & is.na(d))
if (n_unparsed / sum(non_blank) > 0.05) stop(sprintf(
"%d of %d values in '%s' could not be read as dates. Use a recognisable date format such as 2024-01-31 or 01/31/2024.",
n_unparsed, sum(non_blank), date_name))
v <- df$value
if (!is.numeric(v)) {
conv <- suppressWarnings(as.numeric(as.character(v)))
n_orig <- sum(!is.na(v) & nzchar(as.character(v)))
if (n_orig > 0 && sum(!is.na(conv)) >= 0.95 * n_orig) v <- conv
else stop(sprintf("The '%s' column is not numeric; a forecast needs a numeric metric.", value_name))
}
v <- as.numeric(v)
keep <- !is.na(d) & !is.na(v)
n_dropped_rows <- n_in - sum(keep)
work <- data.frame(date = d[keep], value = v[keep])
n_dup_rows <- nrow(work) - length(unique(work$date))
agg <- aggregate(value ~ date, data = work, FUN = if (aggregate_fn == "sum") sum else mean)
agg <- agg[order(agg$date), , drop = FALSE]
if (nrow(agg) < 10) stop(sprintf("Only %d distinct dates in '%s' after cleaning; at least 10 periods are needed to forecast '%s'.", nrow(agg), date_name, value_name))
gaps <- as.numeric(diff(agg$date)); med_gap <- median(gaps)
if (med_gap <= 1.5) {
freq_label <- "daily"; step_days <- 1; freq <- 7; period_word <- "day"; cycle_word <- "week"
} else if (med_gap >= 5.5 && med_gap <= 8.5) {
freq_label <- "weekly"; step_days <- 7; freq <- 52; period_word <- "week"; cycle_word <- "year"
} else if (med_gap >= 26 && med_gap <= 35) {
freq_label <- "monthly"; step_days <- NA; freq <- 12; period_word <- "month"; cycle_word <- "year"
} else {
freq_label <- "irregular"; step_days <- max(1, round(med_gap)); freq <- 1
period_word <- sprintf("%d-day period", step_days); cycle_word <- "cycle"
}
if (freq_label == "monthly") {
snapped <- as.Date(format(agg$date, "%Y-%m-01"))
agg <- aggregate(value ~ date, data = data.frame(date = snapped, value = agg$value),
FUN = if (aggregate_fn == "sum") sum else mean)
agg <- agg[order(agg$date), , drop = FALSE]
grid <- seq(min(agg$date), max(agg$date), by = "month")
} else {
grid <- seq(min(agg$date), max(agg$date), by = step_days)
}
#' ### Step: is the final period complete?
#' A transactional export cut part-way through a period leaves the last bucket holding a
#' fraction of its rows, so its SUM is low through no change in the business. Measured
#' from that value the projected change is fabricated: four of four transactional
#' fixtures produced a headline rise against a flat truth (LAT-3105 review). When the
#' last bucket holds clearly fewer rows than the periods before it, drop it and say so.
#' With one row per period the question cannot be answered from the data, and the
#' assumptions say so rather than pretending otherwise.
partial_note <- NULL
if (aggregate_fn == "sum" && nrow(agg) >= 4) {
bkeys <- as.character(if (freq_label == "monthly") as.Date(format(work$date, "%Y-%m-01")) else work$date)
cnt <- table(bkeys)
last_key <- as.character(agg$date[nrow(agg)])
last_cnt <- if (last_key %in% names(cnt)) as.integer(cnt[[last_key]]) else NA_integer_
prior <- as.integer(cnt[setdiff(names(cnt), last_key)])
med_cnt <- if (length(prior)) median(prior) else NA_real_
#' THE THRESHOLD IS DELIBERATELY LOW-BAR. At 0.5 a final day holding 11 of 20 rows
#' passed and the headline still read +74.8% against a flat truth (measured). The two
#' errors are not symmetric: dropping a complete-but-light period costs one period of
#' history and is stated plainly, while keeping a partial one fabricates the number the
#' customer reads first. So 0.9, and the sentence below is true either way.
if (!is.na(last_cnt) && !is.na(med_cnt) && med_cnt >= 2 && last_cnt < 0.9 * med_cnt) {
partial_note <- sprintf("the final period (%s) carried %d rows against a median of %s in the periods before it, so it was treated as an incomplete export and dropped before any figure was computed; were that period in fact complete, the change is simply measured from the period before it",
last_key, last_cnt, format(med_cnt))
agg <- agg[-nrow(agg), , drop = FALSE]
grid <- if (freq_label == "monthly") seq(min(agg$date), max(agg$date), by = "month")
else seq(min(agg$date), max(agg$date), by = step_days)
if (nrow(agg) < 10) stop(sprintf("Only %d complete periods remain in '%s' after dropping an incomplete final period; at least 10 are needed to forecast '%s'.", nrow(agg), date_name, value_name))
}
}
interp <- approx(x = as.numeric(agg$date), y = agg$value, xout = as.numeric(grid), rule = 2)
values <- interp$y
n_interp <- sum(!(as.numeric(grid) %in% as.numeric(agg$date)))
if (freq_label != "irregular" && n_interp / length(grid) > 0.5) stop(sprintf(
"More than half of the %s periods between the first and last '%s' are missing; too sparse to forecast reliably.", freq_label, date_name))
n_points <- length(values); n_used <- n_points
#' ## The model: a fit chain that never crashes
#' Seasonal Holt-Winters (additive) when the history holds at least two full
#' cycles, else Holt's level-plus-trend smoothing, else ARIMA(1,1,1), else a
#' linear drift with residual bands. A constant history projects flat. 80% and
#' 95% prediction intervals come from the fitted model. Base R only.
fit_chain <- function(values, freq, h) {
#' A NON-CONVERGED OPTIMISER IS A WARNING, NOT AN ERROR. HoltWinters returns a fit
#' object after `ABNORMAL_TERMINATION_IN_LNSRCH`, so `suppressWarnings()` reported a
#' failed optimisation as a clean fit (LAT-3105 review). Collect the warnings and carry
#' them out instead, so the method text can say the model did not converge.
warns <- character(0)
collect <- function(expr) withCallingHandlers(
tryCatch(expr, error = function(e) NULL),
warning = function(w) { warns <<- c(warns, conditionMessage(w)); invokeRestart("muffleWarning") })
out <- (function() {
z80 <- qnorm(0.90); z95 <- qnorm(0.975); n <- length(values); lastv <- values[n]
if (is.na(sd(values)) || sd(values) < 1e-9) {
flat <- rep(lastv, h)
return(list(method = "flat", label = "flat projection (the history is constant)", seasonal = FALSE,
mean = flat, lwr95 = flat, upr95 = flat, lwr80 = flat, upr80 = flat, fit = NULL))
}
min_seasonal_n <- if (freq >= 24) 2 * freq else 2 * freq + 5
allow_seasonal <- freq > 1 && n >= min_seasonal_n
hw_predict <- function(fit, label, key, seasonal) {
p95 <- collect(predict(fit, n.ahead = h, prediction.interval = TRUE, level = 0.95))
p80 <- collect(predict(fit, n.ahead = h, prediction.interval = TRUE, level = 0.80))
if (is.null(p95) || is.null(p80) || !all(is.finite(p95))) return(NULL)
list(method = key, label = label, seasonal = seasonal, mean = as.numeric(p95[, "fit"]),
lwr95 = as.numeric(p95[, "lwr"]), upr95 = as.numeric(p95[, "upr"]),
lwr80 = as.numeric(p80[, "lwr"]), upr80 = as.numeric(p80[, "upr"]), fit = fit)
}
if (allow_seasonal) {
hw <- collect(HoltWinters(ts(values, frequency = freq), seasonal = "additive"))
if (!is.null(hw)) { out <- hw_predict(hw, "Holt-Winters exponential smoothing (level, trend, additive seasonality)", "hw_seasonal", TRUE); if (!is.null(out)) return(out) }
}
hw2 <- collect(HoltWinters(ts(values, frequency = max(freq, 1)), gamma = FALSE))
if (!is.null(hw2)) { out <- hw_predict(hw2, "Holt exponential smoothing (level and trend, no seasonality)", "hw_trend", FALSE); if (!is.null(out)) return(out) }
ar <- collect(arima(ts(values), order = c(1, 1, 1)))
if (!is.null(ar)) {
pr <- collect(predict(ar, n.ahead = h))
if (!is.null(pr) && all(is.finite(pr$pred))) {
m <- as.numeric(pr$pred); se <- as.numeric(pr$se)
return(list(method = "arima", label = "ARIMA(1,1,1)", seasonal = FALSE, mean = m,
lwr95 = m - z95 * se, upr95 = m + z95 * se, lwr80 = m - z80 * se, upr80 = m + z80 * se, fit = ar))
}
}
idx <- seq_len(n); lmfit <- lm(values ~ idx)
m <- as.numeric(predict(lmfit, newdata = data.frame(idx = n + seq_len(h))))
s <- max(sd(residuals(lmfit)), 1e-9)
list(method = "drift", label = "linear trend projection (fallback)", seasonal = FALSE, mean = m,
lwr95 = m - z95 * s, upr95 = m + z95 * s, lwr80 = m - z80 * s, upr80 = m + z80 * s, fit = lmfit)
})()
out$warnings <- unique(warns)
out
}
horizon <- if (!is.na(horizon_param)) horizon_param else max(2, min(floor(0.25 * n_points), 2 * max(freq, 3), 30))
fitres <- fit_chain(values, freq, horizon)
seasonal_fit <- isTRUE(fitres$seasonal)
future_dates <- if (freq_label == "monthly") seq(grid[length(grid)], by = "month", length.out = horizon + 1)[-1]
else grid[length(grid)] + step_days * seq_len(horizon)
#' ## Backtest on a held-out tail
#' The last max(freq, 6) points (at most a third of the series) are withheld,
#' the chain is refitted on the rest, and the withheld points are predicted by
#' a model that never saw them. MAPE and MAE are reported from that window.
mape <- NA_real_; mae <- NA_real_; holdout_n <- 0L; backtest_note <- NULL; bt_df <- NULL
holdout_target <- min(max(freq, 6), floor(n_points / 3))
if (holdout_target >= 4 && (n_points - holdout_target) >= 10) {
bt <- tryCatch(fit_chain(values[seq_len(n_points - holdout_target)], freq, holdout_target), error = function(e) NULL)
if (!is.null(bt)) {
act <- values[(n_points - holdout_target + 1):n_points]; pred <- bt$mean
mae <- mean(abs(act - pred)); nz <- abs(act) > 1e-9
if (any(nz)) mape <- mean(abs((act[nz] - pred[nz]) / act[nz])) * 100
holdout_n <- holdout_target
periods <- format(grid[(n_points - holdout_target + 1):n_points], "%Y-%m-%d")
bt_df <- rbind(data.frame(period = periods, value = tidy(act), series = "actual", stringsAsFactors = FALSE),
data.frame(period = periods, value = tidy(pred), series = "predicted", stringsAsFactors = FALSE))
} else backtest_note <- "backtest skipped: the model could not be refitted on the shortened window"
} else backtest_note <- "backtest skipped: the series is too short to hold out a test window"
#' ## The headline numbers and the components
#' `last_actual` is the last COMPLETE period: an incomplete final bucket was dropped
#' above, because the projected change is measured from this number.
fit_warning <- unique(c(fitres$warnings, if (exists("bt") && !is.null(bt)) bt$warnings))
fit_warning <- fit_warning[nzchar(fit_warning %||% "")]
last_actual <- values[n_points]; fc_end <- fitres$mean[horizon]
pct_change <- if (abs(last_actual) > 1e-9) (fc_end - last_actual) / abs(last_actual) * 100 else NA_real_
direction <- if (is.na(pct_change)) "move" else if (pct_change > 2) "rise" else if (pct_change < -2) "fall" else "hold roughly steady"
idx <- seq_len(n_points)
trend_slope <- as.numeric(coef(lm(values ~ idx))[2]); level_now <- last_actual
seasonal_amplitude <- 0; seasonal_coefs <- numeric(0)
if (fitres$method %in% c("hw_seasonal", "hw_trend") && !is.null(fitres$fit)) {
co <- coef(fitres$fit)
if ("a" %in% names(co)) level_now <- as.numeric(co["a"])
if ("b" %in% names(co)) trend_slope <- as.numeric(co["b"])
if (seasonal_fit) {
seasonal_coefs <- as.numeric(co[grep("^s[0-9]+$", names(co))])
if (length(seasonal_coefs)) seasonal_amplitude <- max(seasonal_coefs) - min(seasonal_coefs)
}
}
sp_df <- NULL; seasonal_reason <- NULL
if (!seasonal_fit) {
seasonal_reason <- sprintf("no repeating %s pattern was fitted: the history holds fewer than two full %ss of %s data, so the model projects level and trend only",
cycle_word, cycle_word, freq_label)
} else if (length(seasonal_coefs) != freq) {
seasonal_reason <- sprintf("the fitted seasonal states did not cover a whole %s, so there is no within-cycle pattern to show", cycle_word)
}
if (seasonal_fit && length(seasonal_coefs) == freq) {
# Holt-Winters' s1..s_freq are the seasonal states for the NEXT freq periods
# after the series end; label them by those calendar positions.
season <- if (freq_label == "monthly") format(seq(grid[length(grid)], by = "month", length.out = freq + 1)[-1], "%B")
else if (freq_label == "daily") weekdays(grid[length(grid)] + seq_len(freq))
else paste0("Week ", format(grid[length(grid)] + step_days * seq_len(freq), "%V"))
sp_df <- data.frame(season = season, effect = tidy(seasonal_coefs), stringsAsFactors = FALSE)
}
#' ## Frames for the places (history capped at 1 500 points for the picture)
hist_keep <- if (n_points > 1500) (n_points - 1499):n_points else seq_len(n_points)
fc_periods <- format(future_dates, "%Y-%m-%d")
#' LAT-3181: the band lines are named for the reader (the legend printed lower_95 / upper_95), and the table's periods
#' read as calendar labels (Jan 1961); the charts keep ISO dates so the time axis stays a time axis.
series_df <- rbind(
data.frame(period = format(grid[hist_keep], "%Y-%m-%d"), value = tidy(values[hist_keep]), series = "History", stringsAsFactors = FALSE),
data.frame(period = fc_periods, value = tidy(fitres$mean), series = "Forecast", stringsAsFactors = FALSE),
data.frame(period = fc_periods, value = tidy(fitres$lwr95), series = "Lower 95%", stringsAsFactors = FALSE),
data.frame(period = fc_periods, value = tidy(fitres$upr95), series = "Upper 95%", stringsAsFactors = FALSE))
rownames(series_df) <- NULL
fc_labels <- if (freq_label == "monthly") format(future_dates, "%b %Y") else format(future_dates, "%Y-%m-%d")
table_df <- data.frame(period = fc_labels, forecast = tidy(fitres$mean),
lower_80 = tidy(fitres$lwr80), upper_80 = tidy(fitres$upr80),
lower_95 = tidy(fitres$lwr95), upper_95 = tidy(fitres$upr95), stringsAsFactors = FALSE)
interval_df <- data.frame(period = fc_periods, forecast = table_df$forecast, lower_95 = table_df$lower_95,
upper_95 = table_df$upper_95, stringsAsFactors = FALSE)
#' ## Method text and the answer
excluded <- character(0); why <- character(0)
if (length(unmapped)) { excluded <- unmapped }
method <- paste0(
fitres$label, " of ", value_name, " by ", date_name, ": ", n_points, " ", freq_label, " periods used of ", n_in, " rows in (",
n_dropped_rows, " dropped for a missing date or value; ", n_dup_rows, " rows sharing a date combined by ", aggregate_fn, "; ",
n_interp, " missing periods interpolated linearly)",
# LAT-3181: one reason for every unmapped column, said once (it was repeated per column)
if (length(excluded)) paste0("; not used: ", paste(excluded, collapse = ", "), " (a forecast of one metric from its own history uses no other column)") else "",
"; horizon ", horizon, " ", period_word, "s", if (!is.na(horizon_param)) " (set by parameter)" else " (a quarter of the history, capped at two cycles and 30)",
if (!is.null(partial_note)) paste0("; ", partial_note) else "",
"; 80% and 95% prediction intervals from the fitted model",
"; trend_per_period and seasonal_swing are the fitted model's terminal trend and seasonal states, which are smoothed CURRENT rates and not the average slope or the peak-to-trough amplitude of the whole history",
if (length(fit_warning)) paste0("; the optimiser did not converge cleanly (", paste(fit_warning, collapse = "; "), "), so treat the intervals as indicative") else "",
if (holdout_n > 0) sprintf("; backtest on the last %d periods withheld: MAPE %.1f%%, MAE %s", holdout_n, mape, format(tidy(mae), big.mark = ",")) else paste0("; ", backtest_note),
".")
assumptions <- list(
"The pattern in the history (level, trend and any repeating seasonal swing) continues over the horizon; a structural break is not modelled.",
"Rows sharing one date belong to the same period and are combined as stated; check that the aggregate is the right reading of the metric.",
"Prediction intervals assume roughly normal, stable errors; a series whose spread grows with its level will have bands that are too narrow at the top.",
"A backtest MAPE above about 15% means the projection is indicative, not reliable.",
if (!is.null(partial_note)) "The final period was incomplete and was dropped; the change is measured from the last complete period."
else "The last observed period is assumed COMPLETE. A file exported part-way through a period reads low there, and the projected change is measured from it, so check the export window before acting on the percentage.")
if (length(fit_warning)) assumptions <- c(assumptions, list(paste0("The model's optimiser reported: ", paste(fit_warning, collapse = "; "), ". The fit was used anyway; a second opinion on this series is worth having.")))
statement <- sprintf("%s is projected to %s%s over the next %d %ss, from %s at the last observed %s to %s at the end of the horizon (95%% band %s to %s).",
value_name, direction, if (is.na(pct_change)) "" else sprintf(" by %.1f%%", abs(pct_change)), horizon, period_word,
format(round(last_actual, 2), big.mark = ","), period_word, format(round(fc_end, 2), big.mark = ","),
format(round(fitres$lwr95[horizon], 2), big.mark = ","), format(round(fitres$upr95[horizon], 2), big.mark = ","))
answer <- compact(list(projected_change_pct = round(pct_change, 2), forecast_end = round(fc_end, 4), last_actual = round(last_actual, 4),
horizon = horizon, frequency = freq_label, model = fitres$label, seasonal = seasonal_fit,
holdout_mape_pct = round(mape, 2), trend_per_period = round(trend_slope, 4),
seasonal_swing = round(seasonal_amplitude, 4), n = n_points,
final_period_dropped = !is.null(partial_note),
converged = !length(fit_warning)))
lead <- if (is.na(pct_change)) "forecast_end" else "projected_change_pct"
# ── Results: one entry per place ─────────────────────────────────────────────
#' ## Summary metrics and assumption checks (LAT-3138): the figures that summarise the
#' whole analysis as one metrics row, and one verdict per assumption of the method,
#' each with the statistic behind it. holds / strained / violated are rules of thumb a
#' reader can re-derive from the statistic shown beside them. Base R throughout.
verdict_p <- function(p, soft = 0.05, hard = 0.001) if (is.na(p)) "unknown" else if (p >= soft) "holds" else if (p >= hard) "strained" else "violated"
fmt_p <- function(p) if (is.na(p)) "" else if (p < 1e-4) "<0.0001" else as.character(signif(p, 3))
summary_vals <- list(projected_change_pct = round(pct_change, 1), forecast_end = tidy(fc_end), last_actual = tidy(last_actual),
holdout_mape_pct = if (is.na(mape)) NA_real_ else round(mape, 1), horizon = horizon, n = n_points)
res_v <- tryCatch({ f <- fitres$fit; r <- if (is.null(f)) NULL else as.numeric(residuals(f)); r[is.finite(r)] }, error = function(e) NULL)
res_r1 <- if (!is.null(res_v) && length(res_v) > 3) { rm_ <- mean(res_v); sum((res_v[-length(res_v)] - rm_) * (res_v[-1] - rm_)) / sum((res_v - rm_)^2) } else NA_real_
cycles <- if (freq > 1) n_points / freq else NA_real_
checks_df <- data.frame(
check = c("Enough history", "Checked against unseen periods", "Backtest error acceptable", "Residuals uncorrelated", "Model converged"),
statistic = c(if (is.na(cycles)) paste0(n_points, " points, no seasonal cycle") else paste0(round(cycles, 1), " cycles of ", freq, " periods"),
if (is.null(bt_df)) (backtest_note %||% "no backtest ran") else paste0(holdout_n, " withheld periods"),
if (is.na(mape)) "no backtest error" else paste0("MAPE = ", round(mape, 1), "%"),
if (is.na(res_r1)) "not assessed" else paste0("lag-1 autocorrelation = ", round(res_r1, 2)),
if (length(fit_warning)) "the fit reported warnings" else "no warnings"),
p_value = c("", "", "", "", ""),
verdict = c(if (is.na(cycles)) (if (n_points >= 24) "holds" else if (n_points >= 12) "strained" else "violated") else if (cycles >= 3) "holds" else if (cycles >= 2) "strained" else "violated",
if (is.null(bt_df)) "violated" else "holds",
if (is.na(mape)) "unknown" else if (mape < 10) "holds" else if (mape < 20) "strained" else "violated",
if (is.na(res_r1)) "unknown" else if (abs(res_r1) < 0.3) "holds" else if (abs(res_r1) < 0.6) "strained" else "violated",
if (length(fit_warning)) "strained" else "holds"),
note = c("a seasonal model needs at least two full cycles to learn the pattern",
"without a backtest the projection is not checked against periods the model never saw",
"MAPE is the average percentage miss on the withheld periods",
"correlated residuals mean the model left a pattern in the data",
"a warning usually means the optimiser stopped short"),
stringsAsFactors = FALSE)
results <- list()
#' The verdict and the headline are NOT places of a library tool (LAT-3130): a
#' library tool supplies data objects; the answer is written by the last mile,
#' which is the first stage that reads the objects together.
#' ## summary_metrics: the whole analysis at a glance (LAT-3138)
results$summary_metrics <- place_metric(summary_vals, lead = "projected_change_pct", place = "summary_metrics")
#' ## assumption_checks: a verdict per assumption (a `checks` place, table-shaped)
results$assumption_checks <- place_table(checks_df, place = "assumption_checks")
#' ## forecast_series: the history and the projection with its 95% band, one line per series
results$forecast_series <- place_trend(series_df, x = "period", y = "value", series = "series", place = "forecast_series")
#' ## forecast_interval: each horizon period's point forecast between its 95% bounds
results$forecast_interval <- place_interval(interval_df, term = "period", value = "forecast", low = "lower_95", high = "upper_95",
place = "forecast_interval")
#' ## holdout_backtest: actual against predicted over the withheld tail.
#' A CONDITIONAL PLACE IS WRITTEN EITHER WAY (LAT-3102). Leaving the entry out is not how
#' to say "this run could not fill it": the mapper cannot tell a place the tool MEANT to
#' skip from one it died before writing, it logs a refusal at ERROR on every such run, and
#' before LAT-3102 it drew the card from whatever table came first in `results`. The reason
#' string is what the reader sees in place of the card, so it is written for them.
if (!is.null(bt_df)) {
results$holdout_backtest <- place_trend(bt_df, x = "period", y = "value", series = "series", place = "holdout_backtest")
} else {
results$holdout_backtest <- place_dropped(paste0(
backtest_note %||% "no backtest ran",
", so the projection here is not checked against periods the model never saw"), place = "holdout_backtest")
}
#' ## seasonal_pattern: the additive seasonal effect by calendar position
if (!is.null(sp_df)) {
results$seasonal_pattern <- place_comparison(sp_df, category = "season", value = "effect", place = "seasonal_pattern")
} else {
results$seasonal_pattern <- place_dropped(seasonal_reason %||%
"no seasonal component was fitted for this series", place = "seasonal_pattern")
}
#' ## forecast_table: every horizon period with both bands
results$forecast_table <- place_table(table_df, place = "forecast_table")
#' ## forecast_method: how it was done
results$forecast_method <- list(kind = "metric", values = list(
method = method, n_in = n_in, n_used = n_used, excluded = as.list(unname(excluded)), assumptions = assumptions,
# LAT-3181: the method card's "rows · x → y" line reads these; unset, it printed a bare arrow
x_column = date_name, y_column = value_name),
value_order = list("n_used", "n_in"))
objects <- list() # filled by the object layer, not here
list(answer = answer, method = method, n = n_used, results = results, objects = objects,
json_output = list(answer = answer, method = method, n = n_used))
}