diff --git a/.Rbuildignore b/.Rbuildignore index d13afd1c..9ffe1a8c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -14,5 +14,7 @@ cran-comments.md ^\.positai$ ^\.claude$ ^\.codex$ +^\.agents$ +^\.cursor$ ^AGENTS\.md$ ^CLAUDE\.md$ diff --git a/.claude/rules/agent-runtime.md b/.claude/rules/agent-runtime.md index 491afecf..2ba5a9d0 100644 --- a/.claude/rules/agent-runtime.md +++ b/.claude/rules/agent-runtime.md @@ -1,12 +1,18 @@ --- paths: - "R/agent_*.R" + - "R/final_models.R" + - "R/forecast_selection.R" - "R/run_info.R" - "R/input_checks.R" - "R/prep_data.R" - "R/prep_models.R" - "R/read_write_data.R" + - "tests/testthat/helper-forecast-selection.R" - "tests/testthat/test-agent*.R" + - "tests/testthat/test-final-models-restart.R" + - "tests/testthat/test-forecast-selection*.R" + - "tests/testthat/test-reconciled-forecast-selection.R" - "tests/testthat/test-finalize_run.R" - "tests/testthat/test-combo-normalization.R" - "tests/testthat/test-prep_models.R" @@ -27,3 +33,13 @@ paths: - Propagate every best-run blob-listing provider error, including post-write verification errors. Never reinterpret listing failures as no files, and do not add per-retry or per-worker wildcard listings to large ADLS folders. - Use `normalize_combo_values()` before validation, `Combo` construction, hierarchy processing, or artifact writes in both `set_agent_info()` and `prep_data()`. Trim character boundaries only; preserve internal spaces, missing values, and numeric identifiers. Fail before writing when normalization creates a blank value or duplicate combo/date. Do not trim generic `hash_data()` inputs. - Never send `Inf`, `-Inf`, or `NaN` in EDA summaries to an LLM. Represent absent outlier dates explicitly and omit unavailable regressor-lag rankings while preserving raw EDA artifacts. + +## Iteration Selection Policy + +- Average model accuracy is a critical search-direction signal, not redundant logging. The best individual model can stay unchanged while an input or setting change improves other models that may become the winners after further iterations. +- For example, ARIMA may remain the most accurate model after adding an external regressor (`xreg`), while the regressor improves MAPE across the multivariate models. Preserve that evidence when choosing the iteration context for continued optimization; do not discard the change solely because ARIMA did not improve. This is a useful signal, not a guarantee of future accuracy. +- Preserve the original near-best iteration-ranking rule: start from the earliest minimum-WMAPE iteration, then consider later eligible iterations within 10% relative of that WMAPE and prefer a strictly lower `model_avg_wmape`. Do not replace this with strict minimum-WMAPE-only ranking. Keep the existing current-version eligibility and distinct best-forecast persistence safeguards. +- `model_avg_wmape` is the mean of the individual model candidates' WMAPEs, not the WMAPE of an averaged forecast. Preserve the existing local/global meanings of `model_avg_wmape`, `model_median_wmape`, and `model_std_wmape`. Do not replace genuine model-pool statistics with copies of the winning model's WMAPE or a fabricated zero spread. +- Future-plausibility checks select models within each iteration. Avoiding repeated future-quality assessments across iterations must not remove these existing backtest-accuracy signals. Reuse available predictions and recorded metrics without introducing repeated artifact discovery or rereading past forecasts. +- All globally selected series must reference one winning global iteration so forecast updates reuse one global run. Promote global winners as one run-level decision, not per-series improvements across iterations. Preserve superior local winners and allow different model IDs or component subsets within that one global iteration. Reject mixed saved global iteration metadata before publication or update, including after interrupted writes; never silently split it into several global updates. +- Changes to this heuristic, its tolerance, metric meanings, rounding, or run-level versus per-series publishing rules require separate explicit user approval. Tests and documentation must protect the intended policy, not silently redefine it to match a refactor. diff --git a/.cursor/rules/agent-runtime.mdc b/.cursor/rules/agent-runtime.mdc index b627a6c9..c6e7614b 100644 --- a/.cursor/rules/agent-runtime.mdc +++ b/.cursor/rules/agent-runtime.mdc @@ -1,6 +1,6 @@ --- description: "Use when working on FinnTS agent runtime rules." -globs: "R/agent_*.R,R/run_info.R,R/input_checks.R,R/prep_data.R,R/prep_models.R,R/read_write_data.R,tests/testthat/test-agent*.R,tests/testthat/test-finalize_run.R,tests/testthat/test-combo-normalization.R,tests/testthat/test-prep_models.R" +globs: "R/agent_*.R,R/final_models.R,R/forecast_selection.R,R/run_info.R,R/input_checks.R,R/prep_data.R,R/prep_models.R,R/read_write_data.R,tests/testthat/helper-forecast-selection.R,tests/testthat/test-agent*.R,tests/testthat/test-final-models-restart.R,tests/testthat/test-forecast-selection*.R,tests/testthat/test-reconciled-forecast-selection.R,tests/testthat/test-finalize_run.R,tests/testthat/test-combo-normalization.R,tests/testthat/test-prep_models.R" alwaysApply: false --- diff --git a/.github/instructions/agent-runtime.instructions.md b/.github/instructions/agent-runtime.instructions.md index 938d3a8a..1add5483 100644 --- a/.github/instructions/agent-runtime.instructions.md +++ b/.github/instructions/agent-runtime.instructions.md @@ -1,5 +1,5 @@ --- -applyTo: "R/agent_*.R,R/run_info.R,R/input_checks.R,R/prep_data.R,R/prep_models.R,R/read_write_data.R,tests/testthat/test-agent*.R,tests/testthat/test-finalize_run.R,tests/testthat/test-combo-normalization.R,tests/testthat/test-prep_models.R" +applyTo: "R/agent_*.R,R/final_models.R,R/forecast_selection.R,R/run_info.R,R/input_checks.R,R/prep_data.R,R/prep_models.R,R/read_write_data.R,tests/testthat/helper-forecast-selection.R,tests/testthat/test-agent*.R,tests/testthat/test-final-models-restart.R,tests/testthat/test-forecast-selection*.R,tests/testthat/test-reconciled-forecast-selection.R,tests/testthat/test-finalize_run.R,tests/testthat/test-combo-normalization.R,tests/testthat/test-prep_models.R" --- # Agent Runtime Rules diff --git a/AGENTS.md b/AGENTS.md index 88196f70..1a93a880 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -16,7 +16,7 @@ Detailed rules load conditionally from `.claude/rules/`, a format shared by Clau - `.claude/rules/r-package.md` for R source, package metadata, roxygen, vignettes, and release notes. - `.claude/rules/testing.md` for tests, CRAN profiles, credentials, runtime budgets, and PSOCK behavior. -- `.claude/rules/agent-runtime.md` for Agent graphs, LLM sessions, reasoning retries, history, artifacts, combo identity, and EDA prompts. +- `.claude/rules/agent-runtime.md` for Agent graphs, iteration selection and its accuracy signals, LLM sessions, reasoning retries, history, artifacts, combo identity, and EDA prompts. - `.claude/rules/multistep.md` for multistep adapters, lag generation, routing, and prediction. - `.claude/rules/optional-dependencies.md` for feature selection, TimeGPT, and optional package boundaries. @@ -75,6 +75,7 @@ Keep edits focused. Do not refactor unrelated code, change public APIs without a ## Safety And Quality - Never commit secrets, tokens, local paths, or machine-specific configuration. +- Preserve established forecasting decision policies unless the user explicitly approves changing them. In particular, protect the Agent's average-model accuracy signal for iteration selection; its rationale and rules are in [.claude/rules/agent-runtime.md](.claude/rules/agent-runtime.md#iteration-selection-policy). Logging or performance work is not permission to simplify those decisions. - Prefer existing dependencies and established package patterns. New dependencies require a concrete feature need and explicit justification. - Do not weaken or delete tests to hide a failure; fix the underlying behavior. - Do not create code or functions that delete files. diff --git a/DESCRIPTION b/DESCRIPTION index 57b9b6d5..4be48bd5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: finnts Title: Microsoft Finance Time Series Forecasting Framework -Version: 0.7.0.9005 +Version: 0.7.0.9006 Authors@R: c(person(given = "Mike", family = "Tokic", diff --git a/NEWS.md b/NEWS.md index 42f29c28..689c7a99 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,8 @@ -# finnts 0.7.0.9005 (DEVELOPMENT VERSION) +# finnts 0.7.0.9006 (DEVELOPMENT VERSION) + +## Improvements + +- Improved model selection to balance backtest accuracy with forecast plausibility, preserve supported growth and seasonal patterns, and reject invalid predictions, with more reliable averaging, forecast updates, and run recovery. ## Bug Fixes diff --git a/R/agent_iterate_forecast.R b/R/agent_iterate_forecast.R index 15d09aff..c74f82da 100644 --- a/R/agent_iterate_forecast.R +++ b/R/agent_iterate_forecast.R @@ -103,6 +103,32 @@ resolve_agent_global_forecast_approaches <- function(agent_info, eda_results) { #' #' This function orchestrates the forecast iteration process for a Finn agent, including exploratory data analysis, #' +#' @details Future quality is evaluated when [final_models()] selects the winner +#' within each iteration. Iteration ranking starts from the earliest minimum +#' WMAPE and may prefer a later eligible iteration within 10 percent relative +#' WMAPE when its average model WMAPE is strictly lower. Local mean, median, and +#' standard deviation summarize individual-model backtests, excluding simple +#' averages. This retains evidence that a setting improves other models even if +#' the current best model does not improve. Global summary fields retain their +#' original meaning: run WMAPE for mean and median, and zero standard deviation. +#' Agent comparisons and stopping use WMAPE rounded to four decimal places. +#' Search-context selection does not overwrite a better saved local forecast. +#' Global promotion applies to one complete iteration, and all saved global +#' winners must reference that same iteration. Individual models and averages +#' may differ within it. Mixed global iteration metadata is rejected before +#' publication or update; interrupted writes are not treated as successful. +#' Normal accuracy-goal stopping requires a complete eligible result and finite WMAPE, not another +#' soft-quality check. A winner with soft concerns may therefore beat an earlier +#' winner on accuracy. Loaded backtests, run history, and best-run metrics are reused without +#' re-evaluating past future paths. Rejected evaluations still consume iteration +#' budget without repeating the same fit as an infrastructure retry. If no +#' eligible result exists, the workflow fails or an enabled local phase handles +#' unresolved global series. Rankings are kept in memory, not new files. +#' Hierarchical accuracy uses reconciled backtests; later comparisons and +#' reconciliation do not require retained source-node quality rankings. Final +#' reconciliation publishes the selected mixture without future-quality scoring, +#' whole-set fallback, or extra refitting. +#' #' @param agent_info Agent info from `set_agent_info()` #' @param max_iter Maximum number of iterations for forecast optimization. #' @param weighted_mape_goal Weighted MAPE goal the agent is trying to achieve for each time series @@ -230,6 +256,9 @@ iterate_forecast <- function(agent_info, dplyr::pull(Combo) %>% unique() + agent_info$selection_combos <- combo_list + agent_info$selection_cache <- new.env(parent = emptyenv()) + best_run_tbl <- load_best_agent_run(agent_info = agent_info) global_models_ran <- FALSE @@ -325,7 +354,7 @@ iterate_forecast <- function(agent_info, # filter combos that need local model optimization local_combo_list <- best_run_tbl %>% - dplyr::filter(weighted_mape > weighted_mape_goal) %>% + dplyr::filter(!is.finite(weighted_mape) | weighted_mape > weighted_mape_goal) %>% dplyr::filter(run_complete == FALSE | max_iterations < max_iter) %>% dplyr::pull(combo) %>% unique() @@ -470,6 +499,17 @@ iterate_forecast <- function(agent_info, #' #' This function retrieves the final forecast for a Finn agent after the forecast iteration process is complete. #' +#' @details For hierarchical Agent runs, returns only the final reconciled +#' `Best-Model` forecast. Each series can run and select different models, +#' recipes, or averages during [iterate_forecast()], so the selected forecasts +#' are reconciled together rather than producing a comparison hierarchy for +#' every model. `Best-Model` does not mean the same model family won for every +#' series. This best-only reconciled output contract also applies after +#' [update_forecast()]. It does not change non-hierarchical candidate output. +#' +#' For non-agentic hierarchical runs, [get_forecast_data()] returns all +#' successfully saved per-model reconciled forecasts plus `Best-Model`. +#' #' @param agent_info Agent info from `set_agent_info()` #' #' @return A tibble containing the final forecast for the agent. @@ -666,7 +706,10 @@ load_agent_forecast <- function(agent_info, project_info <- agent_info$project_info project_info$run_name <- agent_info$run_id - fcst_tbl <- read_file( + fcst_tbl <- if (inherits(project_info$storage_object, c("blob_container", "ms_drive"))) { + read_exact_artifact(project_info, + local_artifact_path(project_info, "forecasts", "-reconciled", hash_data("Best-Model"))) + } else read_file( run_info = project_info, path = paste0( "/forecasts/", hash_data(project_info$project_name), "-", hash_data(project_info$run_name), @@ -686,27 +729,13 @@ load_agent_forecast <- function(agent_info, # load global model forecasts if ("global" %in% model_type_list) { - global_combos <- best_run_tbl %>% - dplyr::filter(model_type == "global") %>% - dplyr::pull(combo) %>% - unique() - - global_run_name <- best_run_tbl %>% - dplyr::filter(model_type == "global") %>% - dplyr::pull(best_run_name) %>% - unique() - - run_info <- agent_info$project_info - run_info$project_name <- paste0( - agent_info$project_info$project_name, - "_", - hash_data("all") - ) - run_info$run_name <- global_run_name - - global_fcst_tbl <- get_forecast_data(run_info = run_info) %>% - dplyr::filter(Combo %in% global_combos) %>% - dplyr::mutate(Date = as.Date(Date)) + global_runs <- best_run_tbl[best_run_tbl$model_type == "global", , drop = FALSE] + global_fcst_tbl <- dplyr::bind_rows(lapply(split(global_runs, global_runs$best_run_name), function(selected_runs) { + run_info <- agent_info$project_info + run_info$project_name <- paste0(agent_info$project_info$project_name, "_", hash_data("all")) + run_info$run_name <- selected_runs$best_run_name[1] + read_selected_agent_forecasts(run_info, selected_runs$combo, agent_info$project_info$combo_variables) + })) } else { global_fcst_tbl <- tibble::tibble() } @@ -717,7 +746,7 @@ load_agent_forecast <- function(agent_info, dplyr::filter(model_type == "local") # submit tasks - local_file_tbl <- foreach::foreach( + local_fcst_tbl <- foreach::foreach( x = local_run_tbl %>% dplyr::group_split(dplyr::row_number(), .keep = FALSE), .combine = "rbind", @@ -742,41 +771,26 @@ load_agent_forecast <- function(agent_info, multiple_models <- grepl("---", x$models_to_run) average_models <- x$average_models - # create file list - # single models - file_list <- paste0( - project_info$path, "/forecasts/", hash_data(project_name), "-", - hash_data(run_name), "-", hash_data(x$combo), - "-single_models.", project_info$data_output - ) %>% fs::path_tidy() + run_info <- project_info + run_info$project_name <- project_name + run_info$run_name <- run_name + forecasts <- read_selection_file(run_info, "forecasts", "-single_models", x$combo) if ((multiple_models | multiple_recipes) & average_models) { - # add average model file if multiple models were run and averaging was selected - file_list <- c( - file_list, - paste0( - project_info$path, "/forecasts/", hash_data(project_name), "-", - hash_data(run_name), "-", hash_data(x$combo), - "-average_models.", project_info$data_output - ) %>% fs::path_tidy() + forecasts <- dplyr::bind_rows(forecasts, + read_selection_file(run_info, "forecasts", "-average_models", x$combo, optional = TRUE) ) } - return(tibble::tibble(File_List = file_list)) + return(forecasts) } %>% base::suppressPackageStartupMessages() # load local forecast files - if (nrow(local_file_tbl) == 0) { + if (nrow(local_fcst_tbl) == 0) { stop("Error in load_agent_forecast(). No local forecast files found for agent.", call. = FALSE) } - local_fcst_tbl <- read_file( - run_info = agent_info$project_info, - file_list = local_file_tbl$File_List, - return_type = "df" - ) - # get train test split data local_run_example <- local_run_tbl %>% dplyr::slice(1) @@ -787,9 +801,9 @@ load_agent_forecast <- function(agent_info, hash_data(local_run_example$combo) ) - model_train_test_tbl <- read_file(agent_info$project_info, - path = paste0( - "/prep_models/", hash_data(local_project_name), "-", hash_data(local_run_example$best_run_name), + model_train_test_tbl <- read_exact_artifact(agent_info$project_info, + file_list = paste0( + agent_info$project_info$path, "/prep_models/", hash_data(local_project_name), "-", hash_data(local_run_example$best_run_name), "-train_test_split.", agent_info$project_info$data_output ), return_type = "df" @@ -894,7 +908,7 @@ load_best_agent_run <- function(agent_info) { project_info$storage_object, paste0( project_info$path, "/logs/*", hash_data(project_info$project_name), "-", - hash_data(agent_info$run_id), "*-agent_best_run.", project_info$data_output + hash_data(agent_info$run_id), "*-agent_best_run.csv" ), fail_on_error = TRUE ) @@ -902,13 +916,17 @@ load_best_agent_run <- function(agent_info) { if (length(combo_best_run_list) == 0) { best_run_tbl <- tibble::tibble() } else { - best_run_tbl <- read_file( + if (inherits(project_info$storage_object, "ms_drive")) { + combo_best_run_list <- fs::path(project_info$path, "logs", fs::path_file(combo_best_run_list)) + } + best_run_tbl <- read_exact_artifact( run_info = project_info, file_list = combo_best_run_list, return_type = "df" ) } + validate_global_iteration(best_run_tbl) return(best_run_tbl) } @@ -1003,6 +1021,8 @@ fcst_agent_workflow <- function(agent_info, previous_run_results = NULL, fallback_available = FALSE, eda_results = NULL) { + agent_info$allow_quality_rejection <- TRUE + if (is.null(agent_info$selection_cache)) agent_info$selection_cache <- new.env(parent = emptyenv()) agent_info$global_forecast_approaches <- if (is.null(combo)) { resolve_agent_global_forecast_approaches(agent_info, eda_results) } else { @@ -1101,7 +1121,8 @@ fcst_agent_workflow <- function(agent_info, agent_info = agent_info, run_info = "{results$submit_fcst_run}", weighted_mape = "{results$calculate_fcst_metrics}", - combo = combo + combo = combo, + run_history = "{ctx$reason_history$previous_run_results}" ), branch = function(ctx) { # test if max run iterations have been reached @@ -1115,11 +1136,22 @@ fcst_agent_workflow <- function(agent_info, # check if the weighted MAPE is below the goal weighted_mape <- ctx$results$calculate_fcst_metrics - if (weighted_mape < weighted_mape_goal) { + selection_ok <- attr(weighted_mape, "selection_ok") + if (is.null(selection_ok)) selection_ok <- TRUE + logged <- ctx$results$log_best_run + if (is.list(logged) && isTRUE(logged$status %in% c("partial", "rejected"))) { + selection_ok <- FALSE + } + if (is.finite(weighted_mape) && weighted_mape < weighted_mape_goal && isTRUE(selection_ok)) { cli::cli_alert_success( "Weighted MAPE goal of {round(weighted_mape_goal * 100, 2)}% achieved! Latest weighted MAPE is {round(weighted_mape * 100, 2)}%. Stopping iterations." ) wmape_goal_reached <- TRUE + } else if (!isTRUE(selection_ok)) { + cli::cli_alert_info( + "Incomplete or rejected forecasts cannot meet the accuracy goal. {if (max_runs_reached) 'Iteration limit reached.' else 'Continuing to the next iteration.'}" + ) + wmape_goal_reached <- FALSE } else if (max_runs_reached) { cli::cli_alert_info( "Weighted MAPE of {round(weighted_mape * 100, 2)}% is above the goal of {round(weighted_mape_goal * 100, 2)}%. Stopping iterations as max runs is reached." @@ -1135,6 +1167,10 @@ fcst_agent_workflow <- function(agent_info, # determine next node based on conditions if (wmape_goal_reached || max_runs_reached) { next_node <- "finalize_run" + if (!isTRUE(selection_ok)) { + ctx$completion_reason <- "quality_rejected" + ctx$abort_reason <- "No complete eligible forecast was available before the iteration limit." + } } else { next_node <- "refresh_reason_history" } @@ -1758,6 +1794,8 @@ reason_inputs <- function(agent_info, best_run <- previous_run_results %>% dplyr::filter(best_run == "yes") %>% dplyr::pull(run_number) + if (!length(best_mape)) best_mape <- "NA" + if (!length(best_run)) best_run <- "NA" lag_changes_allowed <- count_agent_setting_changes( previous_run_results$lag_periods, @@ -2152,6 +2190,22 @@ submit_fcst_run <- function(agent_info, # adjust to prevent unnecessary list_files() calls in spark run_info$combo <- combo_value } + run_info$allow_quality_rejection <- isTRUE(agent_info$allow_quality_rejection) || isTRUE(agent_info$default_reforecast) + if (isTRUE(agent_info$default_reforecast)) { + default_log <- read_selection_file(run_info, "logs") + if (identical(as.character(default_log[["default_reforecast_status"]]), "rejected")) { + rlang::abort("The default replacement was already rejected and cannot be fitted again.", + class = "finnts_forecast_selection_rejected", combo = unique(as.character(input_data$Combo))) + } + if (identical(as.character(default_log[["default_reforecast_status"]]), "accepted")) { + restored <- assess_agent_run(run_info, default_log, unique(as.character(input_data$Combo))) + run_info$forecast_selection <- restored[c("selections", "source_selections", "rejected_combos")] + run_info$forecast_selection$quality_accepted <- TRUE + run_info$selection_combos <- names(restored$selections) + validate_run_outputs(run_info, combo) + return(run_info) + } + } # clean and prepare data for training prep_data( @@ -2220,7 +2274,7 @@ submit_fcst_run <- function(agent_info, } # evaluate models - final_models( + selection_result <- tryCatch(final_models( run_info = run_info, average_models = TRUE, max_model_average = 3, @@ -2228,7 +2282,38 @@ submit_fcst_run <- function(agent_info, parallel_processing = final_parallel, inner_parallel = inner_parallel, num_cores = num_cores - ) + ), finnts_forecast_selection_rejected = function(error) { + if (!isTRUE(run_info$allow_quality_rejection)) stop(error) + rejected_agent_selection(unique(as.character(input_data$Combo)), conditionMessage(error)) + }) + run_info$forecast_selection <- selection_result + run_info$selection_combos <- names(selection_result$selections) + if (!length(run_info$selection_combos)) { + combos <- unique(as.character(input_data$Combo)) + log <- read_selection_file(run_info, "logs") + evaluated <- assess_agent_run(run_info, log, combos, + agent_info$selection_cache %||% new.env(parent = emptyenv()), + check_quality = isTRUE(agent_info$default_reforecast)) + run_info$forecast_selection <- evaluated[c("selections", "source_selections", "rejected_combos")] + run_info$selection_combos <- combos + } + if (isTRUE(agent_info$default_reforecast)) { + default_log <- read_selection_file(run_info, "logs") + quality_missing <- vapply(run_info$forecast_selection$selections, function(selection) { + if (is.null(selection) || is.na(selection$selected_id)) return(FALSE) + score <- selection$rankings$Violations[match(selection$selected_id, selection$rankings$Model_ID)] + length(score) != 1 || is.na(score) + }, logical(1)) + if (any(quality_missing) && !isTRUE(run_info$forecast_selection$quality_accepted)) { + evaluated <- assess_agent_run(run_info, default_log, run_info$selection_combos, check_quality = TRUE) + run_info$forecast_selection <- evaluated[c("selections", "source_selections", "rejected_combos")] + } + default_log$default_reforecast_status <- if (agent_selection_summary(run_info$forecast_selection, check_quality = TRUE)$acceptable) { + "accepted" + } else "rejected" + write_data(default_log, combo = NULL, run_info = run_info, output_type = "log", + folder = "logs", suffix = NULL) + } # validate that all outputs can be loaded before proceeding validate_run_outputs( @@ -2264,15 +2349,18 @@ validate_run_outputs <- function(run_info, combo = NULL) { # validate forecast data fcst_tbl <- tryCatch( - load_combo_forecast( - combo = forecast_combo, - run_info = run_info - ), + if (isTRUE(run_info$forecast_selection$unpublished)) { + NULL + } else if (!is.null(run_info$forecast_selection) && length(run_info$forecast_selection$rejected_combos)) { + read_candidate_forecasts(run_info, run_info$selection_combos) + } else { + load_combo_forecast(combo = forecast_combo, run_info = run_info) + }, error = function(e) NULL ) %>% base::suppressWarnings() - if (is.null(fcst_tbl) || nrow(fcst_tbl) == 0) { + if (!isTRUE(run_info$forecast_selection$unpublished) && (is.null(fcst_tbl) || nrow(fcst_tbl) == 0)) { stop( "Failed to load forecast data for run '", run_info$run_name, "' (combo: ", forecast_combo, "). ", @@ -2354,7 +2442,15 @@ validate_run_outputs <- function(run_info, combo = NULL) { #' @return A tibble containing the forecast output. #' @noRd get_fcst_output <- function(run_info) { - fcst_tbl <- get_forecast_data(run_info) + fcst_tbl <- if (isTRUE(run_info$forecast_selection$unpublished)) { + tibble::tibble() + } else if (!is.null(run_info$forecast_selection) && length(run_info$forecast_selection$rejected_combos)) { + rows <- read_candidate_forecasts(run_info, run_info$selection_combos) + splits <- read_selection_file(run_info, "prep_models", "-train_test_split") + dplyr::left_join(rows, splits[, c("Train_Test_ID", "Run_Type")], by = "Train_Test_ID") + } else { + get_forecast_data(run_info) + } return(fcst_tbl) } @@ -2363,11 +2459,29 @@ get_fcst_output <- function(run_info) { #' #' @param run_info A list containing run information including project name, run name, storage object, path, data output, and object output. #' @param fcst_tbl A tibble containing the forecast output. +#' @param aggregate_wmape Optional native aggregate for update logging; per-series and model-pool metrics still use the forecast output. #' #' @return A numeric value representing the weighted MAPE of the forecast. #' @noRd calculate_fcst_metrics <- function(run_info, - fcst_tbl) { + fcst_tbl, + aggregate_wmape = NULL) { + if (!is.null(run_info$forecast_selection) && length(run_info$forecast_selection$selections)) { + summary <- agent_selection_summary(run_info$forecast_selection) + accuracy <- agent_forecast_accuracy(fcst_tbl, names(run_info$forecast_selection$selections)) + if (!is.null(aggregate_wmape)) { + if (!is.numeric(aggregate_wmape) || length(aggregate_wmape) != 1L || + !is.finite(aggregate_wmape) || aggregate_wmape < 0) { + stop("The update aggregate WMAPE must be a single finite non-negative number.", call. = FALSE) + } + if (is.finite(accuracy$weighted_mape)) accuracy$weighted_mape <- round(aggregate_wmape, 4) + } + value <- if (isTRUE(summary$acceptable)) accuracy$weighted_mape else Inf + attr(value, "selection_ok") <- isTRUE(summary$acceptable) && is.finite(value) + attr(value, "forecast_accuracy") <- accuracy + attr(value, "model_accuracy") <- agent_model_accuracy(fcst_tbl) + return(value) + } # get weighted mape from run logging run_log_df <- read_file(run_info, path = paste0("logs/", hash_data(run_info$project_name), "-", hash_data(run_info$run_name), ".csv"), @@ -2390,6 +2504,7 @@ calculate_fcst_metrics <- function(run_info, #' @param weighted_mape A numeric value representing the weighted MAPE of the forecast. #' @param combo A character string representing the combo to use for the run. If NULL, all combos are used. #' @param check_best_run Logical indicating if the best run check should be performed. Default is TRUE +#' @param run_history Existing in-memory iteration history, when available. #' #' @return NULL #' @noRd @@ -2397,7 +2512,11 @@ log_best_run <- function(agent_info, run_info, weighted_mape, combo = NULL, - check_best_run = TRUE) { + check_best_run = TRUE, + run_history = NULL) { + if (!is.null(run_info$forecast_selection)) { + return(log_selected_agent_run(agent_info, run_info, combo, check_best_run, weighted_mape, run_history)) + } # metadata project_info <- agent_info$project_info project_info$run_name <- agent_info$run_id @@ -2656,6 +2775,129 @@ log_best_run <- function(agent_info, return("Run logged successfully.") } +log_selected_agent_run <- function(agent_info, run_info, combo = NULL, check_best_run = TRUE, + weighted_mape = NULL, run_history = NULL) { + current_log <- read_selection_file(run_info, "logs") + current_result <- list(selections = run_info$forecast_selection$selections, + run_info = run_info, run_log = current_log) + global <- isTRUE(as.logical(current_log$run_global_models)) + if (global) { + expected <- if (check_best_run) { + agent_info$selection_combos %||% run_info$selection_combos + } else run_info$selection_combos + missing <- setdiff(expected, names(current_result$selections)) + current_result$selections[missing] <- rep(list(NULL), length(missing)) + } + summary <- agent_selection_summary(current_result) + forecast_accuracy <- attr(weighted_mape, "forecast_accuracy", exact = TRUE) + current_log <- record_agent_selection_attempt(current_log, current_result, agent_info, + attr(weighted_mape, "model_accuracy", exact = TRUE), forecast_accuracy) + promote_run <- TRUE + if (check_best_run && is.data.frame(run_history)) { + history <- attr(run_history, "run_logs", exact = TRUE) %||% run_history + if ("run_name" %in% names(history)) { + history <- history[is.na(history$run_name) | history$run_name != run_info$run_name, , drop = FALSE] + } + comparison <- dplyr::bind_rows(lapply(list(history, current_log), function(log) { + columns <- intersect(c("weighted_mape", "model_avg_wmape", "agent_version", "selection_status"), names(log)) + rows <- log[, columns, drop = FALSE] + for (column in intersect(c("weighted_mape", "model_avg_wmape", "agent_version"), columns)) { + rows[[column]] <- as.numeric(rows[[column]]) + } + if ("selection_status" %in% columns) rows$selection_status <- as.character(rows$selection_status) + rows + })) + promote_run <- identical(best_agent_iteration(comparison, agent_info$agent_version), as.integer(nrow(comparison))) + } + project_info <- agent_info$project_info + project_info$run_name <- agent_info$run_id + previous_by_series <- NULL + promote_global <- isTRUE(summary$acceptable) && is.finite(current_log$weighted_mape) && promote_run + if (global && check_best_run) { + previous_by_series <- stats::setNames(lapply(names(current_result$selections), function(series) { + read_selection_file(project_info, "logs", "-agent_best_run", series, optional = TRUE) + }), names(current_result$selections)) + previous_global <- dplyr::bind_rows(previous_by_series) + if (nrow(previous_global)) { + previous_global <- previous_global[ + !is.na(previous_global$model_type) & previous_global$model_type == "global" & + !is.na(previous_global$agent_version) & + as.numeric(previous_global$agent_version) == as.numeric(agent_info$agent_version), , drop = FALSE] + } + if (nrow(previous_global)) { + validate_global_iteration(previous_global) + previous_accuracy <- unique(as.numeric(previous_global$model_avg_wmape)) + if (length(previous_accuracy) != 1L || !is.finite(previous_accuracy)) { + stop("Saved global iteration metadata is inconsistent. Restore one complete global best run before continuing.", + call. = FALSE) + } + if (!is.data.frame(run_history)) { + comparison <- data.frame(weighted_mape = c(previous_accuracy, current_log$weighted_mape), + model_avg_wmape = c(previous_accuracy, current_log$weighted_mape)) + promote_global <- promote_global && identical(best_agent_iteration(comparison), 2L) + } + } + } + written <- character() + retained <- character() + for (series in names(current_result$selections)) { + selected <- current_result$selections[[series]] + if (is.null(selected) || is.na(selected$selected_id)) next + score <- selected$rankings[selected$rankings$Model_ID == selected$selected_id, , drop = FALSE] + if (nrow(score) != 1 || !isTRUE(score$Eligible) || !is.finite(score$WMAPE)) next + if (!is.null(forecast_accuracy)) { + completed_wmape <- unname(forecast_accuracy$by_series[series]) + if (length(completed_wmape) != 1L || !is.finite(completed_wmape)) next + score$WMAPE <- completed_wmape + } + score$WMAPE <- round(score$WMAPE, 4) + if (global && !promote_global) { + if (!is.null(previous_by_series) && nrow(previous_by_series[[series]]) > 0L) retained <- c(retained, series) + next + } + if (check_best_run) { + previous <- if (global) previous_by_series[[series]] else + read_selection_file(project_info, "logs", "-agent_best_run", series, optional = TRUE) + if (nrow(previous) > 1) stop("The saved best-run record is ambiguous for series: ", series, call. = FALSE) + if (!promote_run) { + if (nrow(previous)) retained <- c(retained, series) + next + } + same_version <- nrow(previous) == 1 && + isTRUE(as.numeric(previous$agent_version) == as.numeric(agent_info$agent_version)) + protect_individual <- !global || !identical(as.character(previous$model_type), "global") + if (same_version && protect_individual && isTRUE(is.finite(as.numeric(previous$weighted_mape))) && + isTRUE(as.numeric(previous$weighted_mape) <= score$WMAPE)) { + retained <- c(retained, series) + next + } + } + log <- current_log + best_log <- log[, setdiff(names(log), c("project_name", "path", "data_output", "object_output", "weighted_mape")), drop = FALSE] + best_log$best_run_name <- run_info$run_name + best_log$project_name <- project_info$project_name + best_log$agent_run_id <- agent_info$run_id + best_log$model_type <- if (isTRUE(as.logical(log$run_global_models))) "global" else "local" + best_log$combo <- series + best_log$weighted_mape <- score$WMAPE + best_log$max_iterations <- 0 + best_log$run_complete <- FALSE + write_data(best_log, combo = series, run_info = project_info, output_type = "log", + folder = "logs", suffix = "-agent_best_run") + written <- c(written, series) + } + for (series in written) { + saved <- read_selection_file(project_info, "logs", "-agent_best_run", series) + if (nrow(saved) != 1L || !identical(as.character(saved$best_run_name), run_info$run_name) || + !identical(as.character(saved$combo), series) || + !isTRUE(as.numeric(saved$agent_version) == as.numeric(agent_info$agent_version))) { + stop("Saved best-run record does not match the selected iteration for series: ", series, call. = FALSE) + } + } + write_data(current_log, combo = NULL, run_info = run_info, output_type = "log", folder = "logs", suffix = NULL) + list(status = current_log$selection_status, selected_combos = c(retained, written)) +} + #' Finalize Agent Run Metadata #' #' This function updates the agent best run file for each combo by setting @@ -2722,7 +2964,7 @@ finalize_run <- function(agent_info, best_run_tbl_all <- load_best_agent_run(agent_info = agent_info) if (nrow(best_run_tbl_all) == 0) { - if (identical(completion_reason, "reasoning_exhausted") && isTRUE(fallback_available)) { + if (completion_reason %in% c("reasoning_exhausted", "quality_rejected") && isTRUE(fallback_available)) { return(list( status = "skipped", reason = abort_reason, @@ -2741,7 +2983,7 @@ finalize_run <- function(agent_info, unique() if (length(combo_list) == 0) { # when global models have been run but local models are always better - if (identical(completion_reason, "reasoning_exhausted") && isTRUE(fallback_available)) { + if (completion_reason %in% c("reasoning_exhausted", "quality_rejected") && isTRUE(fallback_available)) { return(list( status = "skipped", reason = abort_reason, @@ -2843,6 +3085,7 @@ load_run_results <- function(agent_info, storage_object = agent_info$project_info$storage_object, path = agent_info$project_info$path ) + if (!"selection_status" %in% names(previous_runs)) previous_runs$selection_status <- NA_character_ # columns that must remain numeric for downstream arithmetic numeric_cols <- c( @@ -2896,8 +3139,8 @@ load_run_results <- function(agent_info, previous_runs_formatted <- previous_runs %>% dplyr::filter(stringr::str_detect(run_name, pattern)) %>% dplyr::mutate(created = lubridate::ymd_hms(created, tz = "UTC")) %>% - dplyr::arrange(created) %>% - dplyr::filter(!is.na(weighted_mape)) %>% + dplyr::arrange(created, run_name) %>% + dplyr::filter(!is.na(weighted_mape) | .data$selection_status %in% c("rejected", "partial")) %>% dplyr::filter(!is.na(agent_version)) %>% dplyr::filter(agent_forecast_approach == agent_info$forecast_approach) %>% dplyr::mutate(agent_run_id = stringr::str_extract(run_name, "agent_([^_]+)")) %>% @@ -2907,55 +3150,15 @@ load_run_results <- function(agent_info, dplyr::ungroup() %>% dplyr::relocate(agent_version, run_number, weighted_mape) - # earliest row with *global* minimum weighted_mape for latest agent version - earliest_min <- previous_runs_formatted %>% - dplyr::filter(agent_version == max(agent_version)) %>% - dplyr::filter(weighted_mape == min(weighted_mape)) %>% # all global-mins - dplyr::slice(1) %>% # earliest one - suppressWarnings() - - best_idx <- earliest_min$run_number - best_wmape <- as.numeric(earliest_min$weighted_mape) - best_model <- as.numeric(earliest_min$model_avg_wmape) - - # look **after** that for runs whose weighted_mape is within +-10 % - # of the initial best and pick the *lowest* model_avg_wmape overall - if ("model_avg_wmape" %in% names(previous_runs_formatted)) { - if (nrow(previous_runs_formatted) > 1 && !is.na(best_wmape) && is.finite(best_wmape)) { - cand <- previous_runs_formatted %>% - dplyr::filter( - run_number > best_idx, # later runs only - abs(weighted_mape - best_wmape) <= best_wmape * 0.10 # within +-10 % - ) - - if (nrow(cand)) { - cand <- cand %>% - dplyr::filter(model_avg_wmape == min(model_avg_wmape)) %>% # lowest avg - dplyr::slice(1) # earliest tie - if (cand$model_avg_wmape < best_model) { # strictly better than current - best_idx <- cand$run_number - } - } - } - } - - # flag the chosen best run - previous_runs_formatted <- previous_runs_formatted %>% - dplyr::mutate( - best_run = dplyr::if_else(run_number == best_idx, "yes", "no") - ) - - if (nrow(previous_runs_formatted) == 0) { - run_output <- "No Previous Runs" - } else if ("model_avg_wmape" %in% names(previous_runs_formatted)) { - run_output <- previous_runs_formatted %>% - dplyr::select(tidyselect::all_of(c(column_list, "model_avg_wmape", "model_median_wmape", "model_std_wmape"))) %>% - dplyr::relocate(agent_version, run_number, best_run, weighted_mape, model_avg_wmape, model_median_wmape, model_std_wmape) - } else { - run_output <- previous_runs_formatted %>% - dplyr::select(tidyselect::all_of(column_list)) %>% - dplyr::relocate(agent_version, run_number, best_run, weighted_mape) - } + if (nrow(previous_runs_formatted) == 0) return("No Previous Runs") + current_version <- agent_info$agent_version %||% max(previous_runs_formatted$agent_version) + previous_runs_formatted$best_run <- "no" + winner <- best_agent_iteration(previous_runs_formatted, current_version) + if (!is.na(winner)) previous_runs_formatted$best_run[winner] <- "yes" + run_output <- previous_runs_formatted %>% + dplyr::select(tidyselect::any_of(c(column_list, "selection_status", "model_avg_wmape", "model_median_wmape", "model_std_wmape"))) %>% + dplyr::relocate(agent_version, run_number, best_run, weighted_mape) + attr(run_output, "run_logs") <- previous_runs_formatted } else { run_output <- "No Previous Runs" } diff --git a/R/agent_run.R b/R/agent_run.R index fa018dab..d55d4ed0 100644 --- a/R/agent_run.R +++ b/R/agent_run.R @@ -184,6 +184,9 @@ execute_node <- function(node, ctx, chat) { ctx$attempts[[tool_name]] <- 0L return(list(ctx = ctx, ok = TRUE)) } + if (inherits(err, "finnts_forecast_selection_rejected")) { + stop(err) + } # pause before retrying wait_before_retry() diff --git a/R/agent_update_forecast.R b/R/agent_update_forecast.R index 4f5f9133..11125c54 100644 --- a/R/agent_update_forecast.R +++ b/R/agent_update_forecast.R @@ -14,6 +14,34 @@ #' directing the user to use `iterate_forecast()` instead. #' #' @param agent_info Agent info from `set_agent_info()` +#' @details Reused forecasts are checked against original-scale prepared actuals +#' after refitting and retuning. Quality-rejected series receive one default +#' reforecast through the same path as new series, without LLM quality judgments. +#' Quality-only rejections do not count toward the ordinary execution-failure +#' limit; existing data/provider failures retain that limit. Replacement models +#' are evaluated using [final_models()] and cannot trigger an unbounded retry. +#' Reused fits do not call `final_models()`; their components must pass hard +#' eligibility and their selected combination must pass applicable quality checks +#' before any reconciliation, including after retuning. Global updates recover +#' each series' saved winning single model or average from existing source +#' forecasts, refit the union of required components, and preserve each selected +#' subset. Requested but unselected models are not added back to the average. +#' All globally selected series must reference one winning global iteration. +#' Mixed global iteration metadata is rejected before refitting rather than +#' split into multiple global updates. Different model subsets within that +#' single iteration and separately selected local winners remain supported. +#' Missing or ambiguous saved winners or selected fits require restoring the +#' original artifacts; the requested model list is not used as a fallback. +#' These are checks on newly generated predictions, not repeated assessments of +#' past iteration winners. A reused hierarchy that +#' is incomplete or contains a rejected node is not reconciled; its covered +#' current series follow the existing default-local forecast path. Existing +#' run logs record default acceptance or rejection for restart safety. The +#' selected mixture is then reconciled without post-reconciliation future +#' evaluation, whole-set replacement, or late quality-triggered refitting. +#' Legacy second-order differenced original targets without their own starting +#' values require regeneration of prepared data from the original input. +#' #' @param weighted_mape_goal Weighted MAPE goal the agent is trying to achieve for each time series #' @param allow_iterate_forecast Logical indicating if the forecast iteration #' should be allowed if poor performance is detected, meaning >40% of @@ -222,7 +250,9 @@ update_fcst_agent_workflow <- function(agent_info, previous_best_run_tbl = "{results$initial_checks$prev_best_runs_tbl}", current_run_combos = "{results$initial_checks$current_run_combos}", global_failed_combos = "{results$update_global_models$failed_combos}", - local_failed_combos = "{results$update_local_models$failed_combos}" + local_failed_combos = "{results$update_local_models$failed_combos}", + global_quality_rejected = "{results$update_global_models$quality_rejected_combos}", + local_quality_rejected = "{results$update_local_models$quality_rejected_combos}" ) ), forecast_new_combos = list( @@ -746,13 +776,15 @@ update_global_models <- function(agent_info, if (nrow(previous_best_run_global_tbl) == 0) { cli::cli_alert_info("No global models to update, skipping...") - return(list(status = "No global models to update, skipping...", failed_combos = character(0))) + return(list(status = "No global models to update, skipping...", failed_combos = character(0), quality_rejected_combos = character(0))) } + validate_global_iteration(previous_best_run_global_tbl) + # start forecast update process global_error <- tryCatch( { - if (identical(parallel_processing, "spark") & identical(inner_parallel, TRUE)) { + update_result <- if (identical(parallel_processing, "spark") & identical(inner_parallel, TRUE)) { callr::r( function(agent_info, previous_best_run_global_tbl, parallel_processing, inner_parallel, num_cores, seed, libs) { .libPaths(libs) @@ -791,7 +823,7 @@ update_global_models <- function(agent_info, seed = seed ) } - NULL # no error + update_result }, error = function(e) { e @@ -802,7 +834,7 @@ update_global_models <- function(agent_info, try(doParallel::stopImplicitCluster(), silent = TRUE) try(foreach::registerDoSEQ(), silent = TRUE) - if (!is.null(global_error)) { + if (inherits(global_error, "condition")) { # extract individual combos that were covered by the global model failed_global_combos <- unique(previous_best_run_global_tbl$combo) failed_hashes <- vapply(failed_global_combos, hash_data, character(1), USE.NAMES = FALSE) @@ -810,10 +842,14 @@ update_global_models <- function(agent_info, "Global model update failed ({length(failed_global_combos)} combo{?s} affected). Error: {conditionMessage(global_error)}" ) cli::cli_alert_info("Failed combos will be re-forecast using default local model inputs.") - return(list(status = "Global model update failed", failed_combos = failed_hashes)) + if (inherits(global_error, "finnts_forecast_selection_rejected")) { + return(list(status = "Global forecast quality rejected", failed_combos = character(), quality_rejected_combos = failed_hashes)) + } + return(list(status = "Global model update failed", failed_combos = failed_hashes, quality_rejected_combos = character())) } - return(list(status = "Finished Global Model Update", failed_combos = character(0))) + return(list(status = "Finished Global Model Update", failed_combos = character(0), + quality_rejected_combos = if (is.list(global_error)) global_error$quality_rejected_combos %||% character() else character())) } #' Update Local Models @@ -845,7 +881,7 @@ update_local_models <- function(agent_info, if (nrow(previous_best_run_local_tbl) == 0) { cli::cli_alert_info("No local models to update, skipping...") - return(list(status = "No local models to update, skipping...", failed_combos = character(0))) + return(list(status = "No local models to update, skipping...", failed_combos = character(0), quality_rejected_combos = character())) } prev_run_id <- unique(previous_best_run_local_tbl$agent_run_id)[[1]] @@ -868,7 +904,7 @@ update_local_models <- function(agent_info, if (nrow(previous_best_run_local_tbl) == 0) { # stop if no updates required - return(list(status = "no updates required", failed_combos = character(0))) + return(list(status = "no updates required", failed_combos = character(0), quality_rejected_combos = character())) } } else { # do nothing @@ -946,7 +982,7 @@ update_local_models <- function(agent_info, ) # run update forecast for combo - update_forecast_combo( + update_result <- update_forecast_combo( agent_info = agent_info_lean, prev_best_run_tbl = prev_run, parallel_processing = NULL, @@ -955,6 +991,7 @@ update_local_models <- function(agent_info, seed = seed ) + if (is.list(update_result) && length(update_result$quality_rejected_combos)) return(update_result) return(data.frame(Combo = hash_data(combo))) } %>% base::suppressPackageStartupMessages() @@ -970,8 +1007,17 @@ update_local_models <- function(agent_info, # separate successes from failures failed_combos <- character(0) + quality_rejected_combos <- character() for (i in seq_along(combo_results)) { result <- combo_results[[i]] + if (inherits(result, "finnts_forecast_selection_rejected")) { + quality_rejected_combos <- c(quality_rejected_combos, hash_data(local_combo_list[[i]])) + next + } + if (is.list(result) && !inherits(result, "condition") && length(result$quality_rejected_combos)) { + quality_rejected_combos <- c(quality_rejected_combos, result$quality_rejected_combos) + next + } if (inherits(result, "error") || inherits(result, "simpleError") || inherits(result, "condition")) { failed_combo <- local_combo_list[[i]] failed_hash <- hash_data(failed_combo) @@ -989,7 +1035,8 @@ update_local_models <- function(agent_info, ) } - return(list(status = "Finished Local Model Update", failed_combos = failed_combos)) + return(list(status = "Finished Local Model Update", failed_combos = failed_combos, + quality_rejected_combos = unique(quality_rejected_combos))) } #' Check Update Failures @@ -1015,13 +1062,16 @@ check_update_failures <- function(agent_info, previous_best_run_tbl, current_run_combos, global_failed_combos, - local_failed_combos) { + local_failed_combos, + global_quality_rejected = character(), + local_quality_rejected = character()) { failed_combos <- intersect( unique(c(global_failed_combos, local_failed_combos)), current_run_combos ) - if (length(failed_combos) == 0) { + quality_rejected <- intersect(unique(c(global_quality_rejected, local_quality_rejected)), current_run_combos) + if (length(failed_combos) == 0 && length(quality_rejected) == 0) { return(character(0)) } @@ -1045,6 +1095,7 @@ check_update_failures <- function(agent_info, ) } + failed_combos <- unique(c(failed_combos, quality_rejected)) resolved_names <- resolve_combo_hashes(agent_info, failed_combos) cli::cli_alert_info( "{length(failed_combos)} time series failed to update and will be re-forecast using default local model inputs: {paste(resolved_names, collapse = ', ')}" @@ -1196,15 +1247,17 @@ reconcile_agent_forecast <- function(agent_info, run_name <- single_run$best_run_name + selected_run_info <- project_info + selected_run_info$project_name <- project_name + selected_run_info$run_name <- run_name train_test_file <- if (is.null(project_info$storage_object) && project_info$data_output %in% c("csv", "parquet", "rds")) { - selected_run_info <- project_info - selected_run_info$project_name <- project_name - selected_run_info$run_name <- run_name local_artifact_files( local_artifact_path(selected_run_info, "prep_models", "-train_test_split"), allow_missing = TRUE ) + } else if (inherits(project_info$storage_object, c("blob_container", "ms_drive"))) { + local_artifact_path(selected_run_info, "prep_models", "-train_test_split") } else list_files( project_info$storage_object, paste0( @@ -1219,7 +1272,9 @@ reconcile_agent_forecast <- function(agent_info, ) } - model_train_test_tbl <- read_file( + model_train_test_tbl <- if (inherits(project_info$storage_object, c("blob_container", "ms_drive"))) { + read_exact_artifact(project_info, file_list = train_test_file[1]) + } else read_file( run_info = project_info, file_list = train_test_file[1], return_type = "df", @@ -1231,18 +1286,18 @@ reconcile_agent_forecast <- function(agent_info, agent_info = agent_info ) - hts_fcst_tbl <- hts_fcst_tbl %>% - dplyr::filter(Best_Model == "Yes") - # reconcile the forecast project_info$run_name <- agent_info$run_id - final_fcst_tbl <- reconcile( - initial_fcst = hts_fcst_tbl, - run_info = project_info, - forecast_approach = agent_info$forecast_approach, - negative_forecast = negative_forecast - ) %>% + final_fcst_tbl <- hts_fcst_tbl %>% + dplyr::filter(Best_Model == "Yes") %>% + native_forecast_rows(project_info$date_type) %>% + reconcile( + run_info = project_info, + forecast_approach = agent_info$forecast_approach, + negative_forecast = negative_forecast + ) %>% + dplyr::select(-tidyselect::any_of("Run_Type")) %>% create_prediction_intervals(model_train_test_tbl) %>% convert_weekly_to_daily(project_info$date_type, project_info$weekly_to_daily) %>% dplyr::mutate(Train_Test_ID = as.numeric(Train_Test_ID)) %>% @@ -1349,6 +1404,7 @@ forecast_new_combos <- function(agent_info, # agent adjustments to prevent serialization issues agent_info_lean <- agent_info agent_info_lean$llm <- NULL + agent_info_lean$default_reforecast <- TRUE # parallel setup par_info <- par_start( @@ -1364,7 +1420,7 @@ forecast_new_combos <- function(agent_info, on.exit(par_end(cl), add = TRUE) - timestamp <- format(Sys.time(), "%Y%m%d%H%M%S") + timestamp <- "default" combo_tbl <- tryCatch( { @@ -1377,29 +1433,29 @@ forecast_new_combos <- function(agent_info, ) %op% { # check if combo already ran (in case of restart) - agent_best_run_tbl <- tryCatch( - { - read_file(agent_info_lean$project_info, - file_list = paste0( - agent_info_lean$project_info$path, "/logs/", - hash_data(agent_info_lean$project_info$project_name), "-", - hash_data(agent_info_lean$run_id), "-", - combo_hash, "-agent_best_run.csv" - ) %>% - fs::path_tidy() - ) - }, - error = function(e) { - tibble::tibble() - } + agent_best_run_tbl <- read_file(agent_info_lean$project_info, + file_list = paste0( + agent_info_lean$project_info$path, "/logs/", + hash_data(agent_info_lean$project_info$project_name), "-", + hash_data(agent_info_lean$run_id), "-", + combo_hash, "-agent_best_run.csv" + ) %>% fs::path_tidy() ) - if (nrow(agent_best_run_tbl) > 0) { + if (nrow(agent_best_run_tbl) > 0 && !combo_hash %in% agent_info_lean$quality_rejected_combos) { return(data.frame(Combo = combo_hash)) } + if (nrow(agent_best_run_tbl) > 0 && + identical(as.character(agent_best_run_tbl$default_reforecast_status), "accepted")) { + return(list(quality_error = rlang::error_cnd( + "finnts_forecast_selection_rejected", + message = "The default replacement was already attempted and cannot be fitted again.", + combo = agent_best_run_tbl$combo + ))) + } # run forecast with default inputs - run_info <- submit_fcst_run( + run_info <- tryCatch(submit_fcst_run( agent_info = agent_info_lean, inputs = default_inputs, combo = combo_hash, @@ -1408,11 +1464,19 @@ forecast_new_combos <- function(agent_info, inner_parallel = inner_parallel, num_cores = num_cores, seed = seed - ) + ), finnts_forecast_selection_rejected = function(error) error) + if (inherits(run_info, "finnts_forecast_selection_rejected")) return(list(quality_error = run_info)) # get forecast output and calculate metrics fcst_tbl <- get_fcst_output(run_info) weighted_mape <- calculate_fcst_metrics(run_info, fcst_tbl) + if (!isTRUE(agent_selection_summary(run_info$forecast_selection, check_quality = TRUE)$acceptable)) { + return(list(quality_error = rlang::error_cnd( + "finnts_forecast_selection_rejected", + message = "The default replacement forecast failed the applicable quality checks.", + combo = names(run_info$forecast_selection$selections) + ))) + } # log the best run log_best_run( @@ -1434,6 +1498,9 @@ forecast_new_combos <- function(agent_info, } ) + quality_failures <- Filter(function(result) is.list(result) && + inherits(result$quality_error, "finnts_forecast_selection_rejected"), combo_tbl) + if (length(quality_failures)) stop(quality_failures[[1]]$quality_error) return("Finished Forecasting New Time Series") } @@ -1450,6 +1517,36 @@ forecast_new_combos <- function(agent_info, #' #' @return A data frame containing the updated forecast results. #' @noRd +read_global_update_selection <- function(run_info, run_log, combos) { + source_combos <- if (identical(run_log$forecast_approach, "bottoms_up")) { + combos + } else read_selection_hierarchy(run_info)$hts_combos + forecasts <- read_candidate_forecasts(run_info, source_combos, run_log, reconciled = FALSE) + selected_ids <- stats::setNames(vapply(source_combos, function(combo) { + rows <- forecasts[forecasts$Combo == combo, , drop = FALSE] + winner <- if ("Best_Model" %in% names(rows)) { + unique(as.character(rows$Model_ID[!is.na(rows$Best_Model) & rows$Best_Model == "Yes"])) + } else character() + if (length(winner) != 1 || anyNA(winner) || !nzchar(winner)) { + stop("Saved global winner is missing or ambiguous for series: ", combo, + ". Restore the selected source forecasts before updating.", call. = FALSE) + } + winner + }, character(1)), source_combos) + components <- lapply(selected_ids, function(model_id) { + model_ids <- strsplit(model_id, "_", fixed = TRUE)[[1]] + parts <- strsplit(model_ids, "--", fixed = TRUE) + valid <- vapply(parts, function(part) { + length(part) == 3 && all(nzchar(part)) && part[2] == "global" + }, logical(1)) + if (!all(valid) || anyDuplicated(model_ids)) { + stop("Saved global winner has invalid component identities: ", model_id, call. = FALSE) + } + model_ids + }) + list(selected_ids = selected_ids, components = components) +} + update_forecast_combo <- function(agent_info, prev_best_run_tbl, parallel_processing, @@ -1500,11 +1597,10 @@ update_forecast_combo <- function(agent_info, prev_run_log_tbl <- validate_prev_run_log(prev_run_log_tbl) # get best model list from previous run + selected_models <- NULL if (unique(prev_best_run_tbl$model_type) == "global") { - # derive global model IDs from the previous best run's models_to_run - prev_models <- adjust_inputs(prev_run_log_tbl$models_to_run) - global_models <- intersect(prev_models, list_global_models()) - model_id_list <- paste0(global_models, "--global--R1") + selected_models <- read_global_update_selection(prev_run_info, prev_run_log_tbl, combo_list) + model_id_list <- unique(unlist(selected_models$components, use.names = FALSE)) } else { # get previous forecast for local model prev_fcst_tbl <- load_combo_forecast( @@ -1564,6 +1660,14 @@ update_forecast_combo <- function(agent_info, call. = FALSE ) } + if (!is.null(selected_models)) { + missing_models <- setdiff(model_id_list, trained_models_tbl$Model_ID) + if (length(missing_models) || anyDuplicated(trained_models_tbl$Model_ID)) { + stop("Saved selected model fits are missing or ambiguous: ", + paste(missing_models, collapse = ", "), ". Restore the original selected fits before updating.", + call. = FALSE) + } + } # get external regressor info from previous run external_regressors <- adjust_inputs(prev_run_log_tbl$external_regressors) @@ -1626,7 +1730,8 @@ update_forecast_combo <- function(agent_info, run_name <- paste0( "agent_", agent_info$run_id, "_", - ifelse(combo == "All-Data", hash_data("all"), combo_value) + ifelse(combo == "All-Data", hash_data("all"), combo_value), + if (combo == "All-Data") paste0("_", hash_data(prev_best_run_tbl$best_run_name[1])) else "" ) # create new run @@ -1744,9 +1849,22 @@ update_forecast_combo <- function(agent_info, adjust_forecast( run_info = new_run_info, forecast_approach = prev_run_log_tbl$forecast_approach, - negative_forecast = prev_run_log_tbl$negative_forecast + negative_forecast = prev_run_log_tbl$negative_forecast, + selected_models = selected_models ) + selection_log <- read_selection_file(new_run_info, "logs") + selection_log$negative_forecast <- prev_run_log_tbl$negative_forecast + selection_cache <- new.env(parent = emptyenv()) + assessment <- assess_update_forecasts( + final_fcst_tbl, new_run_info, selection_log, model_train_test_tbl, + expected_components = if (is.null(selected_models)) model_id_list else selected_models$components, + cache = selection_cache, combos = combo_list + ) + quality_rejected <- assessment$quality_rejected_combos + final_fcst_tbl <- assessment$forecasts + if (nrow(final_fcst_tbl) == 0) return(list(quality_rejected_combos = quality_rejected)) + final_wmape <- final_fcst_tbl %>% dplyr::filter(Combo %in% combo_list) %>% calc_wmape() @@ -1778,9 +1896,21 @@ update_forecast_combo <- function(agent_info, adjust_forecast( run_info = new_run_info, forecast_approach = prev_run_log_tbl$forecast_approach, - negative_forecast = prev_run_log_tbl$negative_forecast + negative_forecast = prev_run_log_tbl$negative_forecast, + selected_models = selected_models ) + assessment <- assess_update_forecasts( + final_fcst_tbl, new_run_info, selection_log, model_train_test_tbl, + expected_components = if (is.null(selected_models)) model_id_list else selected_models$components, + cache = selection_cache, combos = combo_list + ) + quality_rejected <- unique(c(quality_rejected, assessment$quality_rejected_combos)) + final_fcst_tbl <- assessment$forecasts + keep_hashes <- vapply(as.character(final_fcst_tbl$Combo), hash_data, character(1), USE.NAMES = FALSE) + final_fcst_tbl <- final_fcst_tbl[!keep_hashes %in% quality_rejected, , drop = FALSE] + if (nrow(final_fcst_tbl) == 0) return(list(quality_rejected_combos = quality_rejected)) + final_wmape <- final_fcst_tbl %>% dplyr::filter(Combo %in% combo_list) %>% calc_wmape() @@ -1815,12 +1945,23 @@ update_forecast_combo <- function(agent_info, } else { write_fcst_tbl <- final_fcst_tbl } + completed_fcst_tbl <- write_fcst_tbl %>% + convert_weekly_to_daily(project_info$date_type, prev_run_log_tbl$weekly_to_daily) if (combo == "All-Data" & prev_run_log_tbl$forecast_approach != "bottoms_up") { - # hierarchical: reconciliation in adjust_forecast() already replaced the data + for (source_combo in unique(assessment$source_forecasts$Combo)) { + source_rows <- assessment$source_forecasts[assessment$source_forecasts$Combo == source_combo, , drop = FALSE] %>% + create_prediction_intervals(model_train_test_tbl) %>% + convert_weekly_to_daily(project_info$date_type, prev_run_log_tbl$weekly_to_daily) + write_data(source_rows[source_rows$Recipe_ID != "simple_average", ], combo = source_combo, + run_info = new_run_info, output_type = "data", folder = "forecasts", suffix = "-global_models") + if ("simple_average" %in% source_rows$Recipe_ID) { + write_data(source_rows[source_rows$Recipe_ID == "simple_average", ], combo = source_combo, + run_info = new_run_info, output_type = "data", folder = "forecasts", suffix = "-average_models") + } + } write_data( - x = write_fcst_tbl %>% - convert_weekly_to_daily(project_info$date_type, prev_run_log_tbl$weekly_to_daily), + x = completed_fcst_tbl, combo = "Best-Model", run_info = new_run_info, output_type = "data", @@ -1829,10 +1970,9 @@ update_forecast_combo <- function(agent_info, ) } else if (combo == "All-Data") { # bottoms_up global: write per-combo forecast files - for (combo_name in unique(write_fcst_tbl$Combo)) { - combo_fcst <- write_fcst_tbl %>% - dplyr::filter(Combo == combo_name) %>% - convert_weekly_to_daily(project_info$date_type, prev_run_log_tbl$weekly_to_daily) + for (combo_name in unique(completed_fcst_tbl$Combo)) { + combo_fcst <- completed_fcst_tbl %>% + dplyr::filter(Combo == combo_name) write_data( x = combo_fcst %>% @@ -1859,9 +1999,8 @@ update_forecast_combo <- function(agent_info, } else { # local models: write single models per combo write_data( - x = write_fcst_tbl %>% - dplyr::filter(Recipe_ID != "simple_average") %>% - convert_weekly_to_daily(project_info$date_type, prev_run_log_tbl$weekly_to_daily), + x = completed_fcst_tbl %>% + dplyr::filter(Recipe_ID != "simple_average"), combo = combo_id, run_info = new_run_info, output_type = "data", @@ -1871,9 +2010,8 @@ update_forecast_combo <- function(agent_info, if ("simple_average" %in% unique(write_fcst_tbl$Recipe_ID)) { write_data( - x = write_fcst_tbl %>% - dplyr::filter(Recipe_ID == "simple_average") %>% - convert_weekly_to_daily(project_info$date_type, prev_run_log_tbl$weekly_to_daily), + x = completed_fcst_tbl %>% + dplyr::filter(Recipe_ID == "simple_average"), combo = combo_id, run_info = new_run_info, output_type = "data", @@ -1918,15 +2056,21 @@ update_forecast_combo <- function(agent_info, ) # validate that all outputs can be loaded before logging best run + accepted_selections <- assessment$selections[unique(final_fcst_tbl$Combo)] + new_run_info$forecast_selection <- list(selections = accepted_selections, + source_selections = assessment$source_selections, rejected_combos = character()) + new_run_info$selection_combos <- names(accepted_selections) validate_run_outputs( run_info = new_run_info, combo = if (combo == "All-Data") NULL else hash_data(combo) ) + metric_fcst_tbl <- completed_fcst_tbl %>% + dplyr::left_join(model_train_test_tbl[, c("Train_Test_ID", "Run_Type")], by = "Train_Test_ID") final_log_results <- log_best_run( agent_info = agent_info, run_info = new_run_info, - weighted_mape = log_wmape, + weighted_mape = calculate_fcst_metrics(new_run_info, metric_fcst_tbl, aggregate_wmape = log_wmape), check_best_run = FALSE, combo = if (combo == "All-Data") { NULL @@ -1937,7 +2081,7 @@ update_forecast_combo <- function(agent_info, cli::cli_progress_done("Update Forecast Complete for {combo}") - return("done") + return(list(status = "done", quality_rejected_combos = quality_rejected)) } #' Fit models based on previous run information and hyperparameters @@ -2421,7 +2565,7 @@ fit_models <- function(run_info, #' Adjust Forecast After Model Fitting #' -#' This function adjusts the forecast table after model fitting, averaging forecasts if multiple models are present, and reconciling the forecast if hierarchical time series methods are used. +#' This function assembles fitted component and average forecasts before quality assessment and any hierarchical reconciliation. #' #' @param model_tbl A tibble containing the model fitting results. #' @param run_info A list containing run information such as project name, run name, etc. @@ -2433,7 +2577,8 @@ fit_models <- function(run_info, adjust_forecast <- function(model_tbl, run_info, forecast_approach, - negative_forecast) { + negative_forecast, + selected_models = NULL) { # check if forecasts should be averaged if (nrow(model_tbl) > 1) { simple_average <- TRUE @@ -2451,12 +2596,32 @@ adjust_forecast <- function(model_tbl, dplyr::mutate(Horizon = dplyr::row_number()) %>% dplyr::ungroup() + if (!is.null(selected_models)) { + return(dplyr::bind_rows(lapply(names(selected_models$selected_ids), function(combo) { + components <- selected_models$components[[combo]] + rows <- forecast_tbl[forecast_tbl$Combo == combo & forecast_tbl$Model_ID %in% components, , drop = FALSE] + if (!nrow(rows)) return(rows) + rows$Best_Model <- if (length(components) == 1) "Yes" else "No" + if (length(components) == 1) return(rows) + average <- rows %>% + dplyr::group_by(Combo_ID, Combo, Run_Type, Train_Test_ID, Date) %>% + dplyr::summarise(Forecast = mean(Forecast), Target = mean(Target, na.rm = TRUE), .groups = "drop") %>% + dplyr::group_by(Combo, Train_Test_ID) %>% + dplyr::arrange(Date, .by_group = TRUE) %>% + dplyr::mutate(Horizon = dplyr::row_number()) %>% + dplyr::ungroup() %>% + dplyr::mutate(Model_ID = selected_models$selected_ids[[combo]], Model_Name = NA_character_, + Model_Type = "local", Recipe_ID = "simple_average", Hyperparameter_ID = NA_real_, Best_Model = "Yes") + dplyr::bind_rows(rows, average) + }))) + } + if (simple_average) { # average the forecasts avg_forecast_tbl <- forecast_tbl %>% dplyr::group_by(Combo_ID, Combo, Run_Type, Train_Test_ID, Date, Horizon) %>% dplyr::summarise( - Forecast = mean(Forecast, na.rm = TRUE), + Forecast = mean(Forecast), Target = mean(Target, na.rm = TRUE), .groups = "drop" ) %>% @@ -2477,16 +2642,6 @@ adjust_forecast <- function(model_tbl, dplyr::mutate(Best_Model = "Yes") } - # reconcile forecast if hts - if (unique(final_fcst_tbl$Combo_ID) == "All-Data" & forecast_approach != "bottoms_up") { - final_fcst_tbl <- final_fcst_tbl %>% - reconcile( - run_info = run_info, - forecast_approach = forecast_approach, - negative_forecast = negative_forecast - ) - } - return(final_fcst_tbl) } @@ -2505,6 +2660,7 @@ reconcile <- function(initial_fcst, run_info, forecast_approach, negative_forecast) { + validate_reconciliation_predictions(initial_fcst) if (is.na(negative_forecast)) { warning("'negative_forecast' is NA in reconcile(), defaulting to FALSE") negative_forecast <- FALSE diff --git a/R/ensemble_models.R b/R/ensemble_models.R index d2c6e1fa..9d4666fd 100644 --- a/R/ensemble_models.R +++ b/R/ensemble_models.R @@ -221,6 +221,17 @@ ensemble_models <- function(run_info, initial_results_final_tbl <- single_model_tbl %>% rbind(global_model_tbl) + series_data <- read_series_history( + run_info, unique(initial_results_final_tbl$Combo), run_log = log_df + ) + initial_results_final_tbl <- screen_ensemble_inputs( + initial_results_final_tbl, series_data, model_train_test_tbl + ) + if (nrow(initial_results_final_tbl) == 0) { + cli::cli_alert_warning("No eligible model predictions remain for ensemble training.") + return(data.frame(Combo = combo)) + } + # create training data for ensemble # consolidate Target per (Combo, Date, Train_Test_ID) to avoid duplicate rows # from models with slightly different floating-point Target values diff --git a/R/final_models.R b/R/final_models.R index 572658f5..6b49989b 100644 --- a/R/final_models.R +++ b/R/final_models.R @@ -2,9 +2,52 @@ #' #' Select Best Models and Prep Final Outputs #' +#' @details Candidates are screened for complete, finite predictions and extreme +#' future magnitudes using original-scale prepared actuals. Among eligible +#' candidates within 0.5 percentage points or 5 percent relative weighted MAPE +#' of the best eligible accuracy, whichever allowance is larger, selection +#' prefers lower risk and fewer future level, trend, and seasonal concerns. +#' Tied candidates with assessed seasonal evidence then prefer smaller amplitude +#' distortion beyond historical cycle variation, before weighted MAPE and model +#' identifier. This preference alone does not reject a forecast. Repeated strong +#' historical seasonality can also support phase checks over at least three +#' informative future periods, even when the horizon is shorter than a cycle. +#' Short histories remain usable; unsupported seasonal checks are not assessed. +#' Sufficient regular prepared history can support an additive or proportional +#' trend reference when it improves both chronological historical validation +#' blocks. Level checks then follow the projected trend and seasonal offsets, +#' with uncertainty from historical residuals and drift variation. Proportional +#' references use log-scale changes and seasonal comparisons only for suitable +#' positive history. Unsupported or unstable trends retain the existing +#' seasonal-naive or recent-median reference. Backtests retain the historical +#' magnitude bound; supported future paths use 100 times the larger of the +#' historical robust scale and the absolute projected reference at each step. +#' Prepared-history imputation remains part of the evidence. These checks are +#' engineering guardrails, not calibrated intervals or accuracy guarantees. +#' If all candidates fail the required checks, selection raises an error. +#' Evaluation is deterministic for fixed inputs and creates no diagnostic files. +#' If an individual model wins, the best eligible simple average is still saved +#' with `Best_Model = "No"`, using the same quality-aware ranking among averages. +#' If an average wins overall, that exact average is saved as the best model. +#' No average artifact is required when no eligible average can be formed. +#' Quality selection happens before hierarchical reconciliation, at each prepared +#' hierarchy node. The selected mixture is reconciled without a second future +#' plausibility evaluation or a whole-hierarchy replacement model. Reconciled +#' backtests still supply reported accuracy; reconciliation does not require +#' retained quality rankings. On retry, saved individual and average outputs +#' must identify one complete winner per series. A `Best_Model` column or an +#' average filename alone is not proof of completion. Incomplete selections +#' rebuild averages and winner flags from existing predictions without fitting +#' models again. Complete saved winners are reused without future-quality +#' reassessment, and every series remains in the returned result. Reconciled +#' output is reused only when all original series have complete, unique backtest +#' and future keys with finite forecasts, including every day of a daily-expanded +#' week. Incomplete reconciled output is rebuilt from selected source forecasts +#' and checked before completion is logged; storage and read errors propagate. +#' #' @param run_info run info using the [set_run_info()] function. #' @param average_models If TRUE, create simple averages of individual models -#' and save the most accurate one. +#' and save the eligible average selected by accuracy and future-quality checks. #' @param max_model_average Max number of models to average together. Will #' create model averages for 2 models up until input value or max number of #' models ran. @@ -99,6 +142,9 @@ final_models <- function(run_info, run_global_models <- prev_log_df$run_global_models run_local_models <- prev_log_df$run_local_models run_ensemble_models <- prev_log_df$run_ensemble_models + selection_results <- list() + rejected_combos <- character() + all_reused <- FALSE local_reads <- is.null(run_info$storage_object) && run_info$data_output %in% c("csv", "parquet", "rds") @@ -110,15 +156,15 @@ final_models <- function(run_info, } # define columns to check for input changes - cols_check_list <- c("average_models", "max_model_average", - "weekly_to_daily", "weighted_mape") + cols_check_list <- c("average_models", "max_model_average", "weekly_to_daily") # check if input values have changed from previous run if (all(cols_check_list %in% colnames(prev_log_df))) { # create current log current_log_df <- tibble::tibble( average_models = average_models, - max_model_average = max_model_average + max_model_average = max_model_average, + weekly_to_daily = weekly_to_daily ) %>% data.frame() @@ -137,9 +183,6 @@ final_models <- function(run_info, "new run with 'set_run_info'.", call. = FALSE ) - } else { - cli::cli_alert_info("Best Models Already Selected") - return(cli::cli_progress_done()) } } @@ -147,7 +190,6 @@ final_models <- function(run_info, if ("combo" %in% names(run_info)) { # Single combo mode - no need to check previously completed combos combo_list <- run_info$combo - prev_combo_list <- NULL combo_diff <- combo_list } else { # Multi combo mode - get all combos and check which are complete @@ -168,25 +210,7 @@ final_models <- function(run_info, dplyr::pull(Combo) %>% unique() - previous_files <- if (local_reads) { - forecast_files[endsWith(forecast_files, paste0("-average_models.", run_info$data_output))] - } else list_files( - run_info$storage_object, - paste0( - run_info$path, "/forecasts/*", hash_data(run_info$project_name), "-", - hash_data(run_info$run_name), "*average_models.", run_info$data_output - ) - ) - prev_combo_list <- previous_files %>% - tibble::tibble( - Path = ., - File = fs::path_file(.) - ) %>% - tidyr::separate(File, into = c("Project", "Run", "Combo", "Run_Type"), sep = "-", remove = TRUE) %>% - dplyr::pull(Combo) %>% - unique() - - combo_diff <- setdiff(combo_list, prev_combo_list) + combo_diff <- combo_list } # check if previous run is complete @@ -208,10 +232,7 @@ final_models <- function(run_info, recon_complete <- length(recon_files) > 0 } - if (length(combo_diff) == 0 & length(prev_combo_list) > 0 & recon_complete) { - cli::cli_alert_info("Best Models Already Selected") - return(cli::cli_progress_done()) - } + if (!length(combo_diff)) stop("No forecast data found for this run.", call. = FALSE) if (length(combo_diff) > 0) { # filter to only combos that need to be processed @@ -253,85 +274,26 @@ final_models <- function(run_info, single_model_tbl <- NULL if (run_local_models) { - single_model_tbl <- tryCatch( - { - tbl <- read_file(run_info, - path = paste0( - "/forecasts/", hash_data(run_info$project_name), "-", hash_data(run_info$run_name), - "-", combo, "-single_models.", run_info$data_output - ), - return_type = "df" - ) - if (is.null(tbl) || nrow(tbl) == 0) NULL else tbl - }, - warning = function(w) { - # do nothing - }, - error = function(e) { - NULL - } - ) + single_model_tbl <- read_final_predictions(run_info, combo, "-single_models") } ensemble_model_tbl <- NULL if (run_ensemble_models) { - ensemble_model_tbl <- tryCatch( - { - tbl <- read_file(run_info, - path = paste0( - "/forecasts/", hash_data(run_info$project_name), "-", hash_data(run_info$run_name), - "-", combo, "-ensemble_models.", run_info$data_output - ), - return_type = "df" - ) - if (is.null(tbl) || nrow(tbl) == 0) NULL else tbl - }, - warning = function(w) { - # do nothing - }, - error = function(e) { - NULL - } - ) + ensemble_model_tbl <- read_final_predictions(run_info, combo, "-ensemble_models") } global_model_tbl <- NULL if (run_global_models) { - global_model_tbl <- tryCatch( - { - tbl <- read_file(run_info, - path = paste0( - "/forecasts/", hash_data(run_info$project_name), "-", hash_data(run_info$run_name), - "-", combo, "-global_models.", run_info$data_output - ), - return_type = "df" - ) - if (is.null(tbl) || nrow(tbl) == 0) NULL else tbl - }, - warning = function(w) { - # do nothing - }, - error = function(e) { - NULL - } - ) + global_model_tbl <- read_final_predictions(run_info, combo, "-global_models") } - local_model_tbl <- single_model_tbl %>% - rbind(ensemble_model_tbl) - - all_model_tbl <- local_model_tbl %>% rbind(global_model_tbl) + all_model_tbl <- dplyr::bind_rows(single_model_tbl, ensemble_model_tbl, global_model_tbl) # error if no forecast data was found if (is.null(all_model_tbl) || nrow(all_model_tbl) == 0) { stop(paste0("No forecast data found for combo '", combo, "'."), call. = FALSE) } - # check if model averaging already happened - if ("Best_Model" %in% colnames(all_model_tbl)) { - return(data.frame(Combo_Hash = combo)) - } - # validate required columns before proceeding required_cols <- c("Combo", "Model_ID", "Model_Name", "Model_Type", "Recipe_ID", "Train_Test_ID", "Date", "Forecast", "Target") missing_cols <- setdiff(required_cols, colnames(all_model_tbl)) @@ -342,6 +304,33 @@ final_models <- function(run_info, ), call. = FALSE) } + combo_name <- unique(all_model_tbl$Combo) + if (isTRUE(run_info$allow_quality_rejection) && length(combo_name) == 1 && + identical(as.character(prev_log_df[["selection_status"]]), "rejected")) { + rejected <- rejected_agent_selection(combo_name, "rejected_evaluation") + return(selection_worker_result(combo_name, rejected$selections[[1]], reused = TRUE)) + } + series_data <- read_series_history(run_info, combo_name, run_log = prev_log_df) + saved_average <- read_selection_file(run_info, "forecasts", "-average_models", combo_name, optional = TRUE) + saved_rows <- dplyr::bind_rows(native_forecast_rows(all_model_tbl, date_type), + if (average_models) native_forecast_rows(saved_average, date_type)) + existing_selection <- completed_forecast_selection(saved_rows, series_data, model_train_test_tbl) + if (!is.null(existing_selection)) { + return(selection_worker_result(combo_name, existing_selection, reused = TRUE)) + } + if (nrow(saved_average)) { + saved_average$Best_Model <- "No" + write_data(saved_average, combo = combo_name, run_info = run_info, + output_type = "data", folder = "forecasts", suffix = "-average_models") + } + single_model_tbl <- unfinalized_forecast_rows(single_model_tbl, date_type) + ensemble_model_tbl <- unfinalized_forecast_rows(ensemble_model_tbl, date_type) + global_model_tbl <- unfinalized_forecast_rows(global_model_tbl, date_type) + local_model_tbl <- if (is.null(single_model_tbl) && is.null(ensemble_model_tbl)) { + NULL + } else dplyr::bind_rows(single_model_tbl, ensemble_model_tbl) + all_model_tbl <- dplyr::bind_rows(local_model_tbl, global_model_tbl) + # combine all forecasts predictions_tbl <- all_model_tbl %>% dplyr::select(Combo, Model_ID, Model_Name, Model_Type, Recipe_ID, Train_Test_ID, Date, Forecast, Target) %>% @@ -441,11 +430,20 @@ final_models <- function(run_info, final_model_list <- c(local_model_list, global_model_list) + individual_selection <- select_series_forecasts( + predictions_tbl, series_data, model_train_test_tbl, + unique(predictions_tbl$Model_ID) + ) + final_model_list <- individual_selection$rankings$Model_ID[ + individual_selection$rankings$Eligible + ] if (length(final_model_list) == 0) { - stop(paste0( - "Combo '", combo, "': no models produced complete back test coverage (", - expected_back_test_fold_count, " folds expected). Cannot select Best_Model." - ), call. = FALSE) + write_rejected_forecasts( + list("-single_models" = single_model_tbl, "-ensemble_models" = ensemble_model_tbl, + "-global_models" = global_model_tbl), + run_info, unique(predictions_tbl$Combo), model_train_test_tbl, date_type, initial_weekly_to_daily + ) + return(selection_worker_result(unique(predictions_tbl$Combo), individual_selection)) } # simple model averaging @@ -502,7 +500,7 @@ final_models <- function(run_info, dplyr::group_by(Combo, Train_Test_ID, Date) %>% dplyr::summarise( Target = mean(Target, na.rm = TRUE), - Forecast = mean(Forecast, na.rm = TRUE) + Forecast = mean(Forecast) ) %>% dplyr::mutate(Model_ID = x) %>% dplyr::select(Combo, Model_ID, Train_Test_ID, Date, Target, Forecast) %>% @@ -517,33 +515,6 @@ final_models <- function(run_info, averages_tbl <- NULL } - # choose best average model - if (!is.null(averages_tbl)) { - avg_back_test_mape <- averages_tbl %>% - dplyr::mutate( - Train_Test_ID = as.numeric(Train_Test_ID), - Target = ifelse(Target == 0, 0.1, Target) - ) %>% - dplyr::filter(Train_Test_ID != 1) %>% - dplyr::mutate(MAPE = round(abs((Forecast - Target) / Target), digits = 4)) - - avg_best_model_mape <- avg_back_test_mape %>% - dplyr::group_by(Model_ID, Combo) %>% - dplyr::mutate( - Combo_Total = sum(abs(Target), na.rm = TRUE), - weighted_MAPE = (abs(Target) / Combo_Total) * MAPE - ) %>% - dplyr::summarise(Rolling_MAPE = sum(weighted_MAPE, na.rm = TRUE)) %>% - dplyr::arrange(Rolling_MAPE) %>% - dplyr::ungroup() %>% - dplyr::group_by(Combo) %>% - dplyr::slice(1) %>% - dplyr::ungroup() - - avg_best_model_tbl <- avg_best_model_mape %>% - dplyr::select(Combo, Model_ID) - } - # choose best overall model final_predictions_tbl <- predictions_tbl %>% dplyr::select(Combo, Model_ID, Train_Test_ID, Date, Forecast, Target) %>% @@ -565,19 +536,29 @@ final_models <- function(run_info, if (!is.null(averages_tbl)) unique(averages_tbl$Model_ID) else character(0) )) - best_model_mape <- back_test_mape %>% - dplyr::filter(Model_ID %in% eligible_model_ids) %>% - dplyr::group_by(Model_ID, Combo) %>% - dplyr::mutate( - Combo_Total = sum(abs(Target), na.rm = TRUE), - weighted_MAPE = (abs(Target) / Combo_Total) * MAPE - ) %>% - dplyr::summarise(Rolling_MAPE = sum(weighted_MAPE, na.rm = TRUE)) %>% - dplyr::arrange(Rolling_MAPE) %>% - dplyr::ungroup() %>% - dplyr::group_by(Combo) %>% - dplyr::slice(1) %>% - dplyr::ungroup() + selection <- select_series_forecasts( + final_predictions_tbl, series_data, model_train_test_tbl, eligible_model_ids + ) + if (is.na(selection$selected_id)) { + abort_forecast_selection(unique(predictions_tbl$Combo), selection) + } + if (!is.null(averages_tbl)) { + average_selection <- rank_forecast_candidates(selection$rankings[ + selection$rankings$Model_ID %in% averages_tbl$Model_ID, , drop = FALSE + ]) + avg_best_model_tbl <- tibble::tibble( + Combo = unique(predictions_tbl$Combo), Model_ID = average_selection$selected_id + ) %>% dplyr::filter(!is.na(Model_ID)) + } + selected_checks <- selection$rankings[selection$rankings$Model_ID == selection$selected_id, ] + if (selected_checks$Violations > 0) { + cli::cli_alert_warning("Selected forecast has plausibility concerns: {paste(selected_checks$Reasons[[1]], collapse = ', ')}") + } + best_model_mape <- selection$rankings %>% + dplyr::filter(Model_ID == selection$selected_id) %>% + dplyr::transmute( + Combo = unique(predictions_tbl$Combo), Model_ID, Rolling_MAPE = .data$WMAPE + ) best_model_tbl <- best_model_mape %>% dplyr::mutate(Best_Model = "Yes") %>% @@ -720,7 +701,7 @@ final_models <- function(run_info, ) %>% dplyr::mutate(Best_Model = ifelse(!is.na(Best_Model), "Yes", "No")) - if (!is.null(averages_tbl)) { + if (!is.null(averages_tbl) && nrow(avg_best_model_tbl) > 0) { avg_model_final_tbl <- averages_tbl %>% dplyr::right_join(avg_best_model_tbl, by = c("Combo", "Model_ID") @@ -811,15 +792,20 @@ final_models <- function(run_info, } } - return(data.frame(Combo_Hash = combo)) + return(selection_worker_result(unique(predictions_tbl$Combo), selection)) } %>% base::suppressPackageStartupMessages() # clean up any parallel run process par_end(cl) + selection_results <- stats::setNames(best_model_tbl$Selection, best_model_tbl$Combo) + all_reused <- all(best_model_tbl$Reused) + rejected_combos <- names(selection_results)[vapply(selection_results, function(result) { + !is.null(result) && is.na(result$selected_id) + }, logical(1))] # condense outputs into less files for larger runs - if (length(combo_list) > 3000) { + if (length(combo_list) > 3000 && length(rejected_combos) == 0 && !all_reused) { cli::cli_progress_step("Condensing Forecasts") condense_data( @@ -830,8 +816,49 @@ final_models <- function(run_info, } } # end combo processing - # reconcile hierarchical forecasts + if (length(rejected_combos)) { + if (forecast_approach != "bottoms_up") { + abort_forecast_selection(rejected_combos, selection_results[[rejected_combos[1]]]) + } + if (!isTRUE(run_info$allow_quality_rejection)) { + rejection <- selection_results[[rejected_combos[1]]] + if (all(vapply(rejection$rankings$Reasons, function(reasons) "incomplete_backtests" %in% reasons, logical(1)))) { + rejection$rankings$Reasons[[1]] <- c(rejection$rankings$Reasons[[1]], "no models produced complete back test coverage") + } + abort_forecast_selection(rejected_combos, rejection) + } + partial_log <- read_selection_file(run_info, "logs") + partial_log$average_models <- average_models + partial_log$max_model_average <- max_model_average + partial_log$weekly_to_daily <- weekly_to_daily + partial_log$weighted_mape <- NA_real_ + write_data(partial_log, combo = NULL, run_info = run_info, output_type = "log", folder = "logs", suffix = NULL) + return(invisible(list(selections = selection_results, rejected_combos = rejected_combos))) + } + + fcst_data <- NULL + selection_cache <- new.env(parent = emptyenv()) if (forecast_approach != "bottoms_up") { + recon_path <- local_artifact_path(run_info, "forecasts", "-reconciled", hash_data("Best-Model")) + read_reconciliation <- function(files = NULL) { + if (local_reads) { + if (is.null(files)) files <- local_artifact_files(recon_path) + if (identical(run_info$data_output, "parquet")) { + arrow::read_parquet(files[[1]], mmap = FALSE) + } else read_file(run_info, file_list = files, strict = TRUE) + } else { + read_file(run_info, path = fs::path("forecasts", fs::path_file(recon_path)), strict = TRUE) + } + } + if (all_reused && recon_complete) { + fcst_data <- read_reconciliation(recon_files) + recon_complete <- complete_reconciled_forecast(fcst_data, run_info, prev_log_df, + model_train_test_tbl, weekly_to_daily, selection_cache) + } + } + + # reconcile hierarchical forecasts + if (forecast_approach != "bottoms_up" && (!all_reused || !recon_complete)) { cli::cli_progress_step("Reconciling Hierarchical Forecasts") reconcile_hierarchical_data( @@ -843,10 +870,24 @@ final_models <- function(run_info, date_type, num_cores ) + fcst_data <- read_reconciliation() + if (!complete_reconciled_forecast(fcst_data, run_info, prev_log_df, + model_train_test_tbl, weekly_to_daily, selection_cache)) { + stop("Reconciled forecasts are incomplete or invalid. Restore the selected source forecasts and retry final_models().", + call. = FALSE) + } } # validate that every combo has a best model - fcst_data <- get_forecast_data(run_info = run_info) + if (forecast_approach == "bottoms_up") { + fcst_data <- get_forecast_data(run_info = run_info) + } else { + fcst_data <- fcst_data %>% + dplyr::select(-tidyselect::any_of("Run_Type")) %>% + dplyr::mutate(Train_Test_ID = as.numeric(Train_Test_ID)) %>% + dplyr::left_join(dplyr::select(model_train_test_tbl, Run_Type, Train_Test_ID), by = "Train_Test_ID") %>% + dplyr::arrange(Combo, dplyr::desc(Best_Model), Model_ID, Train_Test_ID, Date) + } # calculate weighted mape weighted_mape <- fcst_data %>% @@ -867,10 +908,7 @@ final_models <- function(run_info, round(digits = 4) # update logging file - log_df <- read_file(run_info, - path = paste0("logs/", hash_data(run_info$project_name), "-", hash_data(run_info$run_name), ".csv"), - return_type = "df" - ) %>% + log_df <- prev_log_df %>% dplyr::mutate( average_models = average_models, max_model_average = max_model_average, @@ -878,14 +916,66 @@ final_models <- function(run_info, weighted_mape = round(weighted_mape, digits = 4) ) - write_data( - x = log_df, - combo = NULL, - run_info = run_info, - output_type = "log", - folder = "logs", - suffix = NULL - ) + if (!all_reused || !recon_complete || !isTRUE(as.numeric(prev_log_df[["weighted_mape"]]) == weighted_mape)) { + write_data( + x = log_df, + combo = NULL, + run_info = run_info, + output_type = "log", + folder = "logs", + suffix = NULL + ) + } + if (all_reused) cli::cli_alert_info("Best Models Already Selected") + result <- list(selections = selection_results, rejected_combos = rejected_combos) + if (forecast_approach != "bottoms_up") { + result <- hierarchical_selection_result(run_info, prev_log_df, selection_results, + fcst_data, model_train_test_tbl, cache = selection_cache) + } + invisible(result) +} + +complete_reconciled_forecast <- function(forecasts, run_info, run_log, splits, + weekly_to_daily, cache) { + required <- c("Combo", "Model_ID", "Best_Model", "Train_Test_ID", "Date", "Target", "Forecast") + if (!is.data.frame(forecasts) || !nrow(forecasts) || !all(required %in% names(forecasts)) || + !is.numeric(forecasts$Forecast) || !is.numeric(forecasts$Target) || + any(!is.finite(forecasts$Forecast)) || anyNA(forecasts$Combo) || + anyNA(forecasts$Model_ID) || any(!nzchar(as.character(forecasts$Model_ID))) || + anyNA(forecasts$Best_Model) || any(forecasts$Best_Model != "Yes")) return(FALSE) + forecast_dates <- tryCatch(as.Date(forecasts$Date), error = function(error) NULL) + if (is.null(forecast_dates) || anyNA(forecast_dates)) return(FALSE) + forecasts$Date <- forecast_dates + daily <- identical(run_log$date_type, "week") && weekly_to_daily + if (daily != ("Date_Day" %in% names(forecasts))) return(FALSE) + if (daily) { + daily_dates <- tryCatch(as.Date(forecasts$Date_Day), error = function(error) NULL) + if (is.null(daily_dates) || anyNA(daily_dates)) return(FALSE) + forecasts$Date_Day <- daily_dates + } + hierarchy <- read_selection_hierarchy(run_info, cache) + combos <- hierarchy$original_combos + if (!setequal(as.character(forecasts$Combo), combos)) return(FALSE) + stored_combos <- utils::tail(hierarchy$hts_combos, length(combos)) + for (combo_index in seq_along(combos)) { + rows <- forecasts[forecasts$Combo == combos[combo_index], , drop = FALSE] + if (length(unique(rows$Model_ID)) != 1L) return(FALSE) + series <- read_series_history(run_info, stored_combos[combo_index], run_log, cache) + series$train_test_split <- splits + expected <- dplyr::bind_rows(forecast_selection_keys(series, "Back_Test"), + forecast_selection_keys(series, "Future_Forecast")) + if (daily) { + expected <- expected[rep(seq_len(nrow(expected)), each = 7L), , drop = FALSE] + native_dates <- expected$Date + expected$Date <- expected$Date + rep(0:6, length.out = nrow(expected)) + daily_rows <- data.frame(Train_Test_ID = rows$Train_Test_ID, Date = rows$Date_Day) + if (!forecast_keys_complete(daily_rows, expected)) return(FALSE) + row_order <- order(as.character(rows$Train_Test_ID), rows$Date_Day, method = "radix") + expected_order <- order(as.character(expected$Train_Test_ID), expected$Date, method = "radix") + if (!identical(as.numeric(rows$Date[row_order]), as.numeric(native_dates[expected_order]))) return(FALSE) + } else if (!forecast_keys_complete(rows, expected)) return(FALSE) + } + TRUE } #' Create prediction intervals diff --git a/R/forecast_selection.R b/R/forecast_selection.R new file mode 100644 index 00000000..06b01a64 --- /dev/null +++ b/R/forecast_selection.R @@ -0,0 +1,1138 @@ +normalize_series_history <- function(data, hist_end_date, recipe = "R1", + combo_info = NULL, stationary = FALSE, + box_cox = FALSE) { + required <- c("Date", "Target") + if (!is.data.frame(data) || !all(required %in% names(data)) || nrow(data) == 0) { + stop("Prepared history must contain nonempty Date and Target columns.", call. = FALSE) + } + if (identical(recipe, "R2")) { + if (!all(c("Horizon", "Origin") %in% names(data))) { + stop("R2 history is missing Horizon or Origin.", call. = FALSE) + } + data <- data[!is.na(data$Horizon) & data$Horizon == 1, , drop = FALSE] + } + data$Date <- as.Date(data$Date) + data <- data[order(data$Date), , drop = FALSE] + if (nrow(data) == 0 || anyNA(data$Date) || anyDuplicated(data$Date)) { + stop("Prepared history must have one observation per date.", call. = FALSE) + } + if (identical(recipe, "R2") && + (anyNA(data$Origin) || any(diff(data$Origin) != 1))) { + stop("R2 history has inconsistent Horizon 1 origins.", call. = FALSE) + } + calendar <- data$Date + data <- data[, intersect(c("Combo", "Date", "Target", "Target_Original"), names(data)), drop = FALSE] + if (stationary || box_cox) { + if (!is.data.frame(combo_info) || nrow(combo_info) != 1) { + stop("Original-scale history requires the series transformation metadata.", call. = FALSE) + } + if (stationary) { + if (!all(c("Diff_Value1", "Diff_Value2") %in% names(combo_info))) { + stop("History transformation metadata is missing differencing values.", call. = FALSE) + } + data <- undifference_recipe(data, combo_info, hist_end_date) + } + if (box_cox) { + if (!"Box_Cox_Lambda" %in% names(combo_info)) { + stop("History transformation metadata is missing Box_Cox_Lambda.", call. = FALSE) + } + if (!is.na(combo_info$Box_Cox_Lambda)) { + for (target_column in intersect(c("Target", "Target_Original"), names(data))) { + data[[target_column]] <- timetk::box_cox_inv_vec( + data[[target_column]], lambda = combo_info$Box_Cox_Lambda + ) + } + } + } + } + actual_column <- if ("Target_Original" %in% names(data)) "Target_Original" else "Target" + history <- data.frame(Date = data$Date, Target = data[[actual_column]]) + history <- history[history$Date <= as.Date(hist_end_date), , drop = FALSE] + if (nrow(history) == 0 || !any(is.finite(history$Target))) { + stop("Prepared history contains no usable historical actuals.", call. = FALSE) + } + list(history = history, calendar = calendar, hist_end_date = as.Date(hist_end_date)) +} + +read_series_history <- function(run_info, combo, run_log = NULL, cache = NULL) { + if (length(combo) != 1 || is.na(combo)) { + stop("Read prepared history for exactly one series at a time.", call. = FALSE) + } + prefix <- paste0(hash_data(run_info$project_name), "-", hash_data(run_info$run_name)) + cache_key <- paste(prefix, hash_data(combo), sep = "-") + if (!is.null(cache) && exists(cache_key, envir = cache, inherits = FALSE)) { + return(get(cache_key, envir = cache, inherits = FALSE)) + } + if (is.null(run_log)) { + run_log <- read_exact_artifact(run_info, file_list = fs::path( + run_info$path, "logs", paste0(prefix, ".csv") + ), return_type = "df") + } + if (nrow(run_log) != 1 || !"hist_end_date" %in% names(run_log)) { + stop("Prepared history requires the existing run log and historical cutoff.", call. = FALSE) + } + recipes <- run_log[["recipes_to_run"]] + if (is.null(recipes) || is.na(recipes) || recipes == "all") { + recipe <- "R1" + } else { + recipe_list <- strsplit(recipes, "---", fixed = TRUE)[[1]] + recipe <- if ("R1" %in% recipe_list) "R1" else "R2" + } + prepared <- read_exact_artifact(run_info, file_list = fs::path( + run_info$path, "prep_data", paste0(prefix, "-", hash_data(combo), "-", recipe, ".", run_info$data_output) + ), return_type = "df") + prepared <- adjust_combo_column(prepared) + if ("Combo" %in% names(prepared) && any(is.na(prepared$Combo) | as.character(prepared$Combo) != combo)) { + stop("Prepared history does not match the requested series.", call. = FALSE) + } + stationary <- isTRUE(as.logical(run_log[["stationary"]])) + box_cox <- isTRUE(as.logical(run_log[["box_cox"]])) + combo_info <- NULL + if (stationary || box_cox) { + metadata_key <- paste0(prefix, "-orig_combo_info") + if (!is.null(cache) && exists(metadata_key, envir = cache, inherits = FALSE)) { + combo_info <- get(metadata_key, envir = cache, inherits = FALSE) + } else { + combo_info <- read_exact_artifact(run_info, file_list = fs::path( + run_info$path, "prep_data", paste0(metadata_key, ".", run_info$data_output) + ), return_type = "df") + if (!is.null(cache)) assign(metadata_key, combo_info, envir = cache) + } + combo_info <- adjust_combo_column(combo_info) + combo_info <- combo_info[!is.na(combo_info$Combo) & combo_info$Combo == combo, , drop = FALSE] + } + result <- normalize_series_history( + prepared, hist_end_date = run_log$hist_end_date, recipe = recipe, + combo_info = combo_info, stationary = stationary, box_cox = box_cox + ) + result$date_type <- run_log$date_type + result$seasonal_period <- run_log[["seasonal_period"]] + if (!is.null(cache)) assign(cache_key, result, envir = cache) + result +} + +forecast_selection_keys <- function(context, run_type) { + supplied <- context[[if (run_type == "Back_Test") "expected_backtests" else "expected_forecasts"]] + if (!is.null(supplied)) return(supplied) + splits <- context$train_test_split + splits <- splits[splits$Run_Type == run_type, , drop = FALSE] + dplyr::bind_rows(lapply(seq_len(nrow(splits)), function(split_index) { + dates <- context$calendar[ + context$calendar > as.Date(splits$Train_End[split_index]) & + context$calendar <= as.Date(splits$Test_End[split_index]) + ] + data.frame(Train_Test_ID = rep(splits$Train_Test_ID[split_index], length(dates)), Date = dates) + })) +} + +forecast_keys_complete <- function(predictions, expected) { + if (length(predictions$Date) != nrow(expected) || nrow(expected) == 0) return(FALSE) + ids <- as.character(predictions$Train_Test_ID) + dates <- as.Date(predictions$Date) + if (anyNA(ids) || anyNA(dates)) return(FALSE) + key_order <- order(ids, dates, method = "radix") + ids <- ids[key_order] + dates <- as.numeric(dates[key_order]) + if (any(utils::head(ids, -1) == utils::tail(ids, -1) & diff(dates) == 0)) return(FALSE) + expected_ids <- as.character(expected$Train_Test_ID) + expected_dates <- as.Date(expected$Date) + expected_order <- order(expected_ids, expected_dates, method = "radix") + identical(ids, expected_ids[expected_order]) && + identical(dates, as.numeric(expected_dates[expected_order])) +} + +forecast_seasonal_period <- function(context) { + configured <- context[["seasonal_period"]] + if (!is.null(configured) && length(configured) && !all(is.na(configured))) { + periods <- suppressWarnings(as.numeric(unlist(strsplit(as.character(configured), "---", fixed = TRUE)))) + periods <- periods[is.finite(periods) & periods > 1 & periods == floor(periods)] + if (length(periods)) return(min(periods)) + } + switch(context[["date_type"]] %||% "year", + day = 7L, week = 52L, month = 12L, quarter = 4L, 1L + ) +} + +finite_mad <- function(values) { + values <- values[is.finite(values)] + if (length(values)) stats::mad(values) else 0 +} + +forecast_trend_fit <- function(values, period, horizon) { + if (length(values) < max(8, 2 * period) || any(!is.finite(values))) return(NULL) + slopes <- (values[-seq_len(period)] - utils::head(values, -period)) / period + drift <- stats::median(slopes) + slope_mad <- finite_mad(slopes) + precision <- 64 * .Machine$double.eps * max(1, abs(values)) + if (!is.finite(drift) || abs(drift) <= max(2 * slope_mad, precision)) return(NULL) + time <- seq_along(values) - length(values) + phases <- ((time - 1) %% period) + 1 + intercepts <- vapply(seq_len(period), function(phase) { + stats::median((values - drift * time)[phases == phase]) + }, numeric(1)) + projection <- drift * seq_len(horizon) + rep(intercepts, length.out = horizon) + if (any(!is.finite(projection))) return(NULL) + list(drift = drift, slope_mad = slope_mad, + residual_mad = finite_mad(values - drift * time - intercepts[phases]), + projection = projection, values = values) +} + +forecast_trend_reference <- function(history, horizon, context, normalization, scale) { + period <- forecast_seasonal_period(context) + history_size <- nrow(history) + if (history_size < max(12, 3 * period) || horizon < 1 || + normalization <= 0 || scale <= 0 || any(!is.finite(history$Target)) || + !"Date" %in% names(history)) return(NULL) + if ("Observed" %in% names(history) && + any(is.na(history$Observed) | !history$Observed)) return(NULL) + cadence <- switch(context[["date_type"]] %||% "year", + day = "day", week = "week", month = "month", quarter = "3 months", year = "year") + dates <- as.Date(history$Date) + if (is.null(cadence) || anyNA(dates) || + !identical(dates, seq(dates[1], by = cadence, length.out = history_size))) return(NULL) + block_size <- max(1L, floor(period / 2)) + origins <- history_size - c(2, 1) * block_size + if (min(origins) < max(8, 2 * period)) return(NULL) + values <- history$Target / normalization + precision <- 64 * .Machine$double.eps + baseline_errors <- vapply(origins, function(origin) { + training <- values[seq_len(origin)] + prediction <- if (period > 1) { + rep(utils::tail(training, period), length.out = block_size) + } else rep(stats::median(utils::tail(training, 4)), block_size) + mean(abs(prediction - values[origin + seq_len(block_size)])) + }, numeric(1)) + if (any(!is.finite(baseline_errors) | baseline_errors <= precision)) return(NULL) + modes <- c("additive", if (all(values > sqrt(.Machine$double.eps) * scale)) "log") + candidates <- lapply(modes, function(mode) { + working <- if (mode == "log") log(history$Target) - log(normalization) else values + fitted <- forecast_trend_fit(working, period, horizon) + if (is.null(fitted)) return(NULL) + errors <- vapply(origins, function(origin) { + prefix <- forecast_trend_fit(working[seq_len(origin)], period, block_size) + if (is.null(prefix) || sign(prefix$drift) != sign(fitted$drift)) return(Inf) + prediction <- if (mode == "log") exp(prefix$projection) else prefix$projection + if (any(!is.finite(prediction))) return(Inf) + mean(abs(prediction - values[origin + seq_len(block_size)])) + }, numeric(1)) + if (any(!is.finite(errors) | errors > 0.8 * baseline_errors)) return(NULL) + fitted$mode <- mode + fitted$validation_errors <- errors + fitted + }) + names(candidates) <- modes + selected <- candidates[["additive"]] + logarithmic <- candidates[["log"]] + if (!is.null(logarithmic) && (is.null(selected) || + all(selected$validation_errors > precision & + logarithmic$validation_errors <= 0.8 * selected$validation_errors))) { + selected <- logarithmic + } + if (is.null(selected)) return(NULL) + log_projection <- if (selected$mode == "log") { + log(normalization) + selected$projection + } else log(normalization) + log(abs(selected$projection)) + nonzero <- if (selected$mode == "log") rep(TRUE, horizon) else selected$projection != 0 + if (any(!is.finite(log_projection[nonzero])) || + any(log_projection[nonzero] > log(.Machine$double.xmax)) || + any(log_projection[nonzero] < log(.Machine$double.xmin) + log(.Machine$double.eps))) return(NULL) + selected$log_magnitude_scale <- pmax(log(normalization) + log(scale), log_projection) + noise_floor <- if (selected$mode == "log") log1p(0.05) else 0.05 * scale + steps <- seq_len(horizon) + selected$widths <- 6 * sqrt(steps * max(selected$residual_mad, noise_floor)^2 + + (steps * selected$slope_mad)^2) + selected$scale <- if (selected$mode == "log") { + max(as.numeric(stats::quantile(abs(selected$values), 0.95)), + finite_mad(selected$values), finite_mad(diff(selected$values))) + } else scale + selected +} + +forecast_reference <- function(history, horizon, context) { + period <- forecast_seasonal_period(context) + window_size <- max(12, 3 * period, 2 * horizon) + if (!is.null(context[["hist_end_date"]])) { + history <- history[as.Date(history$Date) <= as.Date(context$hist_end_date), , drop = FALSE] + } + history <- history[order(history$Date), , drop = FALSE] + window_history <- utils::tail(history, window_size) + actuals <- window_history$Target + if (!any(is.finite(actuals))) { + stop("Forecast selection requires usable historical actuals in its reference window.", call. = FALSE) + } + normalization <- max(abs(actuals[is.finite(actuals)])) + values <- if (normalization > 0) actuals / normalization else actuals + finite_values <- values[is.finite(values)] + scale <- max(as.numeric(stats::quantile(abs(finite_values), 0.95)), finite_mad(values), finite_mad(diff(values))) + reference <- rep(stats::median(utils::tail(finite_values, min(length(finite_values), max(period, 4)))), horizon) + differences <- diff(values) + seasonal_available <- period > 1 && length(values) >= period && all(is.finite(utils::tail(values, period))) + if (seasonal_available) { + reference <- rep(utils::tail(values, period), length.out = horizon) + if (length(values) > period) differences <- values[-seq_len(period)] - utils::head(values, -period) + } + trend <- forecast_trend_reference(window_history, horizon, context, normalization, scale) + profile_values <- if (!is.null(trend) && trend$mode == "log") trend$values else values + profile <- rep(0, period) + strength <- NA_real_ + cycle_profiles <- NULL + amplitude_tolerance <- NA_real_ + short_seasonality <- NULL + cycles <- floor(length(values) / period) + if (seasonal_available && cycles >= 2) { + complete <- utils::tail(profile_values, cycles * period) + if (all(is.finite(complete))) { + time <- seq_along(complete) + detrended <- stats::lm.fit(cbind(1, time), complete)$residuals + phases <- rep(seq_len(period), cycles) + profile <- vapply(seq_len(period), function(phase) stats::median(detrended[phases == phase]), numeric(1)) + profile <- profile - mean(profile) + cycle_profiles <- matrix(detrended, nrow = cycles, byrow = TRUE) + cycle_profiles <- sweep(cycle_profiles, 1, rowMeans(cycle_profiles), "-") + cycle_amplitudes <- apply(cycle_profiles, 1, function(cycle) diff(range(cycle))) + amplitude_tolerance <- max(3 * finite_mad(cycle_amplitudes), 0.05 * diff(range(profile))) + variation <- stats::var(detrended) + if (is.finite(variation) && variation > 0) { + strength <- max(0, 1 - stats::var(detrended - profile[phases]) / variation) + } + if (is.finite(strength) && strength >= 0.6 && period >= 3 && horizon >= 3 && horizon < period) { + observed_phases <- seq_len(horizon) + observed_profile <- profile[observed_phases] + observed_amplitude <- diff(range(observed_profile)) + observed_cycles <- cycle_profiles[, observed_phases, drop = FALSE] + phase_residuals <- sweep(observed_cycles, 2, observed_profile, "-") + phase_noise <- max(3 * finite_mad(as.numeric(phase_residuals)), 0.05 * diff(range(profile))) + if (observed_amplitude > phase_noise) { + observed_amplitudes <- apply(observed_cycles, 1, function(cycle) diff(range(cycle))) + short_seasonality <- list( + profile = observed_profile - mean(observed_profile), + trend = stats::median(diff(complete - profile[phases])), + phase_noise = phase_noise, + amplitude_tolerance = max(3 * finite_mad(observed_amplitudes), 0.05 * observed_amplitude) + ) + } + } + } + } + list( + normalization = normalization, scale = scale, values = values, + reference = reference, width = max(finite_mad(differences), 0.05 * scale), + period = period, profile = profile, seasonal_strength = strength, + seasonal_available = seasonal_available, cycle_profiles = cycle_profiles, + amplitude_tolerance = amplitude_tolerance, short_seasonality = short_seasonality, + trend = trend + ) +} + +forecast_path_risk <- function(forecasts, reference) { + reasons <- character() + components <- c(level = NA_real_, trend = NA_real_, seasonality = NA_real_) + seasonal_fidelity <- NA_real_ + if (!length(forecasts) || any(!is.finite(forecasts))) { + return(list(risk = 0, reasons = reasons, components = components, seasonal_fidelity = seasonal_fidelity)) + } + if (reference$normalization == 0) { + if (any(forecasts != 0)) { + components["level"] <- 1 + reasons <- "unsupported_level" + } else { + components["level"] <- 0 + } + } else { + trend <- reference$trend + logarithmic <- !is.null(trend) && identical(trend$mode, "log") + if (logarithmic && any(forecasts <= 0)) { + components["level"] <- 1 + return(list(risk = 1, reasons = "level_deviation", components = components, + seasonal_fidelity = seasonal_fidelity)) + } + path <- if (logarithmic) log(forecasts) - log(reference$normalization) else forecasts / reference$normalization + widths <- if (is.null(trend)) 6 * reference$width * sqrt(seq_along(path)) else trend$widths + expected <- if (is.null(trend)) reference$reference else trend$projection + level_deviation <- abs(path - expected) + level_ratios <- level_deviation / widths + level_ratios[widths == 0 & level_deviation == 0] <- 0 + components["level"] <- max(0, max(level_ratios) - 1) + if (components["level"] > 0) reasons <- c(reasons, "level_deviation") + values <- if (logarithmic) trend$values else reference$values + working_scale <- if (logarithmic) trend$scale else reference$scale + period <- reference$period + strong_seasonality <- is.finite(reference$seasonal_strength) && reference$seasonal_strength >= 0.6 + if (strong_seasonality) { + phases <- ((seq_along(values) - length(values) - 1) %% period) + 1 + values <- values - reference$profile[phases] + adjusted <- path - rep(reference$profile, length.out = length(path)) + } else { + adjusted <- path + } + span <- min(length(path), length(values)) + if (span >= 4 && all(is.finite(values))) { + changes <- diff(values) + slopes <- if (span %% 2 == 0) { + stats::runmed(changes, k = span - 1, endrule = "constant")[ + seq.int(span / 2, length.out = length(values) - span + 1) + ] + } else { + vapply(seq_len(length(values) - span + 1), function(start) { + stats::median(changes[seq.int(start, length.out = span - 1)]) + }, numeric(1)) + } + slope_scale <- max(finite_mad(slopes), 0.05 * working_scale / span) + trend_deviation <- abs(stats::median(diff(adjusted)) - stats::median(slopes)) + trend_ratio <- if (slope_scale == 0 && trend_deviation == 0) 0 else trend_deviation / (6 * slope_scale) + components["trend"] <- max(0, trend_ratio - 1) + if (components["trend"] > 0) reasons <- c(reasons, "trend_deviation") + } + if (strong_seasonality && length(path) >= period && period >= 3) { + time <- seq_along(path) + detrended <- stats::lm.fit(cbind(1, time), path)$residuals + phases <- rep(seq_len(period), length.out = length(path)) + future_profile <- vapply(seq_len(period), function(phase) stats::median(detrended[phases == phase]), numeric(1)) + historical_amplitude <- diff(range(reference$profile)) + future_amplitude <- diff(range(future_profile)) + if (historical_amplitude > 0) { + amplitude_tolerance <- reference$amplitude_tolerance %||% NA_real_ + if (is.finite(amplitude_tolerance)) { + seasonal_fidelity <- min(.Machine$double.xmax, + max(0, (abs(future_amplitude - historical_amplitude) - amplitude_tolerance) / historical_amplitude)) + } + ratio <- future_amplitude / historical_amplitude + amplitude_risk <- if (ratio == 0) 100 else max(0, ratio / 3 - 1, 1 / (3 * ratio) - 1) + phase_correlation <- if (stats::sd(future_profile) > 0) stats::cor(reference$profile, future_profile) else NA_real_ + phase_risk <- if (is.finite(phase_correlation)) max(0, -phase_correlation) else 0 + components["seasonality"] <- max(amplitude_risk, phase_risk) + if (amplitude_risk > 0) reasons <- c(reasons, "seasonal_amplitude") + if (phase_risk > 0) reasons <- c(reasons, "seasonal_phase") + } + } else if (strong_seasonality && !is.null(reference$short_seasonality) && + length(path) == length(reference$short_seasonality$profile)) { + short_reference <- reference$short_seasonality + future_profile <- path - short_reference$trend * seq_along(path) + future_profile <- future_profile - mean(future_profile) + historical_amplitude <- diff(range(short_reference$profile)) + future_amplitude <- diff(range(future_profile)) + seasonal_fidelity <- min(.Machine$double.xmax, + max(0, (abs(future_amplitude - historical_amplitude) - short_reference$amplitude_tolerance) / + historical_amplitude)) + if (future_amplitude > short_reference$phase_noise) { + phase_correlation <- stats::cor(short_reference$profile, future_profile) + if (is.finite(phase_correlation)) { + components["seasonality"] <- max(0, -phase_correlation) + if (components["seasonality"] > 0) reasons <- c(reasons, "seasonal_phase") + } + } + } + } + components[is.infinite(components)] <- .Machine$double.xmax + list(risk = max(c(0, components), na.rm = TRUE), reasons = reasons, components = components, + seasonal_fidelity = seasonal_fidelity) +} + +prepare_forecast_evaluation <- function(history, context) { + history$Date <- as.Date(history$Date) + cutoff <- as.Date(context$hist_end_date) + history <- history[history$Date <= cutoff, , drop = FALSE] + history <- history[order(history$Date), , drop = FALSE] + if (anyNA(history$Date) || anyDuplicated(history$Date) || !any(is.finite(history$Target))) { + stop("Forecast selection requires unique dated historical actuals.", call. = FALSE) + } + expected_backtests <- forecast_selection_keys(context, "Back_Test") + expected_forecasts <- forecast_selection_keys(context, "Future_Forecast") + list(history = history, expected_backtests = expected_backtests, + expected_forecasts = expected_forecasts, + reference = forecast_reference(history, nrow(expected_forecasts), context)) +} + +forecast_backtest_accuracy <- function(history, backtest) { + actuals <- history$Target[match(as.Date(backtest$Date), as.Date(history$Date))] + target <- ifelse(actuals == 0, 0.1, actuals) + valid_target <- is.finite(target) + weighted_mape <- NA_real_ + log_weight <- NA_real_ + if (all(is.finite(backtest$Forecast)) && any(valid_target)) { + target <- target[valid_target] + errors <- round(abs((backtest$Forecast[valid_target] - target) / abs(target)), 4) + weights <- abs(target) / max(abs(target)) + weighted_mape <- sum(errors * (weights / sum(weights))) + log_weight <- log(max(abs(target))) + log(sum(weights)) + } + list(WMAPE = weighted_mape, Log_Weight = log_weight) +} + +evaluate_forecast_candidates <- function(history, backtests, forecasts, context) { + evaluation <- context$forecast_evaluation %||% prepare_forecast_evaluation(history, context) + history <- evaluation$history + expected_backtests <- evaluation$expected_backtests + expected_forecasts <- evaluation$expected_forecasts + candidate_ids <- context$candidate_ids + if (is.null(candidate_ids)) candidate_ids <- unique(c(backtests$Model_ID, forecasts$Model_ID)) + candidate_ids <- sort(unique(as.character(candidate_ids)), method = "radix") + if (length(candidate_ids) == 0L) { + stop("Forecast selection requires at least one candidate.", call. = FALSE) + } + if (anyNA(candidate_ids) || any(!nzchar(candidate_ids))) stop("Candidate identities must be nonmissing.", call. = FALSE) + reference <- evaluation$reference + rankings <- lapply(candidate_ids, function(candidate_id) { + backtest_indices <- which(backtests$Model_ID == candidate_id) + future_indices <- which(forecasts$Model_ID == candidate_id) + future_indices <- future_indices[order(forecasts$Date[future_indices])] + backtest <- list(Train_Test_ID = backtests$Train_Test_ID[backtest_indices], + Date = backtests$Date[backtest_indices], Forecast = backtests$Forecast[backtest_indices]) + future <- list(Train_Test_ID = forecasts$Train_Test_ID[future_indices], + Date = forecasts$Date[future_indices], Forecast = forecasts$Forecast[future_indices]) + reasons <- character() + if (!forecast_keys_complete(backtest, expected_backtests)) reasons <- c(reasons, "incomplete_backtests") + if (!forecast_keys_complete(future, expected_forecasts)) reasons <- c(reasons, "incomplete_forecast") + predictions <- c(backtest$Forecast, future$Forecast) + if (any(!is.finite(predictions))) reasons <- c(reasons, "nonfinite_forecast") + if (reference$normalization > 0 && reference$scale > 0) { + extreme_backtest <- any(abs(backtest$Forecast / reference$normalization) / reference$scale > 100, na.rm = TRUE) + trend <- reference$trend + if (is.null(trend) || length(future$Forecast) != length(trend$log_magnitude_scale)) { + extreme_future <- any(abs(future$Forecast / reference$normalization) / reference$scale > 100, na.rm = TRUE) + } else { + log_forecast <- log(abs(future$Forecast)) + precision <- 8 * .Machine$double.eps * pmax(1, abs(log_forecast), abs(trend$log_magnitude_scale)) + extreme_future <- any(log_forecast - trend$log_magnitude_scale > log(100) + precision, na.rm = TRUE) + } + if (extreme_backtest || extreme_future) reasons <- c(reasons, "catastrophic_magnitude") + } + accuracy <- forecast_backtest_accuracy(history, backtest) + if (!is.finite(accuracy$WMAPE)) reasons <- c(reasons, "unavailable_accuracy") + risk <- forecast_path_risk(if (length(reasons) == 0) future$Forecast else numeric(), reference) + tibble::new_tibble(list( + Model_ID = candidate_id, Eligible = length(reasons) == 0, + WMAPE = accuracy$WMAPE, Log_Weight = accuracy$Log_Weight, Risk = risk$risk, + Violations = length(risk$reasons), Reasons = list(c(reasons, risk$reasons)), + Checks = list(risk$components), Seasonal_Fidelity = risk$seasonal_fidelity + ), nrow = 1L) + }) + if (length(rankings) == 1) rankings[[1]] else dplyr::bind_rows(rankings) +} + +order_forecast_candidates <- function(rankings) { + indices <- order(!rankings$Eligible, rankings$Risk, rankings$Violations, + rankings$WMAPE, rankings$Model_ID, method = "radix", na.last = TRUE) + if (length(indices) < 2L || !"Seasonal_Fidelity" %in% names(rankings)) return(indices) + ordered <- rankings[indices, , drop = FALSE] + same_tier <- utils::head(ordered$Eligible, -1) == utils::tail(ordered$Eligible, -1) & + utils::head(ordered$Risk, -1) == utils::tail(ordered$Risk, -1) & + utils::head(ordered$Violations, -1) == utils::tail(ordered$Violations, -1) + same_tier[is.na(same_tier)] <- FALSE + groups <- split(seq_along(indices), cumsum(c(TRUE, !same_tier))) + for (positions in groups) { + fidelity <- ordered$Seasonal_Fidelity[positions] + if (all(is.finite(fidelity) & fidelity >= 0)) { + indices[positions] <- indices[positions][order(fidelity, ordered$WMAPE[positions], + ordered$Model_ID[positions], method = "radix", na.last = TRUE)] + } + } + indices +} + +rank_forecast_candidates <- function(rankings) { + if (nrow(rankings) == 1) { + selected_id <- if (isTRUE(rankings$Eligible[1]) && is.finite(rankings$WMAPE[1])) { + rankings$Model_ID[1] + } else NA_character_ + return(list(selected_id = selected_id, rankings = rankings)) + } + eligible <- rankings[rankings$Eligible, , drop = FALSE] + selected_id <- NA_character_ + if (nrow(eligible) > 0) { + best_accuracy <- min(eligible$WMAPE) + ceiling <- best_accuracy + max(0.005, 0.05 * best_accuracy) + tolerance <- 8 * .Machine$double.eps * max(1, abs(ceiling)) + shortlist <- eligible[eligible$WMAPE <= ceiling + tolerance, , drop = FALSE] + shortlist <- shortlist[order_forecast_candidates(shortlist), , drop = FALSE] + selected_id <- shortlist$Model_ID[1] + } + rankings <- rankings[order_forecast_candidates(rankings), , drop = FALSE] + list(selected_id = selected_id, rankings = rankings) +} + +select_forecast_candidate <- function(history, backtests, forecasts, context) { + rank_forecast_candidates(evaluate_forecast_candidates(history, backtests, forecasts, context)) +} + +select_series_forecasts <- function(predictions, series_data, splits, + candidate_ids = unique(predictions$Model_ID), + selector = select_forecast_candidate) { + context <- series_data + context$train_test_split <- splits + context$candidate_ids <- candidate_ids + backtest_ids <- splits$Train_Test_ID[splits$Run_Type == "Back_Test"] + future_ids <- splits$Train_Test_ID[splits$Run_Type == "Future_Forecast"] + predictions$Date <- as.Date(predictions$Date) + result <- selector( + series_data$history, + predictions[predictions$Train_Test_ID %in% backtest_ids, , drop = FALSE], + predictions[predictions$Train_Test_ID %in% future_ids, , drop = FALSE], + context + ) + validate_forecast_selection(result, candidate_ids) +} + +screen_ensemble_inputs <- function(predictions, series_data, splits) { + selection <- select_series_forecasts(predictions, series_data, splits) + valid_ids <- selection$rankings$Model_ID[selection$rankings$Eligible] + predictions <- predictions[predictions$Model_ID %in% valid_ids, , drop = FALSE] + expected <- unique(predictions[, c("Train_Test_ID", "Date"), drop = FALSE]) + valid_ids <- valid_ids[vapply(valid_ids, function(model_id) { + rows <- predictions[predictions$Model_ID == model_id, , drop = FALSE] + all(is.finite(rows$Forecast)) && forecast_keys_complete(rows, expected) + }, logical(1))] + predictions[predictions$Model_ID %in% valid_ids, , drop = FALSE] +} + +validate_forecast_selection <- function(selection, candidate_ids) { + if (!is.list(selection) || length(selection$selected_id) != 1 || + !is.data.frame(selection$rankings) || + !all(c("Model_ID", "Eligible", "WMAPE", "Risk", "Violations", "Reasons") %in% names(selection$rankings)) || + anyDuplicated(selection$rankings$Model_ID) || + anyNA(selection$rankings$Eligible) || + !setequal(selection$rankings$Model_ID, candidate_ids) || + (!is.na(selection$selected_id) && !selection$selected_id %in% candidate_ids)) { + stop("The forecast selector returned an invalid selection contract.", call. = FALSE) + } + if (!is.na(selection$selected_id) && + !isTRUE(selection$rankings$Eligible[match(selection$selected_id, selection$rankings$Model_ID)])) { + stop("The forecast selector selected an ineligible candidate.", call. = FALSE) + } + selection +} + +abort_forecast_selection <- function(combo, selection) { + rlang::abort( + paste0("No acceptable forecast candidate for series '", combo, "': ", + paste(unique(unlist(selection$rankings$Reasons)), collapse = ", "), "."), + class = "finnts_forecast_selection_rejected", combo = combo, selection = selection + ) +} + +selection_worker_result <- function(combo, selection = NULL, reused = FALSE) { + result <- data.frame(Combo = combo, stringsAsFactors = FALSE) + result$Selection <- list(selection) + result$Reused <- reused + result +} + +rejected_agent_selection <- function(combos, reason) { + selections <- stats::setNames(lapply(combos, function(combo) { + list(selected_id = NA_character_, rankings = tibble::tibble( + Model_ID = "Rejected", Eligible = FALSE, WMAPE = NA_real_, Risk = 0, + Violations = 0L, Reasons = list(reason) + )) + }), combos) + list(selections = selections, rejected_combos = combos, unpublished = TRUE) +} + +write_rejected_forecasts <- function(tables, run_info, combo, splits, date_type, weekly_to_daily) { + for (suffix in names(tables)) { + rows <- tables[[suffix]] + if (is.null(rows) || nrow(rows) == 0) next + rows$Best_Model <- "No" + rows <- convert_weekly_to_daily(create_prediction_intervals(rows, splits), date_type, weekly_to_daily) + write_data(rows, combo = combo, run_info = run_info, output_type = "data", folder = "forecasts", suffix = suffix) + } +} + +native_forecast_rows <- function(rows, date_type) { + if (identical(date_type, "week") && "Date_Day" %in% names(rows)) { + invalid <- !is.finite(rows$Forecast) + if (any(invalid)) { + groups <- dplyr::group_indices(dplyr::group_by(rows, Combo, Model_ID, Train_Test_ID, Date)) + invalid_values <- vapply(split(rows$Forecast[invalid], groups[invalid]), sum, numeric(1)) + matched <- match(groups, names(invalid_values)) + affected <- !is.na(matched) + rows$Forecast[affected] <- invalid_values[matched[affected]] + } + rows <- rows[!duplicated(rows[, c("Combo", "Model_ID", "Train_Test_ID", "Date")]), , drop = FALSE] + rows$Forecast <- rows$Forecast * 7 + rows$Target <- rows$Target * 7 + rows$Date_Day <- NULL + } + rows +} + +read_candidate_forecasts <- function(run_info, combos, run_log = NULL, cache = NULL, reconciled = TRUE) { + if (is.null(run_log)) run_log <- read_selection_file(run_info, "logs", cache = cache) + if (reconciled && !identical(run_log$forecast_approach, "bottoms_up")) { + rows <- read_selection_file(run_info, "forecasts", "-reconciled", "Best-Model", cache = cache) + rows <- rows[rows$Combo %in% combos, , drop = FALSE] + } else { + rows <- dplyr::bind_rows(lapply(combos, function(combo) { + suffixes <- c( + if (isTRUE(as.logical(run_log$run_local_models))) "-single_models", + if (isTRUE(as.logical(run_log$run_global_models))) "-global_models", + if (isTRUE(as.logical(run_log$run_ensemble_models))) "-ensemble_models", + if (isTRUE(as.logical(run_log[["average_models"]]))) "-average_models" + ) + dplyr::bind_rows(lapply(suffixes, function(suffix) { + read_selection_file(run_info, "forecasts", suffix, combo, optional = TRUE, cache = cache) + })) + })) + } + if (nrow(rows) == 0) stop("No candidate forecasts were found in the exact run artifacts.", call. = FALSE) + rows$Date <- as.Date(rows$Date) + native_forecast_rows(rows, run_log$date_type) +} + +read_final_predictions <- function(run_info, combo_hash, suffix) { + filename <- paste0(hash_data(run_info$project_name), "-", hash_data(run_info$run_name), + "-", combo_hash, suffix, ".", run_info$data_output) + path <- fs::path(run_info$path, "forecasts", filename) + if (is.null(run_info$storage_object) && !file.exists(path)) return(NULL) + rows <- read_exact_artifact(run_info, file_list = path, return_type = "df") + if (!is.data.frame(rows) || !nrow(rows)) { + stop("The model prediction artifact is empty or unreadable: ", filename, call. = FALSE) + } + rows +} + +completed_forecast_selection <- function(predictions, series, splits) { + required <- c("Best_Model", "Model_ID", "Train_Test_ID", "Date", "Forecast", + "lo_80", "lo_95", "hi_80", "hi_95") + if (!is.data.frame(predictions) || !nrow(predictions) || !all(required %in% names(predictions)) || + anyNA(predictions$Best_Model) || any(!predictions$Best_Model %in% c("Yes", "No"))) { + return(NULL) + } + selection <- selected_forecast_accuracy(predictions, series, splits) + if (is.na(selection$selected_id)) return(NULL) + components <- strsplit(selection$selected_id, "_", fixed = TRUE)[[1]] + if (length(components) > 1) { + missing <- setdiff(components, unique(predictions$Model_ID)) + if (length(missing)) { + stop("Saved average component predictions are missing: ", paste(missing, collapse = ", "), + ". Restore the original model outputs before retrying.", call. = FALSE) + } + for (component in components) { + rows <- predictions[predictions$Model_ID == component, , drop = FALSE] + rows$Best_Model <- "Yes" + if (is.na(selected_forecast_accuracy(rows, series, splits)$selected_id)) return(NULL) + } + required_ids <- splits$Train_Test_ID[splits$Run_Type %in% c("Back_Test", "Future_Forecast")] + average <- predictions[predictions$Model_ID %in% components & predictions$Train_Test_ID %in% required_ids, ] %>% + dplyr::group_by(Train_Test_ID, Date) %>% + dplyr::summarise(Forecast = mean(Forecast), .groups = "drop") %>% + dplyr::arrange(Train_Test_ID, Date) + saved <- predictions[predictions$Model_ID == selection$selected_id & predictions$Train_Test_ID %in% required_ids, ] %>% + dplyr::arrange(Train_Test_ID, Date) + if (!isTRUE(all.equal(average$Forecast, saved$Forecast, check.attributes = FALSE))) return(NULL) + } + selection +} + +unfinalized_forecast_rows <- function(rows, date_type) { + if (is.null(rows) || !nrow(rows)) return(NULL) + rows <- native_forecast_rows(rows, date_type) + rows[, setdiff(names(rows), c("Best_Model", "lo_80", "lo_95", "hi_80", "hi_95", "Run_Type")), drop = FALSE] +} + +selected_forecast_accuracy <- function(predictions, series, splits, require_forecast = TRUE) { + series$train_test_split <- splits + selected <- if ("Best_Model" %in% names(predictions)) { + predictions[!is.na(predictions$Best_Model) & predictions$Best_Model == "Yes", , drop = FALSE] + } else predictions[0, , drop = FALSE] + selected_ids <- unique(as.character(selected$Model_ID)) + backtest <- selected[selected$Train_Test_ID %in% splits$Train_Test_ID[splits$Run_Type == "Back_Test"], , drop = FALSE] + future <- selected[selected$Train_Test_ID %in% splits$Train_Test_ID[splits$Run_Type == "Future_Forecast"], , drop = FALSE] + reasons <- character() + if (length(selected_ids) != 1 || anyNA(selected_ids) || any(!nzchar(selected_ids))) { + reasons <- c(reasons, "missing_or_ambiguous_winner") + } + if (!forecast_keys_complete(backtest, forecast_selection_keys(series, "Back_Test"))) { + reasons <- c(reasons, "incomplete_backtests") + } + if (require_forecast && !forecast_keys_complete(future, forecast_selection_keys(series, "Future_Forecast"))) { + reasons <- c(reasons, "incomplete_forecast") + } + if (any(!is.finite(backtest$Forecast)) || (require_forecast && any(!is.finite(future$Forecast)))) { + reasons <- c(reasons, "nonfinite_forecast") + } + accuracy <- forecast_backtest_accuracy(series$history, backtest) + if (!is.finite(accuracy$WMAPE)) reasons <- c(reasons, "unavailable_accuracy") + model_id <- if (length(selected_ids) == 1 && !anyNA(selected_ids)) selected_ids else "Unselected" + rankings <- tibble::tibble(Model_ID = model_id, Eligible = length(reasons) == 0, + WMAPE = accuracy$WMAPE, Log_Weight = accuracy$Log_Weight, + Risk = NA_real_, Violations = NA_integer_, Reasons = list(reasons), + Checks = list(numeric()), Seasonal_Fidelity = NA_real_) + list(selected_id = if (rankings$Eligible) model_id else NA_character_, rankings = rankings) +} + +assess_agent_run <- function(run_info, run_log, combos, cache = new.env(parent = emptyenv()), + check_quality = FALSE) { + hierarchical <- !identical(run_log$forecast_approach, "bottoms_up") + splits <- read_selection_file(run_info, "prep_models", "-train_test_split", cache = cache) + if (hierarchical && !check_quality) { + rows <- read_candidate_forecasts(run_info, combos, run_log, cache) + result <- hierarchical_selection_result(run_info, run_log, list(), rows, splits, combos, cache) + result$run_info <- run_info + result$run_log <- run_log + result$forecasts <- rows + return(result) + } + source_combos <- if (hierarchical) read_selection_hierarchy(run_info, cache)$hts_combos else combos + rows <- read_candidate_forecasts(run_info, source_combos, run_log, cache, reconciled = !hierarchical) + selections <- stats::setNames(lapply(source_combos, function(combo) { + series <- read_series_history(run_info, combo, run_log, cache) + predictions <- rows[rows$Combo == combo, , drop = FALSE] + if (!check_quality) return(selected_forecast_accuracy(predictions, series, splits)) + selected <- if ("Best_Model" %in% names(predictions)) predictions[!is.na(predictions$Best_Model) & predictions$Best_Model == "Yes", , drop = FALSE] else predictions[0, ] + selection <- select_series_forecasts( + if (nrow(selected)) selected else predictions, series, splits + ) + if (nrow(selected) == 0) selection$selected_id <- NA_character_ + selection + }), source_combos) + result <- list(selections = selections, source_selections = NULL, rejected_combos = character()) + if (hierarchical) { + rows <- read_candidate_forecasts(run_info, combos, run_log, cache) + result <- hierarchical_selection_result(run_info, run_log, selections, rows, splits, combos, cache) + } + result$run_info <- run_info + result$run_log <- run_log + result$forecasts <- rows + result +} + +hierarchical_selection_result <- function(run_info, run_log, source_selections, forecasts, splits, + combos = NULL, cache = new.env(parent = emptyenv())) { + hierarchy <- read_selection_hierarchy(run_info, cache) + if (is.null(combos)) combos <- hierarchy$original_combos + stored_combos <- utils::tail(hierarchy$hts_combos, length(hierarchy$original_combos)) + if (anyNA(match(combos, hierarchy$original_combos))) stop("Unknown original hierarchy series.", call. = FALSE) + forecasts <- native_forecast_rows(forecasts, run_log$date_type) + selections <- stats::setNames(lapply(combos, function(combo) { + stored <- stored_combos[match(combo, hierarchy$original_combos)] + series <- read_series_history(run_info, stored, run_log, cache) + selected_forecast_accuracy(forecasts[forecasts$Combo == combo, , drop = FALSE], + series, splits, require_forecast = FALSE) + }), combos) + list(selections = selections, source_selections = source_selections, + rejected_combos = names(selections)[vapply(selections, function(selection) is.na(selection$selected_id), logical(1))]) +} + +agent_selection_summary <- function(result, check_quality = FALSE) { + chosen <- lapply(result$selections, function(selection) { + if (is.null(selection) || is.na(selection$selected_id)) return(NULL) + if (nrow(selection$rankings) == 1 && identical(selection$rankings$Model_ID, selection$selected_id)) { + return(selection$rankings) + } + selection$rankings[selection$rankings$Model_ID == selection$selected_id, , drop = FALSE] + }) + rows <- dplyr::bind_rows(chosen) + complete <- length(chosen) > 0 && nrow(rows) == length(chosen) && + all(rows$Eligible) && all(is.finite(rows$WMAPE)) + source <- if (check_quality && length(result$source_selections)) { + agent_selection_summary(list(selections = result$source_selections), check_quality = TRUE) + } else NULL + if (!is.null(source)) complete <- complete && is.finite(source$weighted_mape) + weights <- if (nrow(rows) && "Log_Weight" %in% names(rows) && all(is.finite(rows$Log_Weight))) { + exp(rows$Log_Weight - max(rows$Log_Weight)) + } else rep(1, nrow(rows)) + fidelity <- rows[["Seasonal_Fidelity"]] + list( + weighted_mape = if (complete) sum(rows$WMAPE * weights) / sum(weights) else Inf, + acceptable = complete && (!check_quality || isTRUE(result$quality_accepted) || + (all(!is.na(rows$Violations) & rows$Violations == 0) && (is.null(source) || source$acceptable))), + status = if (complete) "evaluated" else if (nrow(rows)) "partial" else "rejected", + risk = if (!is.null(source)) source$risk else if (nrow(rows)) max(rows$Risk) else 0, + violations = if (!is.null(source)) source$violations else if (nrow(rows)) sum(rows$Violations) else 0L, + seasonal_fidelity = if (!is.null(source)) source$seasonal_fidelity else + if (complete && length(fidelity) == nrow(rows) && all(is.finite(fidelity) & fidelity >= 0)) { + max(fidelity) + } else NA_real_ + ) +} + +rank_agent_run_selections <- function(results) { + best_accuracy <- function(rankings) { + if (!nrow(rankings)) return(NA_integer_) + rankings <- rankings[!is.na(rankings$Eligible) & rankings$Eligible & is.finite(rankings$WMAPE), , drop = FALSE] + if (!nrow(rankings)) return(NA_integer_) + as.integer(rankings$Model_ID[which.min(rankings$WMAPE)]) + } + combos <- unique(unlist(lapply(results, function(result) names(result$selections)))) + series_winners <- stats::setNames(lapply(combos, function(combo) { + rankings <- dplyr::bind_rows(lapply(seq_along(results), function(run_index) { + selection <- results[[run_index]]$selections[[combo]] + if (is.null(selection) || is.na(selection$selected_id)) return(NULL) + row <- selection$rankings[selection$rankings$Model_ID == selection$selected_id, , drop = FALSE] + row$Model_ID <- sprintf("%08d", run_index) + row + })) + best_accuracy(rankings) + }), combos) + aggregate <- dplyr::bind_rows(lapply(seq_along(results), function(run_index) { + result <- results[[run_index]] + summary <- agent_selection_summary(list(selections = result$selections)) + tibble::tibble(Model_ID = sprintf("%08d", run_index), + Eligible = is.finite(summary$weighted_mape) && setequal(names(result$selections), combos), + WMAPE = summary$weighted_mape) + })) + list(series = series_winners, best_run_index = best_accuracy(aggregate)) +} + +agent_selection_pool <- function(agent_info, run_logs, combos, cache = new.env(parent = emptyenv())) { + if (!is.data.frame(run_logs) || nrow(run_logs) == 0) return(list()) + run_logs <- run_logs[run_logs$agent_version == agent_info$agent_version, , drop = FALSE] + run_logs <- run_logs[order(run_logs$created, run_logs$run_name), , drop = FALSE] + lapply(seq_len(nrow(run_logs)), function(run_index) { + log <- run_logs[run_index, , drop = FALSE] + info <- agent_info$project_info + info$project_name <- log$project_name + info$run_name <- log$run_name + key <- paste0("selection:", info$project_name, ":", info$run_name, ":", paste(combos, collapse = "|")) + if (exists(key, cache, inherits = FALSE)) return(get(key, cache, inherits = FALSE)) + result <- if (identical(as.character(log$selection_status), "rejected")) { + selections <- stats::setNames(lapply(combos, function(combo) { + list(selected_id = NA_character_, rankings = tibble::tibble( + Model_ID = "Rejected", Eligible = FALSE, WMAPE = NA_real_, Risk = 0, + Violations = 0L, Reasons = list("rejected_evaluation") + )) + }), combos) + list(selections = selections, run_info = info, run_log = log) + } else assess_agent_run(info, log, combos, cache) + assign(key, result, cache) + result + }) +} + +agent_selection_combos <- function(agent_info, combo = NULL) { + known <- agent_info$selection_combos + if (is.null(combo) && length(known)) return(known) + if (!is.null(combo) && length(known)) { + hashes <- vapply(known, hash_data, character(1), USE.NAMES = FALSE) + matched <- known[hashes == combo] + if (length(matched)) return(matched) + } + if (is.null(combo)) stop("Global selection requires the known series list.", call. = FALSE) + info <- agent_info$project_info + filename <- paste0(hash_data(info$project_name), "-", hash_data(agent_info$run_id), "-", combo, ".", info$data_output) + input <- read_exact_artifact(info, file_list = fs::path(info$path, "input_data", filename), return_type = "df") + combos <- unique(as.character(input$Combo)) + if (length(combos) != 1 || is.na(combos)) stop("Unable to identify the exact series for selection.", call. = FALSE) + combos +} + +read_selection_file <- function(run_info, folder, suffix = NULL, combo = NULL, + optional = FALSE, cache = NULL) { + prefix <- paste0(hash_data(run_info$project_name), "-", hash_data(run_info$run_name)) + extension <- if (folder == "logs") "csv" else run_info$data_output + filename <- paste0(prefix, if (!is.null(combo)) paste0("-", hash_data(combo)), suffix, ".", extension) + path <- fs::path(run_info$path, folder, filename) + if (!is.null(cache) && exists(path, cache, inherits = FALSE)) return(get(path, cache, inherits = FALSE)) + result <- read_exact_artifact(run_info, file_list = path, allow_missing = optional) + if (optional && is.null(result)) return(tibble::tibble()) + if (!is.data.frame(result) || nrow(result) == 0) { + stop("The exact forecast artifact is empty or unreadable: ", filename, call. = FALSE) + } + if (!is.null(cache)) assign(path, result, cache) + result +} + +read_selection_hierarchy <- function(run_info, cache = NULL) { + filename <- paste0(hash_data(run_info$project_name), "-", hash_data(run_info$run_name), + "-hts_info.", run_info$object_output) + path <- fs::path(run_info$path, "prep_data", filename) + if (!is.null(cache) && exists(path, cache, inherits = FALSE)) return(get(path, cache, inherits = FALSE)) + hierarchy <- read_exact_artifact(run_info, file_list = path, return_type = "object") + if (!is.list(hierarchy) || !all(c("original_combos", "hts_combos") %in% names(hierarchy))) { + stop("Hierarchy metadata is missing the original series mapping.", call. = FALSE) + } + if (!is.null(cache)) assign(path, hierarchy, cache) + hierarchy +} + +assess_update_forecasts <- function(forecasts, run_info, run_log, splits, + expected_components = NULL, cache = new.env(parent = emptyenv()), + combos = NULL) { + hierarchical <- !is.null(run_log[["forecast_approach"]]) && !identical(run_log$forecast_approach, "bottoms_up") + hierarchy <- if (hierarchical) read_selection_hierarchy(run_info, cache) else NULL + if (is.null(combos)) combos <- if (hierarchical) hierarchy$original_combos else unique(as.character(forecasts$Combo)) + if (hierarchical && !setequal(unique(as.character(forecasts$Combo)), hierarchy$hts_combos)) { + return(list(forecasts = forecasts[0, ], source_forecasts = forecasts, selections = list(), + source_selections = NULL, quality_rejected_combos = vapply(combos, hash_data, character(1), USE.NAMES = FALSE))) + } + if (!hierarchical) forecasts <- forecasts[forecasts$Combo %in% combos, , drop = FALSE] + accepted <- character() + rejected <- if (hierarchical) character() else setdiff(combos, unique(as.character(forecasts$Combo))) + selections <- list() + for (combo in unique(as.character(forecasts$Combo))) { + rows <- forecasts[forecasts$Combo == combo, , drop = FALSE] + series <- read_series_history(run_info, combo, run_log, cache) + selection <- select_series_forecasts(rows, series, splits) + selected_ids <- unique(rows$Model_ID[rows$Best_Model == "Yes"]) + components <- unique(rows$Model_ID[!is.na(rows$Recipe_ID) & rows$Recipe_ID != "simple_average"]) + required_components <- if (is.list(expected_components)) expected_components[[combo]] else expected_components + if (!is.null(required_components)) components <- unique(c(components, required_components)) + required <- unique(c(components, selected_ids)) + required_rows <- match(required, selection$rankings$Model_ID) + hard_pass <- length(selected_ids) == 1 && !anyNA(required_rows) && all(selection$rankings$Eligible[required_rows]) + delivered <- selection$rankings[selection$rankings$Model_ID %in% selected_ids, , drop = FALSE] + if (hard_pass && nrow(delivered) == 1 && delivered$Violations == 0) { + accepted <- c(accepted, combo) + selection$selected_id <- selected_ids + } else { + rejected <- c(rejected, combo) + } + selections[[combo]] <- selection + } + result <- list( + forecasts = forecasts[forecasts$Combo %in% accepted, , drop = FALSE], + quality_rejected_combos = vapply(rejected, hash_data, character(1), USE.NAMES = FALSE), + selections = selections, source_selections = NULL, source_forecasts = forecasts + ) + if (hierarchical) { + if (length(rejected)) { + result$forecasts <- forecasts[0, ] + result$quality_rejected_combos <- vapply(combos, hash_data, character(1), USE.NAMES = FALSE) + return(result) + } + result$forecasts <- reconcile(forecasts[forecasts$Best_Model == "Yes", , drop = FALSE], + run_info, run_log$forecast_approach, run_log$negative_forecast) + result$forecasts <- result$forecasts[result$forecasts$Combo %in% combos, , drop = FALSE] + selected <- hierarchical_selection_result(run_info, run_log, selections, result$forecasts, splits, combos, cache) + result$selections <- selected$selections + result$source_selections <- selections + } + result +} + +best_agent_iteration <- function(run_logs, agent_version = NULL) { + if (!is.data.frame(run_logs) || !nrow(run_logs) || !"weighted_mape" %in% names(run_logs)) { + return(NA_integer_) + } + accuracy <- as.numeric(run_logs$weighted_mape) + eligible <- is.finite(accuracy) + if (!is.null(agent_version)) { + eligible <- eligible & !is.na(run_logs$agent_version) & + as.numeric(run_logs$agent_version) == as.numeric(agent_version) + } + if ("selection_status" %in% names(run_logs)) { + eligible <- eligible & !run_logs$selection_status %in% c("partial", "rejected") + } + eligible <- which(eligible) + if (!length(eligible)) return(NA_integer_) + winner <- eligible[which.min(accuracy[eligible])] + average <- as.numeric(run_logs[["model_avg_wmape"]]) + if (length(average) == nrow(run_logs) && is.finite(average[winner])) { + later <- eligible[eligible > winner & + abs(accuracy[eligible] - accuracy[winner]) <= accuracy[winner] * 0.10 & + is.finite(average[eligible]) & average[eligible] < average[winner]] + if (length(later)) winner <- later[which.min(average[later])] + } + as.integer(winner) +} + +validate_global_iteration <- function(best_runs) { + if (!is.data.frame(best_runs) || !nrow(best_runs) || !"model_type" %in% names(best_runs)) { + return(invisible(best_runs)) + } + global <- best_runs[!is.na(best_runs$model_type) & best_runs$model_type == "global", , drop = FALSE] + if (!nrow(global)) return(invisible(best_runs)) + runs <- unique(as.character(global[["best_run_name"]])) + if (length(runs) != 1L || anyNA(runs) || !nzchar(runs)) { + stop("All global winners must reference a single global iteration. Restore one complete global best run before continuing.", + call. = FALSE) + } + invisible(best_runs) +} + +agent_forecast_accuracy <- function(forecasts, combos) { + accuracy <- list(weighted_mape = Inf, + by_series = stats::setNames(rep(Inf, length(combos)), combos)) + required <- c("Combo", "Run_Type", "Best_Model", "Target", "Forecast") + if (!length(combos) || !is.data.frame(forecasts) || !all(required %in% names(forecasts)) || + !is.numeric(forecasts$Target) || !is.numeric(forecasts$Forecast)) return(accuracy) + rows <- forecasts[!is.na(forecasts$Run_Type) & forecasts$Run_Type == "Back_Test" & + !is.na(forecasts$Best_Model) & forecasts$Best_Model == "Yes" & + forecasts$Combo %in% combos, , drop = FALSE] + if (!nrow(rows)) return(accuracy) + target <- ifelse(rows$Target == 0, 0.1, rows$Target) + errors <- round(abs((rows$Forecast - target) / abs(target)), 4) + score <- function(indices) { + if (any(!is.finite(rows$Forecast[indices]))) return(Inf) + indices <- indices[is.finite(target[indices])] + if (!length(indices)) return(Inf) + value <- round(sum(errors[indices] * abs(target[indices]) / sum(abs(target[indices]))), 4) + if (is.finite(value)) value else Inf + } + by_series <- vapply(split(seq_len(nrow(rows)), as.character(rows$Combo)), score, numeric(1)) + accuracy$by_series[names(by_series)] <- by_series + if (all(is.finite(accuracy$by_series))) accuracy$weighted_mape <- score(seq_len(nrow(rows))) + accuracy +} + +agent_model_accuracy <- function(forecasts) { + unavailable <- list(model_avg_wmape = NA_real_, model_median_wmape = NA_real_, + model_std_wmape = NA_real_) + required <- c("Model_ID", "Recipe_ID", "Run_Type", "Target", "Forecast") + if (!is.data.frame(forecasts) || !all(required %in% names(forecasts))) return(unavailable) + rows <- forecasts[!is.na(forecasts$Run_Type) & forecasts$Run_Type == "Back_Test" & + !is.na(forecasts$Recipe_ID) & forecasts$Recipe_ID != "simple_average", , drop = FALSE] + if (!nrow(rows) || anyNA(rows$Model_ID) || any(!nzchar(as.character(rows$Model_ID)))) return(unavailable) + if ("Model_Type" %in% names(rows) && all(!is.na(rows$Model_Type) & rows$Model_Type == "global")) { + return(unavailable) + } + accuracy <- vapply(split(seq_len(nrow(rows)), as.character(rows$Model_ID)), function(indices) { + target <- ifelse(rows$Target[indices] == 0, 0.1, rows$Target[indices]) + observed <- is.finite(target) + if (!any(observed) || any(!is.finite(rows$Forecast[indices]))) return(NA_real_) + target <- target[observed] + errors <- round(abs((rows$Forecast[indices][observed] - target) / abs(target)), 4) + weights <- abs(target) / max(abs(target)) + sum(errors * (weights / sum(weights))) + }, numeric(1)) + if (any(!is.finite(accuracy))) return(unavailable) + list(model_avg_wmape = mean(accuracy), model_median_wmape = stats::median(accuracy), + model_std_wmape = stats::sd(accuracy)) +} + +record_agent_selection_attempt <- function(run_log, result, agent_info, model_accuracy = NULL, + forecast_accuracy = NULL) { + summary <- agent_selection_summary(result) + accuracy <- if (is.null(forecast_accuracy)) summary$weighted_mape else forecast_accuracy$weighted_mape + run_log$weighted_mape <- if (isTRUE(summary$acceptable) && length(accuracy) == 1L && is.finite(accuracy)) { + round(accuracy, 4) + } else NA_real_ + run_log$selection_status <- if (isTRUE(summary$acceptable) && !is.finite(run_log$weighted_mape)) { + "rejected" + } else summary$status + if (isTRUE(as.logical(run_log[["run_global_models"]]))) { + run_log$model_avg_wmape <- run_log$weighted_mape + run_log$model_median_wmape <- run_log$weighted_mape + run_log$model_std_wmape <- 0 + } else { + run_log$model_avg_wmape <- model_accuracy$model_avg_wmape %||% NA_real_ + run_log$model_median_wmape <- model_accuracy$model_median_wmape %||% NA_real_ + run_log$model_std_wmape <- model_accuracy$model_std_wmape %||% NA_real_ + } + run_log$agent_version <- as.numeric(agent_info$agent_version) + run_log$agent_forecast_approach <- agent_info$forecast_approach + run_log +} + +read_selected_agent_forecasts <- function(run_info, combos, combo_variables) { + run_log <- read_selection_file(run_info, "logs") + rows <- read_candidate_forecasts(run_info, combos, run_log) + splits <- read_selection_file(run_info, "prep_models", "-train_test_split") + rows <- create_prediction_intervals(rows, splits) + rows <- convert_weekly_to_daily(rows, run_log$date_type, isTRUE(as.logical(run_log$weekly_to_daily))) + rows <- rows %>% + dplyr::select(-tidyselect::any_of(c("Run_Type", "Combo_ID", "Hyperparameter_ID"))) %>% + dplyr::left_join(splits[, c("Train_Test_ID", "Run_Type")], by = "Train_Test_ID") %>% + tidyr::separate(Combo, into = combo_variables, sep = "--", remove = FALSE) + validate_best_model(rows, "read_selected_agent_forecasts") + rows +} + +validate_reconciliation_predictions <- function(predictions) { + if (any(!is.finite(predictions$Forecast))) { + rlang::abort("Reconciliation received non-finite forecast predictions.", + class = "finnts_forecast_selection_rejected", + combo = unique(predictions$Combo[!is.finite(predictions$Forecast)])) + } + invisible(predictions) +} \ No newline at end of file diff --git a/R/forecast_time_series.R b/R/forecast_time_series.R index 1e5a01e7..9c2089bb 100644 --- a/R/forecast_time_series.R +++ b/R/forecast_time_series.R @@ -2,6 +2,15 @@ #' #' Calls the Finn forecast framework to automatically forecast any historical time series. #' +#' @details Final selection uses the deterministic accuracy and future-plausibility +#' checks documented in [final_models()]. It selects from the models already +#' produced; an invalid forecast is not repaired into a zero forecast or replaced +#' by an additional model fit. No acceptable candidate results in an error. +#' The saved nonwinning average uses the same ranking among eligible averages. +#' Hierarchical forecasts use the selected base forecasts as input to the existing +#' reconciliation solver. Reconciled future outputs are not evaluated to choose +#' a replacement set or trigger additional model fitting. +#' #' @param run_info Run info using [set_run_info()] #' @param input_data A data frame or tibble of historical time series data. Can also include external regressors for both #' historical and future data. diff --git a/R/hierarchy.R b/R/hierarchy.R index 74e2a3d2..e705eced 100644 --- a/R/hierarchy.R +++ b/R/hierarchy.R @@ -640,6 +640,7 @@ reconcile_hierarchical_data <- function(run_info, rbind(snaive_tbl) } + validate_reconciliation_predictions(model_tbl) # floor near-zero forecasts to prevent slow nonnegative reconciliation if (!negative_forecast) { model_tbl <- model_tbl %>% @@ -697,6 +698,10 @@ reconcile_hierarchical_data <- function(run_info, } }, error = function(e) { + if (inherits(e, "finnts_forecast_selection_rejected")) { + if (model == "Best-Model") stop(e) + return(NULL) + } if (model != "Best-Model") { warning(paste0("The model '", model, "' was not able to be reconciled, skipping: ", conditionMessage(e)), call. = FALSE @@ -750,16 +755,10 @@ reconcile_hierarchical_data <- function(run_info, convert_weekly_to_daily(date_type, weekly_to_daily) %>% suppressWarnings() - # write outputs to disk write_data( - x = reconciled_tbl, - combo = model, - run_info = run_info, - output_type = "data", - folder = "forecasts", - suffix = "-reconciled" + x = reconciled_tbl, combo = model, run_info = run_info, + output_type = "data", folder = "forecasts", suffix = "-reconciled" ) - return(tibble::tibble()) } %>% base::suppressPackageStartupMessages() @@ -867,6 +866,7 @@ reconcile_hierarchical_data <- function(run_info, rbind(snaive_tbl) } + validate_reconciliation_predictions(model_tbl) # floor near-zero forecasts to prevent slow nonnegative reconciliation if (!negative_forecast) { model_tbl <- model_tbl %>% @@ -923,6 +923,10 @@ reconcile_hierarchical_data <- function(run_info, } }, error = function(e) { + if (inherits(e, "finnts_forecast_selection_rejected")) { + if (model == "Best-Model") stop(e) + return(NULL) + } if (model != "Best-Model") { warning(paste0("The model '", model, "' was not able to be reconciled, skipping: ", conditionMessage(e)), call. = FALSE @@ -976,16 +980,10 @@ reconcile_hierarchical_data <- function(run_info, convert_weekly_to_daily(date_type, weekly_to_daily) %>% suppressWarnings() - # write outputs to disk write_data( - x = reconciled_tbl, - combo = model, - run_info = run_info, - output_type = "data", - folder = "forecasts", - suffix = "-reconciled" + x = reconciled_tbl, combo = model, run_info = run_info, + output_type = "data", folder = "forecasts", suffix = "-reconciled" ) - return(tibble::tibble()) } %>% base::suppressPackageStartupMessages() @@ -993,6 +991,7 @@ reconcile_hierarchical_data <- function(run_info, # clean up any parallel run process par_end(cl) } + invisible(NULL) } #' Determine how external regressors should be aggregated diff --git a/R/prep_data.R b/R/prep_data.R index 286ce0a0..be1d2aa9 100644 --- a/R/prep_data.R +++ b/R/prep_data.R @@ -1219,6 +1219,10 @@ make_stationary <- function(df) { Diff_Value1 = NA, Diff_Value2 = NA ) + if ("Target_Original" %in% names(df)) { + diff_info$Target_Original_Diff_Value1 <- NA_real_ + diff_info$Target_Original_Diff_Value2 <- NA_real_ + } # store the number of differences used for Target so we can reuse for Target_Original target_ndiffs <- NA @@ -1253,6 +1257,12 @@ make_stationary <- function(df) { # If Target_Original exists, force it to use target_ndiffs if (column_name == "Target_Original" && !is.na(target_ndiffs)) { ndiffs <- target_ndiffs + if (ndiffs > 0) { + diff_info$Target_Original_Diff_Value1 <- temp_tbl$Column[1] + if (ndiffs > 1) { + diff_info$Target_Original_Diff_Value2 <- temp_tbl$Column[2] + } + } } if (ndiffs > 0) { diff --git a/R/read_write_data.R b/R/read_write_data.R index f4c82d4f..855e6210 100644 --- a/R/read_write_data.R +++ b/R/read_write_data.R @@ -1,5 +1,17 @@ #' Get Final Forecast Data #' +#' @details For non-agentic standard or grouped hierarchical runs, returns every +#' successfully saved per-model reconciled forecast together with `Best-Model`. +#' Filter `Best_Model == "Yes"` to retain only the reconciled selected forecast. +#' `Best-Model` can combine different winning models or averages across series; +#' it does not require one model family to win everywhere. Models that did not +#' successfully produce a reconciled artifact are not added to the output. +#' +#' Use [get_agent_forecast()] for final Agent results. Hierarchical Agent output +#' contains only the reconciled selected forecast, because [iterate_forecast()] +#' can run different model and recipe sets for different series. It is not an +#' all-model reconciled comparison table. +#' #' @param run_info run info using the [set_run_info()] function #' @param return_type return type #' @@ -50,10 +62,14 @@ get_forecast_data <- function(run_info, check_input_type("return_type", return_type, "character", c("df", "sdf")) local_reads <- is.null(run_info$storage_object) && identical(return_type, "df") && run_info$data_output %in% c("csv", "parquet", "rds") + provider_reads <- inherits(run_info$storage_object, c("blob_container", "ms_drive")) && + identical(return_type, "df") && run_info$data_output %in% c("csv", "parquet", "rds") # get input values log_df <- if (local_reads) { read_local_artifacts(run_info, local_artifact_path(run_info, "logs", extension = "csv")) + } else if (provider_reads) { + read_exact_artifact(run_info, local_artifact_path(run_info, "logs", extension = "csv")) } else read_file(run_info, file_list = paste0( run_info$path, "/logs/", @@ -65,17 +81,22 @@ get_forecast_data <- function(run_info, combo_variables <- strsplit(log_df$combo_variables, split = "---")[[1]] forecast_approach <- log_df$forecast_approach + local_hierarchy <- local_reads && !identical(forecast_approach, "bottoms_up") + provider_hierarchy <- provider_reads && !identical(forecast_approach, "bottoms_up") single_combo <- local_reads && length(run_info$combo) == 1L && identical(forecast_approach, "bottoms_up") # get train test split data - model_train_test_tbl <- read_file(run_info, + model_train_test_tbl <- if (provider_reads) { + read_exact_artifact(run_info, local_artifact_path(run_info, "prep_models", "-train_test_split")) + } else read_file(run_info, path = paste0( "/prep_models/", hash_data(run_info$project_name), "-", hash_data(run_info$run_name), "-train_test_split.", run_info$data_output ), return_type = return_type - ) %>% + ) + model_train_test_tbl <- model_train_test_tbl %>% dplyr::select(Run_Type, Train_Test_ID) %>% dplyr::mutate(Train_Test_ID = as.numeric(Train_Test_ID)) @@ -85,7 +106,9 @@ get_forecast_data <- function(run_info, hash_data(run_info$run_name), "*condensed", ".", run_info$data_output ) - condensed_files <- if (local_reads) { + condensed_files <- if (local_hierarchy || provider_hierarchy) { + character() + } else if (local_reads) { local_artifact_inventory(run_info, "forecasts", "*condensed") } else list_files(run_info$storage_object, fs::path(cond_path)) @@ -113,7 +136,23 @@ get_forecast_data <- function(run_info, ) } - forecast_tbl <- if (local_reads && condensed && identical(forecast_approach, "bottoms_up")) { + forecast_tbl <- if (local_hierarchy) { + reconciled_files <- local_artifact_inventory(run_info, "forecasts", "-*-reconciled") + read_local_artifacts(run_info, unique(c( + local_artifact_path(run_info, "forecasts", "-reconciled", hash_data("Best-Model")), + reconciled_files + ))) + } else if (provider_hierarchy) { + reconciled_files <- list_files(run_info$storage_object, + local_artifact_path(run_info, "forecasts", "-*-reconciled"), fail_on_error = TRUE) + if (inherits(run_info$storage_object, "ms_drive")) { + reconciled_files <- fs::path(run_info$path, "forecasts", fs::path_file(reconciled_files)) + } + read_exact_artifact(run_info, unique(c( + local_artifact_path(run_info, "forecasts", "-reconciled", hash_data("Best-Model")), + reconciled_files + ))) + } else if (local_reads && condensed && identical(forecast_approach, "bottoms_up")) { read_local_artifacts(run_info, condensed_files) } else if (single_combo) { read_file(run_info, @@ -786,6 +825,54 @@ read_file <- function(run_info, } } +download_exact_artifact <- function(storage_object, path, destination, allow_missing) { + if (inherits(storage_object, "blob_container")) { + return(tryCatch({ + AzureStor::storage_download(storage_object, src = path, dest = destination, overwrite = TRUE) + TRUE + }, http_404 = function(condition) { + if (!allow_missing) stop(condition) + AzureStor::get_storage_properties(storage_object) + FALSE + })) + } + if (inherits(storage_object, "ms_drive")) { + item <- tryCatch(storage_object$get_item(path = path), http_404 = function(condition) { + if (!allow_missing) stop(condition) + storage_object$get_item(path = "/") + NULL + }) + if (is.null(item)) return(FALSE) + if (item$is_folder()) stop("Finn artifact is not a regular file: ", path, call. = FALSE) + item$download(dest = destination, overwrite = TRUE) + return(TRUE) + } + stop("Unsupported storage object for an exact Finn artifact read.", call. = FALSE) +} + +read_exact_artifact <- function(run_info, file_list, return_type = "df", allow_missing = FALSE) { + if (is.null(run_info$storage_object)) { + if (allow_missing) { + file_list <- local_artifact_files(file_list, allow_missing = TRUE) + if (!length(file_list)) return(NULL) + } + return(read_file(run_info, file_list = file_list, return_type = return_type, strict = TRUE)) + } + staged <- character() + for (path in unique(as.character(file_list))) { + directory <- tempfile("finnts-artifact-") + fs::dir_create(directory) + destination <- fs::path(directory, fs::path_file(path)) + if (download_exact_artifact(run_info$storage_object, path, destination, allow_missing)) { + staged <- c(staged, destination) + } + } + if (!length(staged) && allow_missing) return(NULL) + local_info <- run_info + local_info$storage_object <- NULL + read_local_artifacts(local_info, staged, return_type = return_type) +} + local_artifact_inventory <- function(run_info, folder, suffix = "*", extension = run_info$data_output) { pattern <- local_artifact_path(run_info, folder, suffix, extension = extension) diff --git a/R/train_models.R b/R/train_models.R index 6f59ff38..102184e8 100644 --- a/R/train_models.R +++ b/R/train_models.R @@ -938,10 +938,7 @@ clamp_negative_target <- function(data, model) { #' @noRd negative_fcst_adj <- function(data, negative_forecast) { - fcst_final <- data %>% - dplyr::mutate(Forecast = ifelse(is.finite(Forecast), Forecast, NA)) %>% # replace infinite values - dplyr::mutate(Forecast = ifelse(is.nan(Forecast), NA, Forecast)) %>% # replace NaN values - dplyr::mutate(Forecast = ifelse(is.na(Forecast), 0, Forecast)) # replace NA values + fcst_final <- data # convert negative forecasts to zero if (is.na(negative_forecast)) { @@ -951,7 +948,7 @@ negative_fcst_adj <- function(data, if (negative_forecast == FALSE) { fcst_final$Forecast <- replace( fcst_final$Forecast, - which(fcst_final$Forecast < 0), + which(is.finite(fcst_final$Forecast) & fcst_final$Forecast < 0), 0 ) } @@ -1057,6 +1054,25 @@ safe_diff_inv_vec <- function(x, num_diffs, initial_value) { #' #' @return tbl with undifferenced forecast #' @noRd +get_original_diff_initial_values <- function(diff_tbl, initial_value) { + columns <- c("Target_Original_Diff_Value1", "Target_Original_Diff_Value2") + if (all(columns %in% names(diff_tbl))) { + values <- as.numeric(unlist(diff_tbl[1, columns], use.names = FALSE)) + if (all(is.na(values))) return(numeric()) + values <- values[seq_along(initial_value)] + if (any(!is.finite(values))) { + stop("Original-target starting values are incomplete. Regenerate prepared data from the original input.", call. = FALSE) + } + return(values) + } + if (length(initial_value) == 1) return(initial_value) + stop( + "Original-target starting values are missing for second-order differencing. ", + "Regenerate prepared data from the original input before reconstructing actuals.", + call. = FALSE + ) +} + undifference_forecast <- function(forecast_data, recipe_data, diff_tbl) { @@ -1111,13 +1127,17 @@ undifference_forecast <- function(forecast_data, num_diffs <- 1 initial_value <- diff1 } + target_initial_value <- initial_value + if ("Target_Original" %in% names(filtered_recipe_data)) { + target_initial_value <- get_original_diff_initial_values(diff_tbl, initial_value) + } # combine historical data with forecast (adjust Target_Originals when needed) # then undifference and return forecast if ("Target_Original" %in% colnames(filtered_recipe_data)) { - filtered_recipe_data$Target_Original[1] <- NA + if (length(target_initial_value) > 0) filtered_recipe_data$Target_Original[1] <- NA - if (!is.na(diff2)) { + if (length(target_initial_value) > 1) { filtered_recipe_data$Target_Original[2] <- NA } combined_data <- filtered_recipe_data %>% @@ -1144,11 +1164,11 @@ undifference_forecast <- function(forecast_data, target_tbl <- combined_data %>% dplyr::select(-Forecast) %>% dplyr::filter(Date < fcst_start_date) %>% - dplyr::mutate(Target = safe_diff_inv_vec(Target, num_diffs, initial_value)) + dplyr::mutate(Target = if (length(target_initial_value)) safe_diff_inv_vec(Target, num_diffs, target_initial_value) else Target) } else { target_tbl <- combined_data %>% dplyr::select(-Forecast) %>% - dplyr::mutate(Target = safe_diff_inv_vec(Target, num_diffs, initial_value)) + dplyr::mutate(Target = if (length(target_initial_value)) safe_diff_inv_vec(Target, num_diffs, target_initial_value) else Target) } forecast_tbl <- combined_data %>% @@ -1210,14 +1230,13 @@ undifference_recipe <- function(recipe_data, # undifference Target_Original col if it exists if ("Target_Original" %in% colnames(undiff_recipe_data)) { - undiff_recipe_data$Target_Original[1] <- NA - - if (!is.na(diff2)) { - undiff_recipe_data$Target_Original[2] <- NA + original_initial_value <- get_original_diff_initial_values(diff_tbl, initial_value) + if (length(original_initial_value) > 0) { + undiff_recipe_data$Target_Original[seq_along(original_initial_value)] <- NA_real_ + undiff_recipe_data$Target_Original <- safe_diff_inv_vec( + undiff_recipe_data$Target_Original, num_diffs, original_initial_value + ) } - - undiff_recipe_data <- undiff_recipe_data %>% - dplyr::mutate(Target_Original = safe_diff_inv_vec(Target_Original, num_diffs, initial_value)) } # combine with future data and return diff --git a/man/final_models.Rd b/man/final_models.Rd index e6dcaaae..49515562 100644 --- a/man/final_models.Rd +++ b/man/final_models.Rd @@ -18,7 +18,7 @@ final_models( \item{run_info}{run info using the \code{\link[=set_run_info]{set_run_info()}} function.} \item{average_models}{If TRUE, create simple averages of individual models -and save the most accurate one.} +and save the eligible average selected by accuracy and future-quality checks.} \item{max_model_average}{Max number of models to average together. Will create model averages for 2 models up until input value or max number of @@ -49,6 +49,50 @@ Final model outputs are written to disk. \description{ Select Best Models and Prep Final Outputs } +\details{ +Candidates are screened for complete, finite predictions and extreme +future magnitudes using original-scale prepared actuals. Among eligible +candidates within 0.5 percentage points or 5 percent relative weighted MAPE +of the best eligible accuracy, whichever allowance is larger, selection +prefers lower risk and fewer future level, trend, and seasonal concerns. +Tied candidates with assessed seasonal evidence then prefer smaller amplitude +distortion beyond historical cycle variation, before weighted MAPE and model +identifier. This preference alone does not reject a forecast. Repeated strong +historical seasonality can also support phase checks over at least three +informative future periods, even when the horizon is shorter than a cycle. +Short histories remain usable; unsupported seasonal checks are not assessed. +Sufficient regular prepared history can support an additive or proportional +trend reference when it improves both chronological historical validation +blocks. Level checks then follow the projected trend and seasonal offsets, +with uncertainty from historical residuals and drift variation. Proportional +references use log-scale changes and seasonal comparisons only for suitable +positive history. Unsupported or unstable trends retain the existing +seasonal-naive or recent-median reference. Backtests retain the historical +magnitude bound; supported future paths use 100 times the larger of the +historical robust scale and the absolute projected reference at each step. +Prepared-history imputation remains part of the evidence. These checks are +engineering guardrails, not calibrated intervals or accuracy guarantees. +If all candidates fail the required checks, selection raises an error. +Evaluation is deterministic for fixed inputs and creates no diagnostic files. +If an individual model wins, the best eligible simple average is still saved +with \code{Best_Model = "No"}, using the same quality-aware ranking among averages. +If an average wins overall, that exact average is saved as the best model. +No average artifact is required when no eligible average can be formed. +Quality selection happens before hierarchical reconciliation, at each prepared +hierarchy node. The selected mixture is reconciled without a second future +plausibility evaluation or a whole-hierarchy replacement model. Reconciled +backtests still supply reported accuracy; reconciliation does not require +retained quality rankings. On retry, saved individual and average outputs +must identify one complete winner per series. A \code{Best_Model} column or an +average filename alone is not proof of completion. Incomplete selections +rebuild averages and winner flags from existing predictions without fitting +models again. Complete saved winners are reused without future-quality +reassessment, and every series remains in the returned result. Reconciled +output is reused only when all original series have complete, unique backtest +and future keys with finite forecasts, including every day of a daily-expanded +week. Incomplete reconciled output is rebuilt from selected source forecasts +and checked before completion is logged; storage and read errors propagate. +} \examples{ \donttest{ data_tbl <- timetk::m4_monthly \%>\% diff --git a/man/forecast_time_series.Rd b/man/forecast_time_series.Rd index a07001c3..210b085b 100644 --- a/man/forecast_time_series.Rd +++ b/man/forecast_time_series.Rd @@ -172,6 +172,16 @@ A list of three separate data sets: the future forecast, the back test results, \description{ Calls the Finn forecast framework to automatically forecast any historical time series. } +\details{ +Final selection uses the deterministic accuracy and future-plausibility +checks documented in \code{\link[=final_models]{final_models()}}. It selects from the models already +produced; an invalid forecast is not repaired into a zero forecast or replaced +by an additional model fit. No acceptable candidate results in an error. +The saved nonwinning average uses the same ranking among eligible averages. +Hierarchical forecasts use the selected base forecasts as input to the existing +reconciliation solver. Reconciled future outputs are not evaluated to choose +a replacement set or trigger additional model fitting. +} \examples{ \donttest{ diff --git a/man/get_agent_forecast.Rd b/man/get_agent_forecast.Rd index fb613143..7839379e 100644 --- a/man/get_agent_forecast.Rd +++ b/man/get_agent_forecast.Rd @@ -15,6 +15,18 @@ A tibble containing the final forecast for the agent. \description{ This function retrieves the final forecast for a Finn agent after the forecast iteration process is complete. } +\details{ +For hierarchical Agent runs, returns only the final reconciled +\code{Best-Model} forecast. Each series can run and select different models, +recipes, or averages during \code{\link[=iterate_forecast]{iterate_forecast()}}, so the selected forecasts +are reconciled together rather than producing a comparison hierarchy for +every model. \code{Best-Model} does not mean the same model family won for every +series. This best-only reconciled output contract also applies after +\code{\link[=update_forecast]{update_forecast()}}. It does not change non-hierarchical candidate output. + +For non-agentic hierarchical runs, \code{\link[=get_forecast_data]{get_forecast_data()}} returns all +successfully saved per-model reconciled forecasts plus \code{Best-Model}. +} \examples{ \dontrun{ # load example data diff --git a/man/get_forecast_data.Rd b/man/get_forecast_data.Rd index 8713c0e5..055f7288 100644 --- a/man/get_forecast_data.Rd +++ b/man/get_forecast_data.Rd @@ -17,6 +17,19 @@ table of final forecast results \description{ Get Final Forecast Data } +\details{ +For non-agentic standard or grouped hierarchical runs, returns every +successfully saved per-model reconciled forecast together with \code{Best-Model}. +Filter \code{Best_Model == "Yes"} to retain only the reconciled selected forecast. +\code{Best-Model} can combine different winning models or averages across series; +it does not require one model family to win everywhere. Models that did not +successfully produce a reconciled artifact are not added to the output. + +Use \code{\link[=get_agent_forecast]{get_agent_forecast()}} for final Agent results. Hierarchical Agent output +contains only the reconciled selected forecast, because \code{\link[=iterate_forecast]{iterate_forecast()}} +can run different model and recipe sets for different series. It is not an +all-model reconciled comparison table. +} \examples{ \donttest{ data_tbl <- timetk::m4_monthly \%>\% diff --git a/man/iterate_forecast.Rd b/man/iterate_forecast.Rd index 38ce1763..964a9814 100644 --- a/man/iterate_forecast.Rd +++ b/man/iterate_forecast.Rd @@ -42,6 +42,33 @@ greater than number of cores on machine minus 1.} \description{ This function orchestrates the forecast iteration process for a Finn agent, including exploratory data analysis, } +\details{ +Future quality is evaluated when \code{\link[=final_models]{final_models()}} selects the winner +within each iteration. Iteration ranking starts from the earliest minimum +WMAPE and may prefer a later eligible iteration within 10 percent relative +WMAPE when its average model WMAPE is strictly lower. Local mean, median, and +standard deviation summarize individual-model backtests, excluding simple +averages. This retains evidence that a setting improves other models even if +the current best model does not improve. Global summary fields retain their +original meaning: run WMAPE for mean and median, and zero standard deviation. +Agent comparisons and stopping use WMAPE rounded to four decimal places. +Search-context selection does not overwrite a better saved local forecast. +Global promotion applies to one complete iteration, and all saved global +winners must reference that same iteration. Individual models and averages +may differ within it. Mixed global iteration metadata is rejected before +publication or update; interrupted writes are not treated as successful. +Normal accuracy-goal stopping requires a complete eligible result and finite WMAPE, not another +soft-quality check. A winner with soft concerns may therefore beat an earlier +winner on accuracy. Loaded backtests, run history, and best-run metrics are reused without +re-evaluating past future paths. Rejected evaluations still consume iteration +budget without repeating the same fit as an infrastructure retry. If no +eligible result exists, the workflow fails or an enabled local phase handles +unresolved global series. Rankings are kept in memory, not new files. +Hierarchical accuracy uses reconciled backtests; later comparisons and +reconciliation do not require retained source-node quality rankings. Final +reconciliation publishes the selected mixture without future-quality scoring, +whole-set fallback, or extra refitting. +} \examples{ \dontrun{ # load example data diff --git a/man/update_forecast.Rd b/man/update_forecast.Rd index 49854146..64878689 100644 --- a/man/update_forecast.Rd +++ b/man/update_forecast.Rd @@ -61,6 +61,34 @@ process, they are automatically re-forecast using default local model inputs (the same treatment as new time series). If more than 20\\% of existing series (with a floor of 10) fail to update, an error is raised directing the user to use \code{iterate_forecast()} instead. + +Reused forecasts are checked against original-scale prepared actuals +after refitting and retuning. Quality-rejected series receive one default +reforecast through the same path as new series, without LLM quality judgments. +Quality-only rejections do not count toward the ordinary execution-failure +limit; existing data/provider failures retain that limit. Replacement models +are evaluated using \code{\link[=final_models]{final_models()}} and cannot trigger an unbounded retry. +Reused fits do not call \code{final_models()}; their components must pass hard +eligibility and their selected combination must pass applicable quality checks +before any reconciliation, including after retuning. Global updates recover +each series' saved winning single model or average from existing source +forecasts, refit the union of required components, and preserve each selected +subset. Requested but unselected models are not added back to the average. +All globally selected series must reference one winning global iteration. +Mixed global iteration metadata is rejected before refitting rather than +split into multiple global updates. Different model subsets within that +single iteration and separately selected local winners remain supported. +Missing or ambiguous saved winners or selected fits require restoring the +original artifacts; the requested model list is not used as a fallback. +These are checks on newly generated predictions, not repeated assessments of +past iteration winners. A reused hierarchy that +is incomplete or contains a rejected node is not reconciled; its covered +current series follow the existing default-local forecast path. Existing +run logs record default acceptance or rejection for restart safety. The +selected mixture is then reconciled without post-reconciliation future +evaluation, whole-set replacement, or late quality-triggered refitting. +Legacy second-order differenced original targets without their own starting +values require regeneration of prepared data from the original input. } \examples{ \dontrun{ diff --git a/tests/testthat/helper-artifact-io.R b/tests/testthat/helper-artifact-io.R index 6a74864b..9c87b287 100644 --- a/tests/testthat/helper-artifact-io.R +++ b/tests/testthat/helper-artifact-io.R @@ -1,3 +1,64 @@ +artifact_http_error <- function(status = 404L, message = "requested artifact is missing") { + response <- structure(list(status_code = status, url = "https://example.invalid/artifact"), + class = "response") + tryCatch(httr::stop_for_status(response, message), error = identity) +} + +local_artifact_provider <- function(provider, .env = parent.frame()) { + state <- new.env(parent = emptyenv()) + state$files <- list() + state$lookups <- character() + state$downloads <- character() + state$destinations <- character() + state$root_checks <- 0L + state$root_error <- NULL + state$lookup_error <- NULL + state$download_error <- NULL + state$folder <- FALSE + root <- function() { + state$root_checks <- state$root_checks + 1L + if (!is.null(state$root_error)) stop(state$root_error) + list() + } + lookup <- function(path) { + state$lookups <- c(state$lookups, as.character(path)) + if (!is.null(state$lookup_error)) stop(state$lookup_error) + if (is.null(state$files[[as.character(path)]])) stop(artifact_http_error()) + state$files[[as.character(path)]] + } + download <- function(src, dest) { + state$downloads <- c(state$downloads, as.character(src)) + state$destinations <- c(state$destinations, as.character(dest)) + if (!is.null(state$download_error)) stop(state$download_error) + fs::file_copy(state$files[[as.character(src)]], dest, overwrite = TRUE) + invisible(NULL) + } + if (provider == "blob_container") { + testthat::skip_if_not_installed("AzureStor") + state$storage_object <- structure(list(), class = "blob_container") + testthat::local_mocked_bindings( + storage_download = function(container, src, dest, overwrite = FALSE, ...) { + lookup(src) + download(src, dest) + }, + get_storage_properties = function(object, ...) root(), + .package = "AzureStor", .env = .env + ) + } else { + state$storage_object <- structure(list(get_item = function(path = NULL, itemid = NULL) { + if (identical(path, "/")) return(root()) + lookup(path) + list(is_folder = function() state$folder, + download = function(dest, overwrite = FALSE) download(path, dest)) + }), class = "ms_drive") + } + testthat::local_mocked_bindings( + list_files = function(...) stop("exact provider reads must not enumerate directories"), + .package = "finnts", .env = .env + ) + state +} + artifact_test_run <- function(path, data_output = "csv", object_output = "rds") { list( project_name = paste0("artifact_io_", basename(tempfile())), diff --git a/tests/testthat/helper-forecast-selection.R b/tests/testthat/helper-forecast-selection.R new file mode 100644 index 00000000..a09778c1 --- /dev/null +++ b/tests/testthat/helper-forecast-selection.R @@ -0,0 +1,584 @@ +locate_single_models_file <- function(run_info) { + forecasts_dir <- file.path(run_info$path, "forecasts") + run_hash <- hash_data(run_info$run_name) + pattern <- paste0( + "^", + hash_data(run_info$project_name), "-", + run_hash, "-.*-single_models\\.(csv|parquet)$" + ) + files <- list.files(forecasts_dir, pattern = pattern, full.names = TRUE) + if (length(files) != 1) { + stop( + "expected exactly 1 single_models file for run ", run_info$run_name, + " but found ", length(files) + ) + } + files +} + +read_fcst_file <- function(path) { + ext <- tools::file_ext(path) + if (ext == "parquet") { + arrow::read_parquet(path) + } else { + suppressMessages(vroom::vroom(path, delim = ",", show_col_types = FALSE, altrep = FALSE)) + } +} + +write_fcst_file <- function(data, path) { + ext <- tools::file_ext(path) + if (ext == "parquet") { + arrow::write_parquet(data, path) + } else { + vroom::vroom_write(data, path, delim = ",") + } +} + +make_best_models_fixture <- function(date_type = "month") { + run_path <- withr::local_tempdir( + pattern = "finnts-best-models-", + .local_envir = parent.frame() + ) + run_info <- set_run_info( + project_name = "best_models_test", + run_name = "partial_fold_coverage", + path = run_path, + data_output = "csv", + add_unique_id = FALSE + ) + dates <- seq(as.Date("2021-01-01"), by = date_type, length.out = 39) + hist_end_date <- dates[36] + log_path <- paste0( + "logs/", hash_data(run_info$project_name), "-", + hash_data(run_info$run_name), ".csv" + ) + log_data <- finnts:::read_file(run_info, path = log_path, return_type = "df") %>% + dplyr::mutate( + date_type = !!date_type, + combo_variables = "Series", + forecast_approach = "bottoms_up", + forecast_horizon = 3, + hist_start_date = dates[1], + hist_end_date = hist_end_date, + recipes_to_run = "R1", + clean_outliers = FALSE, + clean_missing_values = TRUE, + stationary = FALSE, + box_cox = FALSE, + negative_forecast = FALSE, + run_global_models = FALSE, + run_local_models = TRUE, + run_ensemble_models = FALSE + ) + finnts:::write_data( + log_data, + combo = NULL, + run_info = run_info, + output_type = "log", + folder = "logs", + suffix = NULL + ) + + splits <- tibble::tibble( + Run_Type = c("Future_Forecast", rep("Back_Test", 3)), + Train_Test_ID = 1:4, + Train_End = dates[c(36, 33, 30, 27)], + Test_End = dates[c(39, 36, 33, 30)] + ) + finnts:::write_data( + splits, + combo = NULL, + run_info = run_info, + output_type = "data", + folder = "prep_models", + suffix = "-train_test_split" + ) + history <- tibble::tibble( + Combo = "Synthetic", + Date = dates, + Target = ifelse(dates <= hist_end_date, 100 + as.integer(format(dates, "%m")), NA_real_) + ) + finnts:::write_data( + history, + combo = "Synthetic", + run_info = run_info, + output_type = "data", + folder = "prep_data", + suffix = "-R1" + ) + forecasts <- tidyr::expand_grid( + Model_Name = c("meanf", "snaive"), + Train_Test_ID = 1:4, + Horizon = 1:3 + ) %>% + dplyr::mutate( + Combo_ID = "Synthetic", + Combo = "Synthetic", + Model_Type = "local", + Recipe_ID = "R1", + Model_ID = paste(Model_Name, Model_Type, Recipe_ID, sep = "--"), + Hyperparameter_ID = 1, + Date = dates[c(36, 33, 30, 27)[Train_Test_ID] + Horizon], + Target = ifelse(Train_Test_ID == 1, NA_real_, 100 + as.integer(format(Date, "%m"))), + Forecast = dplyr::case_when( + Train_Test_ID == 1 ~ 100 + as.integer(format(Date, "%m")), + Model_Name == "meanf" ~ Target * 1.10, + Train_Test_ID == 2 ~ Target * 1.01, + Train_Test_ID == 3 ~ Target * 1.20, + TRUE ~ Target * 1.30 + ) + ) %>% + dplyr::select( + Combo_ID, Model_ID, Model_Name, Model_Type, Recipe_ID, + Train_Test_ID, Hyperparameter_ID, Combo, Horizon, Date, Target, Forecast + ) + finnts:::write_data( + forecasts, + combo = "Synthetic", + run_info = run_info, + output_type = "data", + folder = "forecasts", + suffix = "-single_models" + ) + run_info +} + +make_agent_metric_forecasts <- function(result) { + dplyr::bind_rows(lapply(names(result$selections), function(series) { + selected <- result$selections[[series]] + if (is.null(selected) || is.na(selected$selected_id)) return(NULL) + score <- selected$rankings[selected$rankings$Model_ID == selected$selected_id, , drop = FALSE] + data.frame(Combo = series, Model_ID = selected$selected_id, Recipe_ID = "R1", + Run_Type = "Back_Test", Best_Model = "Yes", Target = 100, Forecast = 100 * (1 + score$WMAPE)) + })) +} + +selection_benchmark_catalogue <- function() { + dplyr::bind_rows( + data.frame(Model_Name = list_models(), Model_Type = "local", Recipe_ID = "R1"), + data.frame(Model_Name = list_r2_models(), Model_Type = "local", Recipe_ID = "R2"), + data.frame(Model_Name = list_global_models(), Model_Type = "global", Recipe_ID = "R1"), + data.frame(Model_Name = intersect(list_global_models(), list_r2_models()), Model_Type = "global", Recipe_ID = "R2"), + data.frame(Model_Name = list_ensemble_models(), Model_Type = "local", Recipe_ID = "ensemble") + ) %>% dplyr::mutate(Model_ID = paste(Model_Name, Model_Type, Recipe_ID, sep = "--")) +} + +make_catalogue_selection_fixture <- function(trial, catalogue = selection_benchmark_catalogue(), mixed = FALSE, + distinct_forecasts = FALSE) { + path <- withr::local_tempdir(pattern = "finnts-selection-catalogue-", .local_envir = parent.frame()) + info <- set_run_info(project_name = "selection-catalogue", run_name = paste0("trial-", trial), + path = path, data_output = "csv", add_unique_id = FALSE) + info$combo <- hash_data("Synthetic") + dates <- seq(as.Date("2020-01-01"), by = "month", length.out = 60) + actuals <- 100 + 10 * cos(2 * pi * (seq_along(dates) - 0.5) / 12) + splits <- data.frame(Train_Test_ID = 1:4, Run_Type = c("Future_Forecast", rep("Back_Test", 3)), + Train_End = dates[c(48, 36, 30, 24)], Test_End = dates[c(60, 48, 42, 36)]) + log <- read_selection_file(info, "logs") + settings <- list(date_type = "month", combo_variables = "Series", forecast_approach = "bottoms_up", + forecast_horizon = 12L, hist_start_date = dates[1], hist_end_date = dates[48], recipes_to_run = "R1---R2", + clean_outliers = FALSE, clean_missing_values = TRUE, stationary = FALSE, box_cox = FALSE, + negative_forecast = FALSE, run_global_models = any(catalogue$Model_Type == "global"), + run_local_models = any(catalogue$Model_Type == "local" & catalogue$Recipe_ID != "ensemble"), + run_ensemble_models = any(catalogue$Recipe_ID == "ensemble")) + for (setting in names(settings)) log[[setting]] <- settings[[setting]] + write_data(log, combo = NULL, run_info = info, output_type = "log", folder = "logs", suffix = NULL) + write_data(splits, combo = NULL, run_info = info, output_type = "data", folder = "prep_models", suffix = "-train_test_split") + history <- data.frame(Combo = "Synthetic", Date = dates, Target = c(actuals[1:48], rep(NA_real_, 12))) + write_data(history, combo = "Synthetic", run_info = info, output_type = "data", folder = "prep_data", suffix = "-R1") + r2 <- history[rep(seq_len(nrow(history)), 12), ] + r2$Horizon <- rep(1:12, each = nrow(history)) + r2$Origin <- rep(seq_len(nrow(history)), 12) - r2$Horizon + write_data(r2, combo = "Synthetic", run_info = info, output_type = "data", folder = "prep_data", suffix = "-R2") + rows <- dplyr::bind_rows(lapply(seq_len(nrow(catalogue)), function(model_index) { + model <- catalogue[model_index, ] + positions <- unlist(lapply(c(48L, 36L, 30L, 24L), function(origin) origin + seq_len(12))) + future <- rep(c(TRUE, FALSE, FALSE, FALSE), each = 12) + forecast <- actuals[positions] * (1 + 0.06 + model_index * 0.0002) + forecast[future] <- actuals[positions[future]] + if (distinct_forecasts) forecast <- forecast + model_index * rep(seq_len(12), 4) / 1000 + if (mixed && model_index == 1L) forecast[future] <- forecast[future] * 100000 + if (mixed && model_index == 2L) forecast[future] <- Inf + predictions <- data.frame(Combo = "Synthetic", Combo_ID = "Synthetic", + Model_ID = model$Model_ID, Model_Name = model$Model_Name, Model_Type = model$Model_Type, + Recipe_ID = model$Recipe_ID, Hyperparameter_ID = 1L, Train_Test_ID = rep(1:4, each = 12), + Horizon = rep(1:12, 4), Date = dates[positions], + Target = ifelse(future, NA_real_, actuals[positions]), Forecast = forecast) + if (mixed && model_index == 3L) predictions <- predictions[predictions$Train_Test_ID != 4L, ] + predictions + })) + suffixes <- ifelse(rows$Recipe_ID == "ensemble", "-ensemble_models", + ifelse(rows$Model_Type == "global", "-global_models", "-single_models")) + for (suffix in unique(suffixes)) { + write_data(rows[suffixes == suffix, ], combo = "Synthetic", run_info = info, + output_type = "data", folder = "forecasts", suffix = suffix) + } + list(run_info = info, forecasts = rows, catalogue = catalogue, splits = splits) +} + +make_hierarchical_selection_artifacts <- function(approach = "standard_hierarchy", date_type = "month", + shape = "flat", horizon = NULL, backtest_scenarios = 3L) { + fixture <- make_pre_reconciliation_case("magnitude", "all", approach, + date_type = date_type, shape = shape, horizon = horizon) + fixture$splits <- utils::head(fixture$splits, backtest_scenarios + 1L) + fixture$forecasts <- fixture$forecasts[fixture$forecasts$Train_Test_ID %in% fixture$splits$Train_Test_ID, ] + path <- withr::local_tempdir(pattern = "finnts-selection-hierarchy-", .local_envir = parent.frame()) + info <- set_run_info(project_name = "selection-hierarchy", run_name = approach, + path = path, data_output = "csv", add_unique_id = FALSE) + log <- read_selection_file(info, "logs") + context <- fixture$contexts[[1]] + settings <- list(date_type = date_type, combo_variables = "Series", forecast_approach = approach, + forecast_horizon = fixture$horizon, hist_start_date = min(context$history$Date), + hist_end_date = context$hist_end_date, recipes_to_run = "R1", clean_outliers = FALSE, + clean_missing_values = TRUE, stationary = FALSE, box_cox = FALSE, negative_forecast = FALSE, + run_global_models = FALSE, run_local_models = TRUE, run_ensemble_models = FALSE) + for (setting in names(settings)) log[[setting]] <- settings[[setting]] + write_data(log, combo = NULL, run_info = info, output_type = "log", folder = "logs", suffix = NULL) + write_data(fixture$splits, combo = NULL, run_info = info, output_type = "data", folder = "prep_models", suffix = "-train_test_split") + write_data(fixture$metadata, combo = NULL, run_info = info, output_type = "object", folder = "prep_data", suffix = "-hts_info") + write_data(fixture$history, combo = NULL, run_info = info, output_type = "data", folder = "prep_data", suffix = "-hts_data") + for (combo in fixture$metadata$hts_combos) { + context <- fixture$contexts[[combo]] + history <- data.frame(Combo = combo, Date = context$calendar, + Target = c(context$history$Target, rep(NA_real_, fixture$horizon))) + write_data(history, combo = combo, run_info = info, output_type = "data", folder = "prep_data", suffix = "-R1") + predictions <- fixture$forecasts[fixture$forecasts$Combo == combo, ] + predictions$Combo_ID <- combo + predictions$Hyperparameter_ID <- 1L + predictions <- predictions %>% dplyr::group_by(Model_ID, Train_Test_ID) %>% + dplyr::mutate(Horizon = dplyr::row_number()) %>% dplyr::ungroup() + write_data(predictions, combo = combo, run_info = info, output_type = "data", folder = "forecasts", suffix = "-single_models") + } + fixture$run_info <- info + fixture +} + +make_selection_history_recipe <- function(actuals, cleaned = actuals, + difference_order = 0, box_cox = FALSE, + recipe = "R1", horizon = 3) { + dates <- seq(as.Date("2020-01-01"), by = "month", length.out = length(actuals) + horizon) + data <- tibble::tibble( + Combo = "Synthetic", Date = dates, + Target = c(cleaned, rep(NA_real_, horizon)), + Target_Original = c(actuals, rep(NA_real_, horizon)) + ) + lambda <- NA_real_ + if (box_cox) { + transformed <- apply_box_cox(data) + data <- transformed$data + lambda <- transformed$diff_info$Box_Cox_Lambda + } + testthat::local_mocked_bindings( + unitroot_ndiffs = function(...) difference_order, + .package = "feasts" + ) + transformed <- make_stationary(data) + data <- transformed$data + metadata <- transformed$diff_info + metadata$Box_Cox_Lambda <- lambda + if (identical(recipe, "R2")) { + data <- dplyr::bind_rows(lapply(seq_len(horizon), function(period) { + dplyr::mutate(data, Horizon = period, Origin = seq_len(nrow(data)) - period) + })) + } + list( + data = data, combo_info = metadata, + hist_end_date = dates[length(actuals)], + expected = data.frame(Date = dates[seq_along(actuals)], Target = actuals) + ) +} + +make_selection_case <- function(actuals = rep(100, 36), + futures = list(accurate = rep(200, 6), safe = rep(100, 6)), + errors = c(accurate = 0.08, safe = 0.083), + date_type = "month", period = NULL) { + forecast_horizon <- length(futures[[1]]) + cadence <- switch(date_type, day = "day", week = "week", month = "month", quarter = "3 months", year = "year") + dates <- seq(as.Date("2020-01-01"), by = cadence, length.out = length(actuals) + forecast_horizon) + history <- data.frame(Date = dates[seq_along(actuals)], Target = actuals) + backtest_size <- min(forecast_horizon, length(actuals) - 1L) + backtest_dates <- utils::tail(history$Date, backtest_size) + future_dates <- utils::tail(dates, forecast_horizon) + backtests <- dplyr::bind_rows(lapply(names(futures), function(model_id) { + target <- utils::tail(actuals, backtest_size) + data.frame(Model_ID = model_id, Train_Test_ID = 2L, Date = backtest_dates, + Target = target, Forecast = target * (1 + errors[[model_id]])) + })) + forecasts <- dplyr::bind_rows(lapply(names(futures), function(model_id) { + data.frame(Model_ID = model_id, Train_Test_ID = 1L, Date = future_dates, + Target = NA_real_, Forecast = futures[[model_id]]) + })) + context <- list( + calendar = dates, date_type = date_type, seasonal_period = period, + hist_end_date = max(history$Date), + train_test_split = data.frame( + Train_Test_ID = c(1L, 2L), Run_Type = c("Future_Forecast", "Back_Test"), + Train_End = c(max(history$Date), dates[length(actuals) - backtest_size]), + Test_End = c(max(dates), max(history$Date)) + ) + ) + list(history = history, backtests = backtests, forecasts = forecasts, context = context) +} + +make_fitted_selection_models <- function(forecasts, model_names = c("xgboost", "chronos2")) { + dplyr::bind_rows(lapply(model_names, function(model) { + predictions <- forecasts[, c("Combo", "Train_Test_ID", "Date", "Target", "Forecast", "Run_Type")] + predictions$Hyperparameter_ID <- 1L + tibble::tibble(Combo_ID = "All-Data", Model_Name = model, Model_Type = "global", + Recipe_ID = "R1", Forecast_Tbl = list(predictions), Model_Fit = list(NULL)) + })) +} + +make_pre_reconciliation_case <- function(pathology = "magnitude", placement = "all", + approach = "standard_hierarchy", series_count = 4L, + date_type = "month", shape = "seasonal", + history_cycles = 4L, horizon = NULL, recipe = "R1") { + period <- forecast_seasonal_period(list(date_type = date_type)) + history_size <- max(12L, history_cycles * period) + if (is.null(horizon)) horizon <- max(4L, period) + cadence <- switch(date_type, day = "day", week = "week", month = "month", quarter = "3 months", year = "year") + dates <- seq(as.Date("2020-01-01"), by = cadence, length.out = history_size + horizon) + positions <- seq_along(dates) + levels <- 100 * (1 + (seq_len(series_count) %% 17L) / 20) + profile <- switch(shape, + flat = rep(1, length(dates)), + trend = 1 + 0.001 * positions, + noisy = 1 + 0.02 * sin(positions * 1.31) + 0.01 * cos(positions * 2.1), + intermittent = ifelse(positions %% 5L == 0L, 1, 0), + zero = rep(0, length(dates)), + 1 + 0.1 * cos(2 * pi * (positions - 0.5) / period)) + if (shape == "signed") levels <- levels * rep(c(-1, 1), length.out = series_count) + original_combos <- sprintf("series-%06d", seq_len(series_count)) + truth <- outer(profile, levels) + colnames(truth) <- original_combos + group_width <- max(2L, ceiling(sqrt(series_count))) + first_group <- (seq_len(series_count) - 1L) %/% group_width + 1L + second_group <- (seq_len(series_count) - 1L) %% group_width + 1L + hierarchy <- suppressMessages(if (approach == "standard_hierarchy") { + hts::hts(stats::ts(truth), nodes = list(max(first_group), as.integer(tabulate(first_group)))) + } else { + hts::gts(stats::ts(truth), groups = rbind(first_group, second_group)) + }) + all_truth <- hts::allts(hierarchy) + source_combos <- sprintf("node-%06d", seq_len(ncol(all_truth))) + aggregate_count <- ncol(all_truth) - series_count + affected <- switch(placement, root = 1L, aggregate = 2L, leaf = aggregate_count + 1L, + siblings = aggregate_count + seq_len(min(2L, series_count)), all = seq_len(ncol(all_truth))) + backtest_size <- min(horizon, floor(history_size / 2)) + origins <- history_size - backtest_size - (0:2) * max(1L, floor(backtest_size / 2)) + origins <- origins[origins >= 1L] + split_origins <- c(history_size, origins) + split_lengths <- c(horizon, rep(backtest_size, length(origins))) + keys <- dplyr::bind_rows(lapply(seq_along(split_origins), function(split_index) { + data.frame(Train_Test_ID = split_index, Position = split_origins[split_index] + seq_len(split_lengths[split_index])) + })) + splits <- data.frame(Train_Test_ID = seq_along(split_origins), + Run_Type = c("Future_Forecast", rep("Back_Test", length(origins))), + Train_End = dates[split_origins], Test_End = dates[split_origins + split_lengths]) + contexts <- stats::setNames(lapply(seq_along(source_combos), function(source_index) { + list(history = data.frame(Date = dates[seq_len(history_size)], Target = all_truth[seq_len(history_size), source_index]), + calendar = dates, hist_end_date = dates[history_size], date_type = date_type, seasonal_period = period) + }), source_combos) + models <- if (recipe == "R2") c("glmnet", "svm-rbf", "xgboost") else c("arima", "ets", "snaive") + forecasts <- dplyr::bind_rows(lapply(seq_along(source_combos), function(source_index) { + actuals <- all_truth[seq_len(history_size), source_index] + future <- utils::tail(all_truth[, source_index], horizon) + level <- mean(utils::tail(actuals, min(period, length(actuals)))) + magnitude <- max(abs(level), 1) + damaged <- switch(pathology, + magnitude = future * 100000, + trend = future + magnitude * 0.15 * seq_len(horizon), + level = future + 2 * magnitude, + phase = 2 * level - future, + amplitude = level + 6 * (future - level), + flatten = rep(level, horizon), future) + bad_index <- 1L + source_index %% 2L + dplyr::bind_rows(lapply(seq_along(models), function(model_index) { + error <- if (model_index == bad_index) 0.08 else if (model_index == 3L) 0.085 else 0.083 + target <- all_truth[keys$Position, source_index] + forecast <- target * (1 + error) + forecast[keys$Train_Test_ID == 1L] <- if (source_index %in% affected && model_index == bad_index) damaged else future + data.frame(Combo = source_combos[source_index], Model_ID = paste(models[model_index], "local", recipe, sep = "--"), + Model_Name = models[model_index], Model_Type = "local", Recipe_ID = recipe, + Train_Test_ID = keys$Train_Test_ID, Date = dates[keys$Position], + Target = ifelse(keys$Train_Test_ID == 1L, NA_real_, target), Forecast = forecast) + })) + })) + history <- data.frame(Combo = rep(original_combos, each = history_size), + Date = rep(dates[seq_len(history_size)], series_count), + Target = as.vector(truth[seq_len(history_size), , drop = FALSE])) + held_out <- data.frame(Combo = rep(original_combos, each = horizon), + Date = rep(utils::tail(dates, horizon), series_count), Truth = as.vector(utils::tail(truth, horizon))) + affected_bottoms <- switch(placement, root = original_combos, all = original_combos, + aggregate = original_combos[first_group == 1L], leaf = original_combos[1], + siblings = utils::head(original_combos, 2)) + list(forecasts = forecasts, contexts = contexts, history = history, held_out = held_out, splits = splits, + metadata = list(original_combos = original_combos, hts_combos = source_combos, + nodes = if (approach == "standard_hierarchy") hts::get_nodes(hierarchy) else hts::get_groups(hierarchy)), + run_info = list(project_name = "paired-selection", run_name = "synthetic", data_output = "csv", object_output = "rds"), + approach = approach, negative_forecast = shape == "signed", pathology = pathology, placement = placement, + horizon = horizon, history_size = history_size, affected_bottoms = affected_bottoms) +} + +select_pre_reconciliation_inputs <- function(fixture, quality = TRUE, max_average = 3L) { + results <- lapply(names(fixture$contexts), function(combo) { + rows <- fixture$forecasts[fixture$forecasts$Combo == combo, , drop = FALSE] + context <- fixture$contexts[[combo]] + selection <- NULL + if (quality) { + selection <- select_series_forecasts(rows, context, fixture$splits) + } else { + model_ids <- unique(as.character(rows$Model_ID)) + if (!length(model_ids) || anyNA(model_ids) || any(!nzchar(model_ids))) { + stop("Candidate identities must be nonmissing.", call. = FALSE) + } + history <- context$history + history$Date <- as.Date(history$Date) + history <- history[history$Date <= as.Date(context$hist_end_date), , drop = FALSE] + if (anyNA(history$Date) || anyDuplicated(history$Date) || !any(is.finite(history$Target))) { + stop("Forecast selection requires unique dated historical actuals.", call. = FALSE) + } + } + eligible <- if (quality) selection$rankings$Model_ID[selection$rankings$Eligible] else unique(rows$Model_ID) + averages <- list() + if (length(eligible) >= 2L && max_average >= 2L) { + for (size in seq.int(2L, min(max_average, length(eligible)))) { + combinations <- utils::combn(sort(eligible), size, simplify = FALSE) + averages <- c(averages, lapply(combinations, function(components) { + rows[rows$Model_ID %in% components, ] %>% + dplyr::group_by(Combo, Train_Test_ID, Date) %>% + dplyr::summarise(Target = mean(Target, na.rm = TRUE), Forecast = mean(Forecast), .groups = "drop") %>% + dplyr::mutate(Model_ID = paste(components, collapse = "_"), Model_Name = NA_character_, + Model_Type = "local", Recipe_ID = "simple_average") + })) + } + } + candidates <- dplyr::bind_rows(c(list(rows), averages)) + if (quality) { + selection <- select_series_forecasts(candidates, context, fixture$splits) + chosen <- selection$selected_id + } else { + ids <- sort(unique(candidates$Model_ID)) + scores <- vapply(ids, function(model_id) { + backtest <- candidates[candidates$Model_ID == model_id & candidates$Train_Test_ID != 1L, ] + forecast_backtest_accuracy(context$history, backtest)$WMAPE + }, numeric(1)) + chosen <- ids[order(scores, ids, na.last = TRUE)][1] + } + if (is.na(chosen)) abort_forecast_selection(combo, selection) + selected <- candidates[candidates$Model_ID == chosen, , drop = FALSE] + selected$Best_Model <- "Yes" + selected$Run_Type <- fixture$splits$Run_Type[match(selected$Train_Test_ID, fixture$splits$Train_Test_ID)] + list(forecasts = selected, selection = selection) + }) + list(forecasts = dplyr::bind_rows(lapply(results, `[[`, "forecasts")), + selections = stats::setNames(lapply(results, `[[`, "selection"), names(fixture$contexts))) +} + +reconcile_pre_selection_case <- function(fixture, selected) { + testthat::local_mocked_bindings(read_file = function(run_info, path, return_type = "df", ...) { + if (return_type == "object") fixture$metadata else fixture$history + }, .package = "finnts") + reconcile(selected$forecasts, fixture$run_info, fixture$approach, fixture$negative_forecast) +} + +score_pre_selection_case <- function(fixture, forecast) { + future <- forecast[forecast$Train_Test_ID == 1L, ] + measured <- dplyr::inner_join(future[, c("Combo", "Date", "Forecast")], fixture$held_out, by = c("Combo", "Date")) + stopifnot(nrow(measured) == nrow(fixture$held_out), all(is.finite(measured$Forecast))) + errors <- abs(measured$Forecast - measured$Truth) + scales <- pmax(abs(measured$Truth), 1) + shapes <- lapply(split(measured, measured$Combo), function(series) { + series <- series[order(series$Date), ] + scale <- max(abs(series$Truth), 1) + amplitude <- diff(range(series$Truth)) + c(endpoint = abs(utils::tail(series$Forecast - series$Truth, 1)) / scale, + slope = abs(stats::median(diff(series$Forecast)) - stats::median(diff(series$Truth))) / scale, + amplitude = if (amplitude > 1e-10) abs(diff(range(series$Forecast)) / amplitude - 1) else NA_real_, + phase = if (stats::sd(series$Truth) > 1e-10 && stats::sd(series$Forecast) > 1e-10) { + stats::cor(series$Truth, series$Forecast) + } else NA_real_) + }) + shape_matrix <- do.call(rbind, shapes) + finite_max <- function(values) if (any(is.finite(values))) max(values[is.finite(values)]) else NA_real_ + untouched <- !measured$Combo %in% fixture$affected_bottoms + c(relative_error = sum(errors) / max(sum(abs(measured$Truth)), 1), + maximum_point_error = max(errors / scales), + total_error = sum(abs(tapply(measured$Forecast - measured$Truth, measured$Date, sum))) / + max(sum(abs(measured$Truth)), 1), endpoint_error = finite_max(shape_matrix[, "endpoint"]), + slope_error = finite_max(shape_matrix[, "slope"]), amplitude_error = finite_max(shape_matrix[, "amplitude"]), + phase_correlation = -finite_max(-shape_matrix[, "phase"]), + sibling_error = if (any(untouched)) sum(errors[untouched]) / max(sum(abs(measured$Truth[untouched])), 1) else 0) +} + +measure_pre_selection_case <- function(fixture) { + baseline_seconds <- system.time(baseline <- select_pre_reconciliation_inputs(fixture, quality = FALSE))[["elapsed"]] + selected_seconds <- system.time(selected <- select_pre_reconciliation_inputs(fixture))[["elapsed"]] + baseline_hts_seconds <- system.time(before_rows <- reconcile_pre_selection_case(fixture, baseline))[["elapsed"]] + selected_hts_seconds <- system.time(after_rows <- reconcile_pre_selection_case(fixture, selected))[["elapsed"]] + before <- score_pre_selection_case(fixture, before_rows) + after <- score_pre_selection_case(fixture, after_rows) + accuracy_ok <- all(vapply(selected$selections, function(selection) { + eligible <- selection$rankings[selection$rankings$Eligible, ] + best <- min(eligible$WMAPE) + chosen <- eligible[eligible$Model_ID == selection$selected_id, ] + nrow(chosen) == 1L && chosen$WMAPE <= best + max(0.005, 0.05 * best) + 1e-12 + }, logical(1))) + improved <- after[["relative_error"]] < before[["relative_error"]] - 1e-8 + meets_expectation <- if (fixture$placement == "all" && fixture$pathology != "clean") { + before[["relative_error"]] > 0.01 && after[["relative_error"]] < before[["relative_error"]] / 2 - 1e-10 + } else NA + data.frame(Approach = fixture$approach, Placement = fixture$placement, Pathology = fixture$pathology, + Series = length(fixture$metadata$original_combos), Nodes = length(fixture$metadata$hts_combos), + Before_Error = before[["relative_error"]], After_Error = after[["relative_error"]], + Before_Maximum = before[["maximum_point_error"]], After_Maximum = after[["maximum_point_error"]], + Before_Endpoint = before[["endpoint_error"]], After_Endpoint = after[["endpoint_error"]], + Before_Slope = before[["slope_error"]], After_Slope = after[["slope_error"]], + Before_Amplitude = before[["amplitude_error"]], After_Amplitude = after[["amplitude_error"]], + Before_Phase = before[["phase_correlation"]], After_Phase = after[["phase_correlation"]], + Before_Sibling = before[["sibling_error"]], After_Sibling = after[["sibling_error"]], + Preselection_Accuracy_OK = accuracy_ok, Meets_Expectation = meets_expectation, + Outcome = if (after[["relative_error"]] < 1e-6 && before[["relative_error"]] > 0.01) "fixed" else + if (improved) "improved" else if (before[["relative_error"]] < 0.01) "attenuated" else "remaining distortion", + Baseline_Selection_Seconds = baseline_seconds, Quality_Selection_Seconds = selected_seconds, + Baseline_Hts_Seconds = baseline_hts_seconds, Selected_Hts_Seconds = selected_hts_seconds) +} + +make_reconciled_selection_fixture <- function(approach = "standard_hierarchy", date_type = "month") { + values <- c(100, 120, 80, 110) + original_combos <- paste0("series-", seq_along(values)) + bottom <- matrix(rep(values, each = 36), nrow = 36, dimnames = list(NULL, original_combos)) + hierarchy <- if (approach == "standard_hierarchy") { + hts::hts(stats::ts(bottom), nodes = list(2L, c(2L, 2L))) + } else { + hts::gts(stats::ts(bottom), groups = rbind(c(1L, 1L, 2L, 2L), c(1L, 2L, 1L, 2L))) + } + all_values <- hts::allts(hierarchy) + stored_combos <- paste0("stored-", seq_len(ncol(all_values))) + metadata <- list(original_combos = original_combos, hts_combos = stored_combos, + nodes = if (approach == "standard_hierarchy") hts::get_nodes(hierarchy) else hts::get_groups(hierarchy)) + contexts <- lapply(values, function(value) { + fixture <- make_selection_case(actuals = rep(value, 36), + futures = list(accurate = rep(3 * value, 6), safe = rep(value, 6)), date_type = date_type) + fixture$context$history <- fixture$history + fixture$context + }) + predictions <- dplyr::bind_rows(lapply(seq_along(stored_combos), function(series_index) { + value <- all_values[36, series_index] + fixture <- make_selection_case(actuals = rep(value, 36), + futures = list(accurate = rep(3 * value, 6), safe = rep(value, 6)), date_type = date_type) + dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::mutate(Combo = stored_combos[series_index], + Best_Model = ifelse(Model_ID == "accurate", "Yes", "No"), + Run_Type = ifelse(Train_Test_ID == 1, "Future_Forecast", "Back_Test")) + })) + history <- dplyr::bind_rows(lapply(seq_along(contexts), function(series_index) { + dplyr::mutate(contexts[[series_index]]$history, Combo = original_combos[series_index]) + })) + list(metadata = metadata, contexts = contexts, history = history, forecasts = predictions, + splits = contexts[[1]]$train_test_split, values = stats::setNames(values, original_combos), + run_inputs = data.frame(combo = utils::tail(stored_combos, length(values)), + model_type = "local", best_run_name = "previous"), + agent_info = list(forecast_approach = approach), + project_info = list(project_name = "reconciliation-test", run_name = "outer", + date_type = date_type, data_output = "csv", object_output = "rds")) +} \ No newline at end of file diff --git a/tests/testthat/test-agent-artifact-reads.R b/tests/testthat/test-agent-artifact-reads.R index 6983f0ff..d5d7f7f2 100644 --- a/tests/testthat/test-agent-artifact-reads.R +++ b/tests/testthat/test-agent-artifact-reads.R @@ -129,6 +129,91 @@ test_that("local submission reads its exact input before starting modeling", { ) }) +for (provider in c("blob_container", "ms_drive")) { + test_that(paste("best-run retrieval downloads CSV metadata independently of data format on", provider), { + source <- artifact_test_agent(withr::local_tempdir(), "rds") + expected <- tibble::tibble(combo = "A", model_type = "local", best_run_name = "selected", weighted_mape = 0.1) + write_data(expected, "A", source$project_info, "log", "logs", "-agent_best_run") + agent <- source + agent$project_info$path <- "provider-artifacts" + transport <- local_artifact_provider(provider) + agent$project_info$storage_object <- transport$storage_object + path <- artifact_test_path(agent$project_info, "logs", "A", "-agent_best_run", "csv") + transport$files[[as.character(path)]] <- artifact_test_path(source$project_info, "logs", "A", "-agent_best_run", "csv") + listings <- 0L + local_mocked_bindings(list_files = function(storage_object, path, fail_on_error = FALSE) { + listings <<- listings + 1L + expect_true(fail_on_error) + expect_match(path, "-agent_best_run[.]csv$") + files <- names(transport$files) + if (provider == "ms_drive") fs::path_file(files) else files + }) + + result <- load_best_agent_run(agent) + + expect_equal(result, expected) + expect_equal(listings, 1L) + expect_identical(transport$downloads, as.character(path)) + }) +} + +for (provider in c("blob_container", "ms_drive")) { + test_that(paste("hierarchical Agent publication downloads only its exact best artifact on", provider), { + source <- artifact_test_run(withr::local_tempdir(), "rds") + best <- artifact_test_forecast(source, write_output = FALSE) + best$Model_ID <- "Best-Model" + write_data(best, "Best-Model", source, "data", "forecasts", "-reconciled") + transport <- local_artifact_provider(provider) + project <- source + project$path <- "provider-artifacts" + project$storage_object <- transport$storage_object + agent <- list(run_id = source$run_name, project_info = project, forecast_approach = "standard_hierarchy") + best_path <- artifact_test_path(project, "forecasts", "Best-Model", "-reconciled") + alternative_path <- artifact_test_path(project, "forecasts", "meanf--local--R1", "-reconciled") + transport$files[[as.character(best_path)]] <- artifact_test_path(source, "forecasts", "Best-Model", "-reconciled") + transport$files[[as.character(alternative_path)]] <- transport$files[[as.character(best_path)]] + local_mocked_bindings(check_agent_info = function(...) NULL) + + result <- load_agent_forecast(agent, final_output = TRUE) + + expect_equal(result, best) + expect_identical(transport$downloads, as.character(best_path)) + transport$files[[as.character(best_path)]] <- NULL + expect_error(load_agent_forecast(agent, final_output = TRUE), class = "http_404") + }) +} + +test_that("hierarchical Agent publication and getter ignore per-model reconciled alternatives", { + agent <- artifact_test_agent(withr::local_tempdir()) + agent$forecast_approach <- "grouped_hierarchy" + info <- agent$project_info + info$run_name <- agent$run_id + best <- artifact_test_forecast(info, write_output = FALSE) + best$Model_ID <- "Best-Model" + historical <- best + historical$Train_Test_ID <- 2 + historical$Date <- as.Date("2024-01-01") + historical$Target <- 100 + best <- dplyr::bind_rows(best, historical) + write_data(best, "Best-Model", info, "data", "forecasts", "-reconciled") + alternative <- best + alternative$Model_ID <- "arima--local--R1" + alternative$Best_Model <- "No" + alternative$Forecast <- 1e6 + write_data(alternative, alternative$Model_ID, info, "data", "forecasts", "-reconciled") + tracker <- local_artifact_spies() + local_mocked_bindings(check_agent_info = function(...) NULL) + + save_agent_forecast(agent) + result <- get_agent_forecast(agent) + + expect_equal(result, best) + expect_identical(unique(result$Model_ID), "Best-Model") + expect_true(all(result$Best_Model == "Yes")) + expect_equal(tracker$listings, 0L) + expect_false(any(grepl(hash_data(alternative$Model_ID), tracker$payload_paths, fixed = TRUE))) +}) + test_that("reconciliation reads the selected run split by exact path", { agent_info <- artifact_test_agent(withr::local_tempdir()) project_info <- agent_info$project_info @@ -157,6 +242,33 @@ test_that("reconciliation reads the selected run split by exact path", { ) }) +for (provider in c("blob_container", "ms_drive")) { + test_that(paste("outer Agent reconciliation transfers the required exact split on", provider), { + agent <- artifact_test_agent(withr::local_tempdir(), "rds") + selected <- agent$project_info + selected$project_name <- paste0(selected$project_name, "_", hash_data("A")) + selected$run_name <- "selected" + artifact_test_splits(selected) + source_path <- artifact_test_path(selected, "prep_models", suffix = "-train_test_split") + agent$project_info$path <- "provider-artifacts" + transport <- local_artifact_provider(provider) + agent$project_info$storage_object <- transport$storage_object + selected$path <- agent$project_info$path + path <- artifact_test_path(selected, "prep_models", suffix = "-train_test_split") + transport$files[[as.character(path)]] <- source_path + local_mocked_bindings( + check_agent_info = function(...) NULL, + get_best_agent_run = function(...) tibble::tibble(negative_forecast = FALSE, + model_type = "local", combo = "A", best_run_name = "selected"), + load_agent_forecast = function(...) stop("exact split successfully loaded", call. = FALSE) + ) + + expect_error(reconcile_agent_forecast(agent, agent$project_info), + "exact split successfully loaded", fixed = TRUE) + expect_identical(transport$downloads, as.character(path)) + }) +} + test_that("model summaries consolidate only expected combo artifacts", { agent_info <- artifact_test_agent(withr::local_tempdir()) best_runs <- artifact_test_selected_models(agent_info) diff --git a/tests/testthat/test-agent-forecast-selection.R b/tests/testthat/test-agent-forecast-selection.R new file mode 100644 index 00000000..5a0c1ada --- /dev/null +++ b/tests/testthat/test-agent-forecast-selection.R @@ -0,0 +1,794 @@ +test_that("quality-rejected updates bypass only the ordinary failure limit", { + local_mocked_bindings(resolve_combo_hashes = function(agent_info, combos) combos) + combos <- paste0("combo-", 1:30) + previous <- data.frame(combo = combos) + expect_setequal(check_update_failures(list(), previous, combos, character(), character(), + global_quality_rejected = combos), combos) + expect_error(check_update_failures(list(), previous, combos, combos[1:11], character(), + global_quality_rejected = combos), "exceeds") + expect_setequal(check_update_failures(list(), previous, combos, combos[1], character(), + global_quality_rejected = c(combos[1:2], "removed")), combos[1:2]) +}) + +test_that("update assessment preserves healthy series and rejects a bad sibling", { + fixture <- make_selection_case(futures = list(only = rep(100, 6)), errors = c(only = 0.03)) + series <- fixture$context + series$history <- fixture$history + local_mocked_bindings(read_series_history = function(...) series) + rows <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::mutate(Combo = "healthy", Best_Model = "Yes", Recipe_ID = "R1") + bad <- rows %>% dplyr::mutate(Combo = "bad", Forecast = ifelse(Train_Test_ID == 1, 1e8, Forecast)) + result <- assess_update_forecasts(dplyr::bind_rows(rows, bad), list(), list(), fixture$context$train_test_split) + expect_identical(unique(result$forecasts$Combo), "healthy") + expect_identical(result$quality_rejected_combos, hash_data("bad")) +}) + +test_that("update forecast assembly leaves reconciliation until after quality assessment", { + fixture <- make_reconciled_selection_fixture() + predictions <- fixture$forecasts[fixture$forecasts$Model_ID == "safe", ] + fitted <- make_fitted_selection_models(predictions) + solver_calls <- 0L + local_mocked_bindings(reconcile = function(initial_fcst, ...) { + solver_calls <<- solver_calls + 1L + initial_fcst + }) + result <- adjust_forecast(fitted, fixture$project_info, "standard_hierarchy", FALSE) + expect_identical(solver_calls, 0L) + expect_setequal(unique(result$Combo), fixture$metadata$hts_combos) + expect_setequal(unique(result$Recipe_ID), c("R1", "simple_average")) + expect_true(all(result$Best_Model[result$Recipe_ID == "simple_average"] == "Yes")) +}) + +test_that("hierarchical update quality is checked before a single selected-only reconciliation", { + fixture <- make_reconciled_selection_fixture() + raw <- adjust_forecast(make_fitted_selection_models( + fixture$forecasts[fixture$forecasts$Model_ID == "safe", ]), fixture$project_info, + "standard_hierarchy", FALSE) + contexts <- stats::setNames(lapply(fixture$metadata$hts_combos, function(combo) { + context <- fixture$contexts[[1]] + context$history$Target <- raw$Forecast[raw$Combo == combo & raw$Train_Test_ID == 1][1] + context + }), fixture$metadata$hts_combos) + events <- character() + original_selector <- select_series_forecasts + original_reconcile <- reconcile + local_mocked_bindings( + read_selection_hierarchy = function(...) fixture$metadata, + read_series_history = function(run_info, combo, ...) contexts[[combo]], + read_file = function(run_info, path, return_type = "df", ...) { + if (return_type == "object") fixture$metadata else fixture$history + }, + select_series_forecasts = function(...) { events <<- c(events, "assess"); original_selector(...) }, + reconcile = function(initial_fcst, ...) { + events <<- c(events, "reconcile") + expect_true(all(initial_fcst$Best_Model == "Yes")) + original_reconcile(initial_fcst, ...) + } + ) + log <- data.frame(forecast_approach = "standard_hierarchy", date_type = "month", negative_forecast = FALSE) + result <- assess_update_forecasts(raw, fixture$project_info, log, fixture$splits) + expect_identical(events, c(rep("assess", length(contexts)), "reconcile")) + expect_setequal(unique(result$forecasts$Combo), fixture$metadata$original_combos) + expect_true(all(result$forecasts$Best_Model == "Yes")) + expect_identical(names(result$source_selections), fixture$metadata$hts_combos) + + raw$Forecast[raw$Combo == fixture$metadata$hts_combos[1] & + raw$Recipe_ID == "R1" & raw$Train_Test_ID == 1] <- Inf + rejected <- assess_update_forecasts(raw, fixture$project_info, log, fixture$splits) + expect_equal(nrow(rejected$forecasts), 0) + expect_setequal(rejected$quality_rejected_combos, + vapply(fixture$metadata$original_combos, hash_data, character(1), USE.NAMES = FALSE)) + expect_equal(sum(events == "reconcile"), 1) + missing <- raw[raw$Combo != fixture$metadata$hts_combos[1], ] + expect_equal(nrow(assess_update_forecasts(missing, fixture$project_info, log, fixture$splits)$forecasts), 0) + expect_equal(sum(events == "reconcile"), 1) +}) + +for (date_type in c("month", "week")) test_that( + paste("hierarchical refit and retune preserve solver settings before final logging", date_type), { + fixture <- make_reconciled_selection_fixture(date_type = date_type) + base <- fixture$forecasts[fixture$forecasts$Model_ID == "safe", ] + fitted <- make_fitted_selection_models(base) + contexts <- stats::setNames(lapply(fixture$metadata$hts_combos, function(combo) { + context <- fixture$contexts[[1]] + context$history$Target <- base$Forecast[base$Combo == combo & base$Train_Test_ID == 1][1] + context + }), fixture$metadata$hts_combos) + previous <- data.frame(models_to_run = "xgboost---chronos2", external_regressors = NA_character_, + lag_periods = NA_character_, rolling_window_periods = NA_character_, seasonal_period = 12, + forecast_approach = "standard_hierarchy", date_type = date_type, negative_forecast = FALSE, + box_cox = FALSE, stationary = FALSE, feature_selection = FALSE, global_model_recipes = "R1", + average_models = TRUE, max_model_average = 3L, weekly_to_daily = date_type == "week") + events <- character() + settings <- list() + writes <- list() + logged <- NULL + logged_metric <- NULL + invalid_retune <- FALSE + original_selector <- select_series_forecasts + original_reconcile <- reconcile + local_mocked_bindings( + get_run_info = function(...) previous, + validate_prev_run_log = function(log) log, + list_files = function(...) "input.csv", + read_file = function(run_info, file_list = NULL, path = NULL, return_type = "df", ...) { + if (return_type == "object") return(fixture$metadata) + if (!is.null(path)) return(fixture$history) + if (any(grepl("/models/", file_list, fixed = TRUE))) { + return(data.frame(Model_ID = c("xgboost--global--R1", "chronos2--global--R1"))) + } + fixture$history + }, + set_run_info = function(...) fixture$project_info, + prep_data = function(...) NULL, + prep_models = function(...) NULL, + get_prepped_models = function(...) tibble::tibble(Type = c("Train_Test_Splits", "Model_Hyperparameters"), + Data = list(fixture$splits, data.frame(Hyperparameter_ID = 1L))), + fit_models = function(retune_hyperparameters, ...) { + events <<- c(events, if (retune_hyperparameters) "retune" else "refit") + updated <- fitted + if (retune_hyperparameters && invalid_retune) { + updated$Forecast_Tbl <- lapply(updated$Forecast_Tbl, function(rows) { + rows$Forecast[rows$Combo == fixture$metadata$hts_combos[1] & rows$Train_Test_ID == 1L] <- Inf + rows + }) + } + updated + }, + read_selection_file = function(...) previous[, names(previous) != "negative_forecast", drop = FALSE], + read_selection_hierarchy = function(...) fixture$metadata, + read_candidate_forecasts = function(...) { + adjust_forecast(fitted, fixture$project_info, "standard_hierarchy", FALSE) + }, + read_series_history = function(run_info, combo, ...) contexts[[combo]], + select_series_forecasts = function(...) { events <<- c(events, "assess"); original_selector(...) }, + reconcile = function(initial_fcst, run_info, forecast_approach, negative_forecast) { + events <<- c(events, "reconcile") + settings[[length(settings) + 1L]] <<- negative_forecast + expect_true(all(initial_fcst$Best_Model == "Yes")) + original_reconcile(initial_fcst, run_info, forecast_approach, negative_forecast) + }, + write_data = function(x, combo, suffix, ...) { writes[[length(writes) + 1L]] <<- list(data = x, combo = combo, suffix = suffix) }, + validate_run_outputs = function(...) TRUE, + log_best_run = function(run_info, weighted_mape, ...) { + logged <<- run_info$forecast_selection + logged_metric <<- weighted_mape + } + ) + agent <- list(project_info = fixture$project_info, run_id = "updated", forecast_horizon = 6) + selected <- data.frame(combo = fixture$metadata$original_combos, model_type = "global", + best_run_name = "previous", weighted_mape = 0.01) + expect_no_error(update_forecast_combo(agent, selected, NULL, 1, FALSE, 123)) + expect_identical(events, c("refit", rep("assess", length(contexts)), "reconcile", + "retune", rep("assess", length(contexts)), "reconcile")) + expect_identical(settings, list(FALSE, FALSE)) + expect_setequal(names(logged$source_selections), fixture$metadata$hts_combos) + expect_setequal(names(logged$selections), fixture$metadata$original_combos) + expect_equal(sum(vapply(writes, function(write) identical(write$suffix, "-reconciled"), logical(1))), 1L) + expect_equal(sum(vapply(writes, function(write) identical(write$suffix, "-global_models"), logical(1))), length(contexts)) + completed <- writes[[which(vapply(writes, function(write) identical(write$suffix, "-reconciled"), logical(1)))]]$data + expect_identical("Date_Day" %in% names(completed), date_type == "week") + expect_false("Run_Type" %in% names(completed)) + keys <- c("Combo", "Train_Test_ID", "Date", "Model_ID") + expect_equal(nrow(completed), nrow(unique(completed[, keys])) * if (date_type == "week") 7L else 1L) + completed$Run_Type <- fixture$splits$Run_Type[match(completed$Train_Test_ID, fixture$splits$Train_Test_ID)] + expected <- vapply(split(completed, completed$Combo), function(rows) round(calc_wmape(rows), 4), numeric(1)) + expect_equal(attr(logged_metric, "forecast_accuracy")$by_series[names(expected)], expected) + native_log <- writes[[which(vapply(writes, function(write) is.null(write$suffix), logical(1)))]]$data + expect_equal(as.numeric(logged_metric), round(native_log$weighted_mape, 4)) + + events <- character() + settings <- list() + writes <- list() + logged <- NULL + invalid_retune <- TRUE + rejected <- update_forecast_combo(agent, selected, NULL, 1, FALSE, 123) + expect_identical(events, c("refit", rep("assess", length(contexts)), "reconcile", + "retune", rep("assess", length(contexts)))) + expect_identical(settings, list(FALSE)) + expect_length(writes, 0L) + expect_null(logged) + expect_setequal(rejected$quality_rejected_combos, + vapply(fixture$metadata$original_combos, hash_data, character(1), USE.NAMES = FALSE)) +}) + +test_that("update assessment rejects an invalid component even if its average looks valid", { + fixture <- make_selection_case() + series <- fixture$context + series$history <- fixture$history + local_mocked_bindings(read_series_history = function(...) series) + rows <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::mutate(Combo = "Synthetic", Best_Model = ifelse(Model_ID == "safe", "Yes", "No"), + Recipe_ID = ifelse(Model_ID == "safe", "simple_average", "R1"), + Forecast = ifelse(Model_ID == "accurate" & Train_Test_ID == 1, NA_real_, Forecast)) + result <- assess_update_forecasts(rows, list(), list(), fixture$context$train_test_split) + expect_equal(nrow(result$forecasts), 0) + expect_identical(result$quality_rejected_combos, hash_data("Synthetic")) +}) + +test_that("quality failures are not retried as infrastructure failures", { + calls <- 0L + local_mocked_bindings( + submit_fcst_run = function(...) { + calls <<- calls + 1L + rlang::abort("no acceptable candidate", class = "finnts_forecast_selection_rejected") + }, + wait_before_retry = function(...) stop("must not wait") + ) + expect_error(execute_node(list(fn = "submit_fcst_run", max_retry = 3, retry_mode = "plain"), + list(args = list(), results = list(), attempts = list()), NULL), + class = "finnts_forecast_selection_rejected") + expect_identical(calls, 1L) +}) + +test_that("final selection returns rejected evaluations without publishing a best model", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + run_info <- make_best_models_fixture() + path <- locate_single_models_file(run_info) + rows <- read_fcst_file(path) + rows$Forecast[rows$Train_Test_ID == 1] <- Inf + write_fcst_file(rows, path) + run_info$allow_quality_rejection <- TRUE + result <- final_models(run_info) + expect_identical(result$rejected_combos, "Synthetic") + expect_true(all(read_fcst_file(path)$Best_Model == "No")) + expect_error(get_forecast_data(run_info), "missing a best model") +}) + +test_that("Agent run comparison chooses lower accuracy error and keeps a fixed anchor", { + fixture <- make_selection_case() + first <- fixture + first$context$candidate_ids <- "accurate" + second <- fixture + second$context$candidate_ids <- "safe" + results <- list( + list(selections = list(series = do.call(select_forecast_candidate, first))), + list(selections = list(series = do.call(select_forecast_candidate, second))) + ) + expect_identical(rank_agent_run_selections(results)$series$series, 1L) + expect_identical(rank_agent_run_selections(results)$best_run_index, 1L) + rejected <- results[[1]] + rejected$selections$series$selected_id <- NA_character_ + expect_false(agent_selection_summary(rejected)$acceptable) + expect_identical(agent_selection_summary(rejected)$status, "rejected") + expect_identical(rank_agent_run_selections(c(results, list(rejected)))$series$series, 1L) +}) + +test_that("seasonal preferences remain in selection rather than iteration comparison", { + profile <- cos(2 * pi * (seq_len(12) - 0.5) / 12) + fixture <- make_selection_case(100 + rep(10 * profile, 4), + futures = list(diluted = 100 + 5 * profile, intact = 100 + 10 * profile), + errors = c(diluted = 0.0815, intact = 0.083)) + results <- lapply(c("diluted", "intact"), function(model_id) { + candidate <- fixture + candidate$context$candidate_ids <- model_id + list(selections = list(series = do.call(select_forecast_candidate, candidate))) + }) + summary <- agent_selection_summary(results[[1]]) + expect_true(summary$acceptable) + expect_equal(summary$seasonal_fidelity, 0.45, tolerance = 1e-10) + expect_identical(rank_agent_run_selections(results)$series$series, 1L) + expect_identical(rank_agent_run_selections(results)$best_run_index, 1L) + + series <- fixture$context + series$history <- fixture$history + local_mocked_bindings(read_series_history = function(...) series) + rows <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::filter(Model_ID == "diluted") %>% + dplyr::mutate(Combo = "series", Best_Model = "Yes", Recipe_ID = "R1") + reused <- assess_update_forecasts(rows, list(), list(), fixture$context$train_test_split) + expect_length(reused$quality_rejected_combos, 0L) + expect_equal(nrow(reused$forecasts), nrow(rows)) + + first <- list(selections = results[[2]]$selections, + source_selections = list(root = results[[1]]$selections$series, leaf = results[[2]]$selections$series)) + first$selections$series$rankings$WMAPE <- 0.02 + second <- first + second$source_selections$root <- results[[2]]$selections$series + second$selections$series$rankings$WMAPE <- 0.022 + summary <- agent_selection_summary(first, check_quality = TRUE) + expect_equal(summary$weighted_mape, 0.02) + expect_equal(summary$seasonal_fidelity, 0.45, tolerance = 1e-10) + expect_true(summary$acceptable) + expect_identical(rank_agent_run_selections(list(first, second))$series$series, 1L) + expect_identical(rank_agent_run_selections(list(first, second))$best_run_index, 1L) + first$source_selections$root$rankings$Seasonal_Fidelity <- NA_real_ + expect_identical(agent_selection_summary(first, check_quality = TRUE)$seasonal_fidelity, NA_real_) + expect_identical(rank_agent_run_selections(list(first, second))$best_run_index, 1L) + results[[1]]$selections$series$rankings$Seasonal_Fidelity <- NULL + expect_identical(agent_selection_summary(results[[1]])$seasonal_fidelity, NA_real_) + expect_identical(rank_agent_run_selections(results)$best_run_index, 1L) +}) + +test_that("selected Agent results use existing log files only", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + info$forecast_selection <- final_models(info) + agent <- list(project_info = info, run_id = "agent-parent", agent_version = 1, + forecast_approach = "bottoms_up") + result <- log_best_run(agent, info, 0.1, combo = hash_data("Synthetic"), check_best_run = FALSE) + expect_identical(result$status, "evaluated") + saved_log <- read_selection_file(info, "logs") + expect_identical(saved_log$selection_status, "evaluated") + parent <- info + parent$run_name <- agent$run_id + best <- read_selection_file(parent, "logs", "-agent_best_run", "Synthetic") + expect_identical(best$best_run_name, info$run_name) + expect_true(is.finite(best$weighted_mape)) + expect_false(any(grepl("quality|selection", list.files(info$path, recursive = TRUE)))) +}) + +test_that("rejected Agent attempts keep finite bookkeeping and consume history slots", { + fixture <- make_selection_case() + fixture$forecasts$Forecast <- Inf + rejected <- do.call(select_forecast_candidate, fixture) + run_log <- data.frame(run_name = "attempt", models_to_run = "arima") + agent <- list(agent_version = 2, forecast_approach = "bottoms_up") + recorded <- record_agent_selection_attempt(run_log, list(selections = list(series = rejected)), agent) + expect_identical(recorded$selection_status, "rejected") + expect_true(is.na(recorded$weighted_mape)) + expect_equal(new_reason_history(recorded, agent_version = 2)$total_runs, 1) +}) + +test_that("partial global runs cannot win by omitting a difficult series", { + fixture <- make_selection_case() + selection <- do.call(select_forecast_candidate, fixture) + rejected <- selection + rejected$selected_id <- NA_character_ + results <- list( + list(selections = list(first = selection, second = rejected)), + list(selections = list(first = selection, second = selection)) + ) + ranked <- rank_agent_run_selections(results) + expect_identical(ranked$best_run_index, 2L) + expect_identical(ranked$series$first, 1L) + expect_identical(ranked$series$second, 2L) +}) + +test_that("hierarchical resume restores accuracy without source-quality assessment", { + fixture <- make_reconciled_selection_fixture() + base <- fixture$forecasts[fixture$forecasts$Model_ID == "safe", ] + base$Best_Model <- "Yes" + contexts <- stats::setNames(lapply(fixture$metadata$hts_combos, function(combo) { + level <- base$Forecast[base$Combo == combo & base$Train_Test_ID == 1][1] + context <- fixture$contexts[[1]] + context$history$Target <- level + context + }), fixture$metadata$hts_combos) + delivered <- base[base$Combo %in% fixture$run_inputs$combo, ] + delivered$Combo <- fixture$metadata$original_combos[match(delivered$Combo, fixture$run_inputs$combo)] + delivered$Model_ID <- "Best-Model" + delivered$Forecast <- ifelse(delivered$Train_Test_ID == 1, 1e8, delivered$Target * 1.02) + assessed_combos <- character() + local_mocked_bindings( + list_files = function(...) stop("must not list"), + read_selection_hierarchy = function(...) fixture$metadata, + read_selection_file = function(...) fixture$splits, + read_candidate_forecasts = function(..., reconciled = TRUE) { + if (!reconciled) stop("must not reload source forecasts for quality assessment") + delivered + }, + read_series_history = function(run_info, combo, ...) contexts[[combo]], + select_series_forecasts = function(predictions, ...) { + assessed_combos <<- c(assessed_combos, unique(predictions$Combo)) + stop("must not repeat future-quality selection") + } + ) + log <- data.frame(forecast_approach = "standard_hierarchy", date_type = "month") + result <- assess_agent_run(fixture$project_info, log, fixture$metadata$original_combos) + expect_true(agent_selection_summary(result)$acceptable) + expect_equal(agent_selection_summary(result)$weighted_mape, 0.02) + expect_identical(names(result$selections), fixture$metadata$original_combos) + expect_length(result$source_selections, 0L) + expect_length(assessed_combos, 0L) + + root <- base$Combo == fixture$metadata$hts_combos[1] & base$Train_Test_ID == 1 + base$Forecast[root] <- base$Forecast[root] * 3 + concerned <- assess_agent_run(fixture$project_info, log, fixture$metadata$original_combos) + expect_true(agent_selection_summary(concerned)$acceptable) + expect_true(is.na(agent_selection_summary(concerned)$risk)) + expect_equal(agent_selection_summary(concerned)$weighted_mape, 0.02) + expect_equal(concerned$selections, result$selections) +}) + +test_that("fresh and resumed hierarchical artifacts preserve heterogeneous source winners", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + for (approach in c("standard_hierarchy", "grouped_hierarchy")) { + fixture <- make_hierarchical_selection_artifacts(approach) + result <- final_models(fixture$run_info, average_models = FALSE, weekly_to_daily = FALSE) + log <- read_selection_file(fixture$run_info, "logs") + expect_identical(names(result$selections), fixture$metadata$original_combos) + expect_setequal(names(result$source_selections), fixture$metadata$hts_combos) + expect_setequal(vapply(result$source_selections, `[[`, character(1), "selected_id"), + c("arima--local--R1", "ets--local--R1")) + source <- read_candidate_forecasts(fixture$run_info, fixture$metadata$hts_combos, log, reconciled = FALSE) + chosen <- source[source$Best_Model == "Yes", ] + chosen$Run_Type <- fixture$splits$Run_Type[match(chosen$Train_Test_ID, fixture$splits$Train_Test_ID)] + expected <- reconcile_pre_selection_case(fixture, list(forecasts = chosen)) + delivered <- read_candidate_forecasts(fixture$run_info, fixture$metadata$original_combos, log) + keys <- c("Combo", "Train_Test_ID", "Date", "Forecast") + expect_equal(dplyr::arrange(delivered[, keys], Combo, Train_Test_ID, Date), + dplyr::arrange(expected[, keys], Combo, Train_Test_ID, Date), tolerance = 1e-7) + resumed <- assess_agent_run(fixture$run_info, log, fixture$metadata$original_combos) + expect_equal(agent_selection_summary(resumed), agent_selection_summary(result), tolerance = 1e-7) + delivered$Forecast[delivered$Train_Test_ID == 1] <- 1e8 + write_data(delivered, combo = "Best-Model", run_info = fixture$run_info, output_type = "data", + folder = "forecasts", suffix = "-reconciled") + reloaded <- assess_agent_run(fixture$run_info, log, fixture$metadata$original_combos) + expect_equal(agent_selection_summary(reloaded), agent_selection_summary(resumed)) + } +}) + +test_that("weekly hierarchy resume retains accuracy and native outputs after daily expansion", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + fixture <- make_hierarchical_selection_artifacts(date_type = "week", shape = "seasonal", + horizon = 6L, backtest_scenarios = 1L) + result <- final_models(fixture$run_info, average_models = FALSE, weekly_to_daily = FALSE) + log <- read_selection_file(fixture$run_info, "logs") + resumed <- assess_agent_run(fixture$run_info, log, fixture$metadata$original_combos) + expect_equal(agent_selection_summary(resumed), agent_selection_summary(result), tolerance = 1e-7) + expect_true(is.na(agent_selection_summary(resumed)$seasonal_fidelity)) + source <- read_candidate_forecasts(fixture$run_info, fixture$metadata$hts_combos, log, reconciled = FALSE) + source <- source[source$Best_Model == "Yes", ] + expect_setequal(unique(source$Combo), fixture$metadata$hts_combos) + expect_equal(nrow(source), length(fixture$metadata$hts_combos) * fixture$horizon * nrow(fixture$splits)) + for (combo in fixture$metadata$hts_combos) { + expanded <- convert_weekly_to_daily(source[source$Combo == combo, ], "week", TRUE) + write_data(expanded, combo = combo, run_info = fixture$run_info, output_type = "data", + folder = "forecasts", suffix = "-single_models") + } + delivered <- read_candidate_forecasts(fixture$run_info, fixture$metadata$original_combos, log) + delivered <- convert_weekly_to_daily(delivered, "week", TRUE) + write_data(delivered, combo = "Best-Model", run_info = fixture$run_info, output_type = "data", + folder = "forecasts", suffix = "-reconciled") + log$weekly_to_daily <- TRUE + write_data(log, combo = NULL, run_info = fixture$run_info, output_type = "log", folder = "logs", suffix = NULL) + log <- read_selection_file(fixture$run_info, "logs") + expanded_resumed <- assess_agent_run(fixture$run_info, log, fixture$metadata$original_combos) + expect_equal(expanded_resumed$source_selections, resumed$source_selections, tolerance = 1e-7) + expect_equal(expanded_resumed$selections, resumed$selections, tolerance = 1e-7) + expect_equal(agent_selection_summary(expanded_resumed), agent_selection_summary(resumed), tolerance = 1e-7) + native_source <- read_candidate_forecasts(fixture$run_info, fixture$metadata$hts_combos, log, reconciled = FALSE) + columns <- c("Combo", "Model_ID", "Train_Test_ID", "Date", "Forecast", "Target", "Best_Model") + expect_equal(dplyr::arrange(native_source[, columns], Combo, Model_ID, Train_Test_ID, Date), + dplyr::arrange(source[, columns], Combo, Model_ID, Train_Test_ID, Date), tolerance = 1e-7) + delivered$Forecast[delivered$Train_Test_ID == 1L] <- 1e8 + write_data(delivered, combo = "Best-Model", run_info = fixture$run_info, output_type = "data", + folder = "forecasts", suffix = "-reconciled") + altered_future <- assess_agent_run(fixture$run_info, log, fixture$metadata$original_combos) + expect_equal(agent_selection_summary(altered_future), agent_selection_summary(expanded_resumed)) +}) + +test_that("weekly Agent metrics and logs retain the completed-output zero-target WMAPE", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture(date_type = "week") + history <- read_selection_file(info, "prep_data", "-R1", "Synthetic") + forecasts <- read_selection_file(info, "forecasts", "-single_models", "Synthetic") + zero_dates <- unique(forecasts$Date[forecasts$Train_Test_ID > 1 & forecasts$Horizon == 1]) + history$Target[history$Date %in% zero_dates] <- 0 + forecasts$Target[forecasts$Date %in% zero_dates] <- 0 + forecasts$Forecast[forecasts$Date %in% zero_dates] <- 0 + write_data(history, combo = "Synthetic", run_info = info, output_type = "data", + folder = "prep_data", suffix = "-R1") + write_data(forecasts, combo = "Synthetic", run_info = info, output_type = "data", + folder = "forecasts", suffix = "-single_models") + + info$forecast_selection <- final_models(info, average_models = FALSE, weekly_to_daily = TRUE) + completed <- get_fcst_output(info) + original_wmape <- read_selection_file(info, "logs")$weighted_mape + native_wmape <- round(agent_selection_summary(info$forecast_selection)$weighted_mape, 4) + expect_true("Date_Day" %in% names(completed)) + expect_false(isTRUE(all.equal(original_wmape, native_wmape))) + restored <- info + restored$forecast_selection <- assess_agent_run(info, read_selection_file(info, "logs"), "Synthetic") + selections <- info$forecast_selection$selections + local_mocked_bindings( + list_files = function(...) stop("completed metrics must not enumerate artifacts"), + read_series_history = function(...) stop("completed metrics must use loaded backtests"), + forecast_path_risk = function(...) stop("completed metrics must not reassess future paths") + ) + metric <- calculate_fcst_metrics(info, completed) + expect_equal(as.numeric(metric), original_wmape) + expect_true(attr(metric, "selection_ok")) + expect_equal(as.numeric(calculate_fcst_metrics(restored, completed)), original_wmape) + expect_equal(agent_selection_summary(restored$forecast_selection)$weighted_mape, + agent_selection_summary(info$forecast_selection)$weighted_mape) + agent <- list(project_info = info, run_id = "metric-parent", agent_version = 1, + forecast_approach = "bottoms_up") + log_best_run(agent, info, metric, combo = hash_data("Synthetic"), check_best_run = FALSE) + parent <- info + parent$run_name <- agent$run_id + current <- read_selection_file(info, "logs") + saved <- read_selection_file(parent, "logs", "-agent_best_run", "Synthetic") + expect_equal(current$weighted_mape, original_wmape) + expect_equal(saved$weighted_mape, original_wmape) + expect_identical(info$forecast_selection$selections, selections) +}) + +test_that("default reforecast quality failure is attempted once through the graph", { + calls <- 0L + local_mocked_bindings( + get_foundation_model_suffix = function() "", + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + read_file = function(...) tibble::tibble(), + submit_fcst_run = function(...) { + calls <<- calls + 1L + rlang::abort("replacement is unusable", class = "finnts_forecast_selection_rejected") + }, + wait_before_retry = function(...) stop("quality failures must not wait"), + cancel_parallel = function(...) NULL + ) + agent <- list(run_id = "run", project_info = list(project_name = "project", path = tempdir())) + context <- list(args = list(agent_info = agent, new_combos = character(), failed_combos = "series-hash", + parallel_processing = NULL, inner_parallel = FALSE, num_cores = 1, seed = 1), + results = list(), attempts = list()) + expect_error(execute_node(list(fn = "forecast_new_combos", max_retry = 2, retry_mode = "plain"), context, NULL), + class = "finnts_forecast_selection_rejected") + expect_identical(calls, 1L) +}) + +test_that("Agent iteration continues until a complete forecast meets the accuracy goal", { + state <- new.env(parent = emptyenv()) + state$submissions <- 0L + state$refreshes <- 0L + chat <- new.env(parent = emptyenv()) + chat$set_system_prompt <- function(...) chat + local_mocked_bindings( + new_llm_session = function(llm) llm, + iterate_forecast_system_prompt = function(...) "prompt", + reason_inputs = function(...) list(models_to_run = "arima"), + submit_fcst_run = function(...) { state$submissions <- state$submissions + 1L; list() }, + get_fcst_output = function(...) data.frame(), + calculate_fcst_metrics = function(...) { + structure(if (state$submissions > 1) 0.01 else Inf, selection_ok = state$submissions > 1) + }, + log_best_run = function(...) "logged", + load_reason_history = function(...) { state$refreshes <- state$refreshes + 1L; list(total_runs = state$submissions) }, + finalize_run = function(...) "finalized" + ) + result <- fcst_agent_workflow(list(llm = chat, agent_version = 1), combo = "series", + weighted_mape_goal = 0.03, parallel_processing = NULL, inner_parallel = FALSE, + num_cores = 1, max_iter = 2, previous_run_results = "No Previous Runs") + expect_identical(state$submissions, 2L) + expect_identical(state$refreshes, 1L) + expect_identical(result$node, "stop") +}) + +test_that("a default replacement cannot publish success with soft quality concerns", { + fixture <- make_selection_case(futures = list(only = rep(200, 6)), errors = c(only = 0.01)) + selection <- do.call(select_forecast_candidate, fixture) + logged <- 0L + submitted <- 0L + local_mocked_bindings( + get_foundation_model_suffix = function() "", + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + read_file = function(...) tibble::tibble(), + submit_fcst_run = function(...) { + submitted <<- submitted + 1L + list(forecast_selection = list(selections = list(series = selection))) + }, + get_fcst_output = function(run_info) make_agent_metric_forecasts(run_info$forecast_selection), + log_best_run = function(...) { logged <<- logged + 1L }, + cancel_parallel = function(...) NULL + ) + agent <- list(run_id = "run", project_info = list(project_name = "project", path = tempdir())) + expect_error(forecast_new_combos(agent, character(), "series-hash", NULL, FALSE, 1, 1), + class = "finnts_forecast_selection_rejected") + expect_identical(submitted, 1L) + expect_identical(logged, 0L) +}) + +test_that("an explicitly rejected best-run record does not skip default recovery", { + fixture <- make_selection_case(futures = list(only = rep(100, 6)), errors = c(only = 0.03)) + selection <- do.call(select_forecast_candidate, fixture) + submitted <- 0L + logged <- 0L + local_mocked_bindings( + get_foundation_model_suffix = function() "", + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + read_file = function(...) data.frame(combo = "series", best_run_name = "reused"), + submit_fcst_run = function(agent_info, timestamp, ...) { + expect_true(isTRUE(agent_info$default_reforecast)) + expect_identical(timestamp, "default") + submitted <<- submitted + 1L + list(forecast_selection = list(selections = list(series = selection))) + }, + get_fcst_output = function(run_info) make_agent_metric_forecasts(run_info$forecast_selection), + log_best_run = function(...) { logged <<- logged + 1L } + ) + agent <- list(run_id = "run", quality_rejected_combos = hash_data("series"), + project_info = list(project_name = "project", path = tempdir())) + forecast_new_combos(agent, character(), hash_data("series"), NULL, FALSE, 1, 1) + expect_identical(submitted, 1L) + expect_identical(logged, 1L) +}) + +test_that("the update graph never refits because reconciliation rejects its input", { + recovered <- character() + reconciliations <- 0L + final_writes <- 0L + combos <- c("stored-a", "stored-b") + hashes <- vapply(combos, hash_data, character(1), USE.NAMES = FALSE) + local_mocked_bindings( + new_llm_session = function(llm) llm, + initial_checks = function(...) list(prev_best_runs_tbl = data.frame(combo = combos), + current_run_combos = hashes, new_combos = character()), + update_global_models = function(...) list(failed_combos = character(), quality_rejected_combos = character()), + update_local_models = function(...) list(failed_combos = character(), quality_rejected_combos = character()), + forecast_new_combos = function(agent_info, new_combos, failed_combos, ...) { + recovered <<- c(recovered, failed_combos) + "done" + }, + save_best_agent_run = function(...) "done", + analyze_results = function(...) 0, + reconcile_agent_forecast = function(...) { + reconciliations <<- reconciliations + 1L + if (reconciliations == 1L) { + rlang::abort("invalid reconciliation input", class = "finnts_forecast_selection_rejected", combo = "stored-b") + } + "done" + }, + summarize_hierarchy = function(...) "done", + save_agent_forecast = function(...) { final_writes <<- final_writes + 1L }, + summarize_models = function(...) "done", + eda_agent_workflow = function(...) "done", + wait_before_retry = function(...) stop("quality rejection must not enter retry waiting") + ) + project <- list(project_name = "project", path = tempdir(), combo_variables = "ID") + agent <- list(run_id = "run", forecast_approach = "standard_hierarchy", project_info = project) + expect_error(update_fcst_agent_workflow(agent, project, NULL, FALSE, 1, + max_iter = 1, allow_iterate_forecast = FALSE), class = "finnts_forecast_selection_rejected") + expect_identical(recovered, character()) + expect_identical(reconciliations, 1L) + expect_identical(final_writes, 0L) +}) + +test_that("reconciliation storage errors never initiate model fitting", { + submissions <- 0L + local_mocked_bindings( + check_agent_info = function(...) NULL, + get_best_agent_run = function(...) stop("storage unavailable"), + forecast_new_combos = function(...) { submissions <<- submissions + 1L } + ) + expect_error(reconcile_agent_forecast(list(), list()), "storage unavailable") + expect_identical(submissions, 0L) +}) + +test_that("a rejected default run cannot be fitted again on restart", { + fixture <- make_selection_case(futures = list(only = rep(100, 6)), errors = c(only = 0.03)) + selection <- do.call(select_forecast_candidate, fixture) + prepared <- 0L + local_mocked_bindings( + list_files = function(...) stop("known input must not require directory discovery"), + read_local_artifacts = function(run_info, file_list, ...) { + expect_length(file_list, 1L) + expect_false(grepl("*", file_list, fixed = TRUE)) + data.frame(Combo = "series", Date = fixture$history$Date, Target = 100) + }, + read_file = function(...) data.frame(Combo = "series", Date = fixture$history$Date, Target = 100), + set_run_info = function(...) list(project_name = "project", run_name = "default", path = tempdir()), + read_selection_file = function(...) data.frame(default_reforecast_status = "rejected"), + prep_data = function(...) { prepared <<- prepared + 1L }, + prep_models = function(...) NULL, + train_models = function(...) NULL, + final_models = function(...) list(selections = list(series = selection)), + validate_run_outputs = function(...) NULL + ) + agent <- list(run_id = "run", default_reforecast = TRUE, + project_info = list(project_name = "project", path = tempdir(), data_output = "csv")) + expect_error(submit_fcst_run(agent, list(models_to_run = "meanf"), hash_data("series"), "default"), + class = "finnts_forecast_selection_rejected") + expect_identical(prepared, 0L) +}) + +test_that("an already-used default best run cannot be recovered a second time", { + fixture <- make_selection_case(futures = list(only = rep(100, 6)), errors = c(only = 0.03)) + selection <- do.call(select_forecast_candidate, fixture) + submissions <- 0L + local_mocked_bindings( + get_foundation_model_suffix = function() "", + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + read_file = function(...) data.frame(combo = "series", best_run_name = "default", default_reforecast_status = "accepted"), + submit_fcst_run = function(...) { + submissions <<- submissions + 1L + list(forecast_selection = list(selections = list(series = selection))) + }, + get_fcst_output = function(...) data.frame(), + log_best_run = function(...) NULL + ) + agent <- list(run_id = "run", quality_rejected_combos = hash_data("series"), + project_info = list(project_name = "project", path = tempdir())) + expect_error(forecast_new_combos(agent, character(), hash_data("series"), NULL, FALSE, 1, 1), + class = "finnts_forecast_selection_rejected") + expect_identical(submissions, 0L) +}) + +test_that("reconciliation rejects nonfinite input before reading or filling", { + local_mocked_bindings(read_file = function(...) stop("must reject before storage")) + for (value in c(Inf, -Inf, NA_real_, NaN)) { + expect_error(reconcile(data.frame(Combo = "series", Forecast = value), list(), "standard_hierarchy", FALSE), + class = "finnts_forecast_selection_rejected") + } +}) + +test_that("Agent forecast loading does not require an ineligible average artifact", { + fixture <- make_selection_case(futures = list(only = rep(100, 6)), errors = c(only = 0.03)) + rows <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::mutate(Combo = "series", Combo_ID = Combo, Hyperparameter_ID = 1, + Best_Model = "Yes", Model_Name = "meanf", Model_Type = "local", Recipe_ID = "R1") + reads <- character() + local_mocked_bindings( + check_agent_info = function(...) NULL, + load_best_agent_run = function(...) data.frame(combo = "series", model_type = "local", + best_run_name = "selected", recipes_to_run = "R1", models_to_run = "meanf---snaive", average_models = TRUE), + list_files = function(...) stop("must not list"), + read_file = function(run_info, file_list = NULL, path = NULL, ...) { + if (!is.null(path)) stop("expected exact file_list") + reads <<- c(reads, file_list) + if (any(grepl("-average_models", file_list, fixed = TRUE))) stop("no eligible average exists") + if (any(grepl("-train_test_split", file_list, fixed = TRUE))) fixture$context$train_test_split else rows + } + ) + agent <- list(run_id = "run", forecast_approach = "bottoms_up", + project_info = list(project_name = "project", path = tempdir(), data_output = "csv", combo_variables = "Series")) + result <- load_agent_forecast(agent) + expect_identical(unique(result$Model_ID), "only") + expect_length(reads, 2L) + expect_true(all(result$Best_Model == "Yes")) +}) + +for (provider in c("blob_container", "ms_drive")) { + test_that(paste("Agent loading reads required splits and missing optional averages on", provider), { + fixture <- make_selection_case(futures = list(only = rep(100, 6)), errors = c(only = 0.03)) + rows <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::mutate(Combo = "series", Combo_ID = Combo, Hyperparameter_ID = 1, + Best_Model = "Yes", Model_Name = "meanf", Model_Type = "local", Recipe_ID = "R1") + source <- artifact_test_run(withr::local_tempdir(), "rds") + write_data(rows, "series", source, "data", "forecasts", "-single_models") + write_data(fixture$context$train_test_split, NULL, source, "data", "prep_models", "-train_test_split") + transport <- local_artifact_provider(provider) + project <- artifact_test_run("provider-artifacts", "rds") + project$storage_object <- transport$storage_object + project$combo_variables <- "Series" + selected <- project + selected$project_name <- paste0(project$project_name, "_", hash_data("series")) + selected$run_name <- "selected" + transport$files[[as.character(artifact_test_path(selected, "forecasts", "series", "-single_models"))]] <- + artifact_test_path(source, "forecasts", "series", "-single_models") + transport$files[[as.character(artifact_test_path(selected, "prep_models", suffix = "-train_test_split"))]] <- + artifact_test_path(source, "prep_models", suffix = "-train_test_split") + local_mocked_bindings( + check_agent_info = function(...) NULL, + load_best_agent_run = function(...) data.frame(combo = "series", model_type = "local", + best_run_name = "selected", recipes_to_run = "R1", models_to_run = "meanf---snaive", average_models = TRUE) + ) + agent <- list(run_id = "run", forecast_approach = "bottoms_up", project_info = project) + + result <- load_agent_forecast(agent) + + expect_identical(unique(result$Model_ID), "only") + expect_true(all(result$Best_Model == "Yes")) + expect_length(transport$downloads, 2L) + rows$Best_Model <- "No" + write_data(rows, "series", source, "data", "forecasts", "-single_models") + expect_error(load_agent_forecast(agent), "missing a best model", fixed = TRUE) + }) +} + +test_that("an unpublished quality rejection is not treated as a completed forecast", { + result <- rejected_agent_selection(c("first", "second"), "incomplete hierarchy") + expect_identical(agent_selection_summary(result)$status, "rejected") + expect_equal(nrow(get_fcst_output(list(forecast_selection = result))), 0) + metric <- calculate_fcst_metrics(list(forecast_selection = result), data.frame()) + expect_false(attr(metric, "selection_ok")) +}) \ No newline at end of file diff --git a/tests/testthat/test-agent-selection-policy.R b/tests/testthat/test-agent-selection-policy.R new file mode 100644 index 00000000..a88edf26 --- /dev/null +++ b/tests/testthat/test-agent-selection-policy.R @@ -0,0 +1,950 @@ +make_agent_policy_result <- function(wmape, risk = 0, fidelity = NA_real_) { + list(selections = list(series = list( + selected_id = "chosen", + rankings = tibble::tibble( + Model_ID = "chosen", Eligible = TRUE, WMAPE = wmape, + Log_Weight = log(100), Risk = risk, Violations = as.integer(risk > 0), + Reasons = list(if (risk > 0) "level_shift" else character()), + Seasonal_Fidelity = fidelity + ) + ))) +} + +test_that("iteration winners are compared by accuracy without quality tie-breaks", { + for (scores in list(c(2, 0), c(0, 0))) { + results <- list(make_agent_policy_result(0.08, scores[1], 0.5), + make_agent_policy_result(0.083, scores[2], 0)) + ranked <- rank_agent_run_selections(results) + expect_identical(ranked$series$series, 1L) + expect_identical(ranked$best_run_index, 1L) + } +}) + +test_that("equal iteration accuracy retains the earlier selected winner", { + results <- list(make_agent_policy_result(0.08, 2, 0.5), + make_agent_policy_result(0.08, 0, 0)) + ranked <- rank_agent_run_selections(results) + expect_identical(ranked$series$series, 1L) + expect_identical(ranked$best_run_index, 1L) +}) + +test_that("Agent metrics require completeness but not a second soft-quality pass", { + result <- make_agent_policy_result(0.01, 2, 0.5) + metric <- calculate_fcst_metrics(list(forecast_selection = result), make_agent_metric_forecasts(result)) + expect_equal(as.numeric(metric), 0.01) + expect_true(attr(metric, "selection_ok")) + result$selections["missing"] <- list(NULL) + metric <- calculate_fcst_metrics(list(forecast_selection = result), make_agent_metric_forecasts(result)) + expect_identical(as.numeric(metric), Inf) + expect_false(attr(metric, "selection_ok")) +}) + +test_that("an update aggregate preserves completed metrics and cannot bypass validity", { + info <- list(forecast_selection = make_agent_policy_result(0.1)) + rows <- make_agent_metric_forecasts(info$forecast_selection) + original <- calculate_fcst_metrics(info, rows) + updated <- calculate_fcst_metrics(info, rows, aggregate_wmape = 0.025049) + expect_equal(as.numeric(updated), 0.025) + expect_true(attr(updated, "selection_ok")) + expect_equal(attr(updated, "forecast_accuracy")$weighted_mape, 0.025) + expect_equal(attr(updated, "forecast_accuracy")$by_series, + attr(original, "forecast_accuracy")$by_series) + expect_equal(attr(updated, "model_accuracy"), attr(original, "model_accuracy")) + nonfinite <- rows + nonfinite$Forecast[1] <- Inf + for (unavailable in list(data.frame(), nonfinite)) { + metric <- calculate_fcst_metrics(info, unavailable, aggregate_wmape = 0) + expect_identical(as.numeric(metric), Inf) + expect_false(attr(metric, "selection_ok")) + } + info$forecast_selection$selections["missing"] <- list(NULL) + partial <- calculate_fcst_metrics(info, rows, aggregate_wmape = 0) + expect_identical(as.numeric(partial), Inf) + expect_false(attr(partial, "selection_ok")) + for (invalid in list(NA_real_, Inf, -1, numeric(), c(0, 0.1), "0.1")) { + expect_error(calculate_fcst_metrics(info, rows, aggregate_wmape = invalid), + "single finite non-negative number", fixed = TRUE) + } +}) + +test_that("completed forecast restoration never evaluates future quality", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + selected <- final_models(info, weekly_to_daily = FALSE) + log <- read_selection_file(info, "logs") + local_mocked_bindings( + select_series_forecasts = function(...) stop("must not repeat future-quality selection"), + forecast_path_risk = function(...) stop("must not assess saved future paths") + ) + restored <- assess_agent_run(info, log, "Synthetic") + expect_identical(restored$selections$Synthetic$selected_id, + selected$selections$Synthetic$selected_id) + expect_equal(agent_selection_summary(restored)$weighted_mape, log$weighted_mape) +}) + +test_that("normal iteration stops on a complete accurate winner with soft concerns", { + state <- new.env(parent = emptyenv()) + state$submissions <- 0L + state$refreshes <- 0L + chat <- new.env(parent = emptyenv()) + chat$set_system_prompt <- function(...) chat + local_mocked_bindings( + new_llm_session = function(llm) llm, + iterate_forecast_system_prompt = function(...) "prompt", + reason_inputs = function(...) list(models_to_run = "arima"), + submit_fcst_run = function(...) { + state$submissions <- state$submissions + 1L + list(forecast_selection = make_agent_policy_result(0.01, 2, 0.5)) + }, + get_fcst_output = function(run_info) make_agent_metric_forecasts(run_info$forecast_selection), + log_best_run = function(...) "logged", + load_reason_history = function(...) { + state$refreshes <- state$refreshes + 1L + list(total_runs = state$submissions) + }, + finalize_run = function(...) "finalized" + ) + result <- fcst_agent_workflow(list(llm = chat, agent_version = 1), combo = "series", + weighted_mape_goal = 0.03, parallel_processing = NULL, inner_parallel = FALSE, + num_cores = 1, max_iter = 2, previous_run_results = "No Previous Runs") + expect_identical(state$submissions, 1L) + expect_identical(state$refreshes, 0L) + expect_identical(result$node, "stop") +}) + +test_that("run history compares recorded accuracy without restoring forecasts", { + reads <- 0L + logs <- data.frame( + project_name = paste0("project_", hash_data("all")), + run_name = paste0("agent_run_", hash_data("all"), "_", 1:4), + created = paste0("2026-01-01 00:00:0", 1:4), + agent_version = c(1, 1, 1, 0), agent_forecast_approach = "bottoms_up", + weighted_mape = c(0.08, 0.083, 0.001, 0.0001), + selection_status = c("evaluated", "evaluated", "partial", "evaluated") + ) + local_mocked_bindings( + get_run_info = function(...) { reads <<- reads + 1L; logs }, + agent_selection_pool = function(...) stop("history must not restore old forecast assessments"), + assess_agent_run = function(...) stop("history must use its recorded accuracy"), + read_series_history = function(...) stop("history must not reload prepared recipes") + ) + agent <- list(agent_version = 1, forecast_approach = "bottoms_up", + selection_combos = c("first", "second"), + project_info = list(project_name = "project", path = tempdir())) + result <- load_run_results(agent) + expect_equal(result$weighted_mape[result$best_run == "yes"], 0.08) + expect_true(all(result$best_run[result$selection_status == "partial"] == "no")) + expect_true(all(result$best_run[result$agent_version == 0] == "no")) + expect_identical(reads, 1L) +}) + +test_that("best-run logging compares the saved incumbent without forecast rereads", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + info$forecast_selection <- final_models(info, weekly_to_daily = FALSE) + agent <- list(project_info = info, run_id = "parent", agent_version = 1, + forecast_approach = "bottoms_up") + log_best_run(agent, info, 0.1, combo = hash_data("Synthetic"), check_best_run = FALSE) + later <- info + later$run_name <- "later" + later$forecast_selection <- make_agent_policy_result(0.12, 0) + names(later$forecast_selection$selections) <- "Synthetic" + later_log <- read_selection_file(info, "logs") + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, + output_type = "log", folder = "logs", suffix = NULL) + local_mocked_bindings( + load_run_results = function(...) stop("incumbent comparison must not rescan run history"), + agent_selection_pool = function(...) stop("incumbent comparison must not reload forecasts"), + assess_agent_run = function(...) stop("incumbent comparison must not reassess forecasts"), + read_series_history = function(...) stop("incumbent comparison must not reload recipes") + ) + parent <- info + parent$run_name <- agent$run_id + log_best_run(agent, later, 0.12, combo = hash_data("Synthetic")) + saved <- read_selection_file(parent, "logs", "-agent_best_run", "Synthetic") + expect_identical(saved$best_run_name, info$run_name) + later$forecast_selection$selections$Synthetic$rankings$WMAPE <- 0.085 + log_best_run(agent, later, 0.085, combo = hash_data("Synthetic")) + saved <- read_selection_file(parent, "logs", "-agent_best_run", "Synthetic") + expect_identical(saved$best_run_name, later$run_name) + expect_equal(saved$weighted_mape, 0.085) +}) + +test_that("only unfinished default acceptance restores one-time quality evidence", { + quality_calls <- 0L + status <- NULL + current <- make_agent_policy_result(0.03) + current$rejected_combos <- character() + restored <- current + restored$selections$series$rankings$Risk <- NA_real_ + restored$selections$series$rankings$Violations <- NA_integer_ + info <- list(project_name = "project", run_name = "default", path = tempdir(), data_output = "csv") + local_mocked_bindings( + list_files = function(...) stop("known input must not require directory discovery"), + read_local_artifacts = function(run_info, file_list, ...) { + expect_length(file_list, 1L) + expect_false(grepl("*", file_list, fixed = TRUE)) + data.frame(Combo = "series", Date = as.Date("2024-01-01") + 0:5, Target = 100) + }, + read_file = function(...) data.frame(Combo = "series", Date = as.Date("2024-01-01") + 0:5, Target = 100), + set_run_info = function(...) info, + read_selection_file = function(...) data.frame(forecast_approach = "bottoms_up", date_type = "month"), + prep_data = function(...) NULL, + prep_models = function(...) NULL, + train_models = function(...) NULL, + final_models = function(...) restored, + assess_agent_run = function(..., check_quality = FALSE) { + expect_true(check_quality) + quality_calls <<- quality_calls + 1L + current + }, + write_data = function(x, ...) { status <<- x$default_reforecast_status }, + validate_run_outputs = function(...) TRUE + ) + agent <- list(run_id = "run", agent_version = 1, default_reforecast = TRUE, + project_info = list(project_name = "project", path = tempdir(), data_output = "csv")) + result <- submit_fcst_run(agent, list(models_to_run = "meanf"), hash_data("series"), "default") + expect_identical(quality_calls, 1L) + expect_identical(status, "accepted") + expect_true(agent_selection_summary(result$forecast_selection, check_quality = TRUE)$acceptable) + agent$default_reforecast <- FALSE + quality_calls <- 0L + status <- NULL + submit_fcst_run(agent, list(models_to_run = "meanf"), hash_data("series"), "iteration") + expect_identical(quality_calls, 0L) + expect_null(status) +}) + +make_selected_agent_log_fixture <- function(path, series = c("North--Revenue", "South--Revenue"), + global = TRUE) { + info <- list(project_name = "selected-run-logging", run_name = "iteration-1", + path = path, data_output = "csv", object_output = "rds", storage_object = NULL) + info$forecast_selection <- list(selections = stats::setNames(lapply(seq_along(series), function(index) { + make_agent_policy_result(0.08 + index / 100)$selections$series + }), series)) + info$selection_combos <- series + log <- data.frame(project_name = info$project_name, run_name = info$run_name, + path = path, data_output = "csv", object_output = "rds", + run_global_models = global, weighted_mape = 0.5) + write_data(log, combo = NULL, run_info = info, output_type = "log", folder = "logs") + agent <- list(project_info = info, run_id = "parent-run", agent_version = 2, + forecast_approach = "bottoms_up", selection_combos = series) + parent <- info + parent$run_name <- agent$run_id + list(info = info, agent = agent, parent = parent, log = log) +} + +test_that("global iteration promotion never mixes per-series winners", { + cases <- list( + list(wmape = c(0.08, 0.13), winner = "iteration-1", saved_wmape = c(0.1, 0.1)), + list(wmape = c(0.06, 0.11), winner = "iteration-2", saved_wmape = c(0.06, 0.11)), + list(wmape = c(0.09, 0.11), winner = "iteration-1", saved_wmape = c(0.1, 0.1)) + ) + for (case in cases) local({ + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + series <- names(fixture$info$forecast_selection$selections) + fixture$info$forecast_selection$selections <- lapply( + fixture$info$forecast_selection$selections, function(selection) { + selection$rankings$WMAPE <- 0.1 + selection + } + ) + local_mocked_bindings( + list_files = function(...) stop("global promotion must not enumerate artifacts"), + get_run_info = function(...) stop("global promotion must not rescan run history"), + forecast_path_risk = function(...) stop("global promotion must not reassess future paths") + ) + log_best_run(fixture$agent, fixture$info, 0.1, check_best_run = FALSE) + later <- fixture$info + later$run_name <- "iteration-2" + for (index in seq_along(series)) { + later$forecast_selection$selections[[index]]$rankings$WMAPE <- case$wmape[index] + } + later$forecast_selection$selections <- later$forecast_selection$selections[2:1] + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + + log_best_run(fixture$agent, later, mean(case$wmape)) + + saved <- dplyr::bind_rows(lapply(series, function(combo) { + read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + })) + expect_identical(unique(saved$best_run_name), case$winner) + expect_equal(saved$weighted_mape, case$saved_wmape) + log_best_run(fixture$agent, later, mean(case$wmape)) + repeated <- dplyr::bind_rows(lapply(series, function(combo) { + read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + })) + expect_equal(repeated, saved) + third <- later + third$run_name <- "iteration-3" + for (index in seq_along(series)) { + third$forecast_selection$selections[[series[index]]]$rankings$WMAPE <- c(0.03, 0.12)[index] + } + third_log <- fixture$log + third_log$run_name <- third$run_name + write_data(third_log, combo = NULL, run_info = third, output_type = "log", folder = "logs") + + log_best_run(fixture$agent, third, 0.075) + + promoted <- dplyr::bind_rows(lapply(series, function(combo) { + read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + })) + expect_identical(unique(promoted$best_run_name), third$run_name) + expect_equal(promoted$weighted_mape, c(0.03, 0.12)) + }) +}) + +test_that("incomplete global iterations cannot promote an available subset", { + for (mode in c("missing", "reported-missing", "rejected", "forced")) local({ + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + series <- names(fixture$info$forecast_selection$selections) + log_best_run(fixture$agent, fixture$info, 0.095, check_best_run = FALSE) + later <- fixture$info + later$run_name <- "partial-iteration" + later$forecast_selection$selections[[1]]$rankings$WMAPE <- 0.01 + if (mode %in% c("missing", "reported-missing")) { + later$forecast_selection$selections <- later$forecast_selection$selections[1] + if (mode == "reported-missing") later$selection_combos <- series[1] + } else { + later$forecast_selection$selections[[2]]$selected_id <- NA_character_ + } + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + local_mocked_bindings(list_files = function(...) stop("partial promotion must not enumerate")) + + expect_no_error(log_best_run(fixture$agent, later, Inf, check_best_run = mode != "forced")) + + saved <- dplyr::bind_rows(lapply(series, function(combo) { + read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + })) + expect_identical(unique(saved$best_run_name), fixture$info$run_name) + log <- read_selection_file(later, "logs") + expect_identical(log$selection_status, "partial") + expect_true(is.na(log$weighted_mape)) + }) +}) + +test_that("global promotion preserves a superior local winner", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + series <- names(fixture$info$forecast_selection$selections) + log_best_run(fixture$agent, fixture$info, 0.095, check_best_run = FALSE) + local_winner <- read_selection_file(fixture$parent, "logs", "-agent_best_run", series[1]) + local_winner$model_type <- "local" + local_winner$best_run_name <- "local-winner" + local_winner$weighted_mape <- 0.02 + write_data(local_winner, combo = series[1], run_info = fixture$parent, + output_type = "log", folder = "logs", suffix = "-agent_best_run") + later <- fixture$info + later$run_name <- "new-global-winner" + later$forecast_selection$selections[[1]]$rankings$WMAPE <- 0.05 + later$forecast_selection$selections[[2]]$rankings$WMAPE <- 0.11 + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + + log_best_run(fixture$agent, later, 0.08) + + saved <- dplyr::bind_rows(lapply(series, function(combo) { + read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + })) + expect_identical(saved$best_run_name, c("local-winner", "new-global-winner")) + expect_identical(saved$model_type, c("local", "global")) + expect_equal(saved$weighted_mape, c(0.02, 0.11)) +}) + +test_that("mixed global iterations cannot be loaded or finalized", { + mixed <- data.frame(combo = c("North", "South"), model_type = "global", + best_run_name = c("iteration-1", "iteration-2"), agent_version = 2, + weighted_mape = c(0.1, 0.08)) + agent <- list(project_info = list(project_name = "project", path = tempdir(), data_output = "csv"), + run_id = "parent", agent_version = 2, max_iter = 3, forecast_approach = "bottoms_up") + writes <- 0L + forecasts <- 0L + local_mocked_bindings( + check_agent_info = function(...) NULL, + list_files = function(...) "existing-metadata.csv", + read_file = function(...) mixed, + write_data = function(...) { writes <<- writes + 1L }, + get_total_combos = function(...) vapply(mixed$combo, hash_data, character(1)), + read_selected_agent_forecasts = function(...) { + forecasts <<- forecasts + 1L + stop("mixed forecasts reached the prediction reader") + } + ) + expect_error(load_best_agent_run(agent), "single global iteration") + expect_error(finalize_run(agent), "single global iteration") + expect_error(save_best_agent_run(agent), "single global iteration") + expect_error(load_agent_forecast(agent), "single global iteration") + expect_identical(writes, 0L) + expect_identical(forecasts, 0L) +}) + +test_that("global updates reject mixed iterations before any refit", { + mixed <- data.frame(combo = c("North", "South"), model_type = "global", + best_run_name = c("iteration-1", "iteration-2"), agent_version = 2) + fits <- 0L + local_mocked_bindings(update_forecast_combo = function(...) { + fits <<- fits + 1L + list(status = "done") + }) + expect_error(update_global_models(list(project_info = list()), mixed, NULL, FALSE, 1, 123), + "single global iteration") + expect_identical(fits, 0L) + mixed$best_run_name <- "iteration-1" + result <- update_global_models(list(project_info = list()), mixed, NULL, FALSE, 1, 123) + expect_identical(fits, 1L) + expect_length(result$failed_combos, 0L) +}) + +test_that("selection-backed logging preserves genuine local model-pool statistics", { + for (global in c(FALSE, TRUE)) local({ + fixture <- make_selected_agent_log_fixture(withr::local_tempdir(), "series", global = global) + fixture$info$forecast_selection$selections$series$rankings$WMAPE <- 0.1 + forecasts <- data.frame( + Combo = "series", Model_ID = rep(c("arima", "glmnet", "xgboost", "average"), each = 2), + Recipe_ID = rep(c("R1", "R1", "R1", "simple_average"), each = 2), + Run_Type = "Back_Test", Target = rep(c(100, 300), 4) + ) + forecasts$Forecast <- forecasts$Target * (1 + rep(c(0.1, 0.2, 0.3, 0.001), each = 2)) + forecasts$Best_Model <- ifelse(forecasts$Model_ID == "arima", "Yes", "No") + future <- forecasts + future$Run_Type <- "Future_Forecast" + future$Forecast <- 1000000 + forecasts <- dplyr::bind_rows(forecasts, future) + local_mocked_bindings( + list_files = function(...) stop("model statistics must not enumerate artifacts"), + read_series_history = function(...) stop("model statistics must use loaded backtests"), + forecast_path_risk = function(...) stop("model statistics must not reassess future paths") + ) + + metric <- calculate_fcst_metrics(fixture$info, forecasts) + log_best_run(fixture$agent, fixture$info, metric, check_best_run = FALSE) + + current <- read_selection_file(fixture$info, "logs") + saved <- read_selection_file(fixture$parent, "logs", "-agent_best_run", "series") + expected <- if (global) c(0.1, 0.1, 0) else c(0.2, 0.2, 0.1) + for (log in list(current, saved)) { + expect_equal(unname(unlist(log[, c("model_avg_wmape", "model_median_wmape", "model_std_wmape")])), + expected) + } + }) +}) + +test_that("model-pool statistics preserve signed targets and unavailable values", { + forecasts <- data.frame(Model_ID = rep(c("arima", "glmnet"), each = 3), + Recipe_ID = "R1", Run_Type = "Back_Test", Model_Type = "local", + Target = rep(c(0, -100, 300), 2)) + adjusted <- ifelse(forecasts$Target == 0, 0.1, forecasts$Target) + forecasts$Forecast <- adjusted * (1 + rep(c(0.1, 0.2), each = 3)) + expect_equal(agent_model_accuracy(forecasts), + list(model_avg_wmape = 0.15, model_median_wmape = 0.15, model_std_wmape = stats::sd(c(0.1, 0.2)))) + expect_equal(agent_model_accuracy(forecasts[forecasts$Model_ID == "arima", ]), + list(model_avg_wmape = 0.1, model_median_wmape = 0.1, model_std_wmape = NA_real_)) + unavailable <- list(model_avg_wmape = NA_real_, model_median_wmape = NA_real_, model_std_wmape = NA_real_) + global <- forecasts + global$Model_Type <- "global" + expect_identical(agent_model_accuracy(global), unavailable) + forecasts$Forecast[1] <- Inf + expect_identical(agent_model_accuracy(forecasts), unavailable) + forecasts$Target[] <- NA_real_ + expect_identical(agent_model_accuracy(forecasts), unavailable) + expect_identical(agent_model_accuracy(data.frame()), unavailable) +}) + +test_that("Agent decisions and saved winners retain original rounded precision", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir(), "series", global = FALSE) + fixture$info$forecast_selection$selections$series$rankings$WMAPE <- 0.100049 + metric <- calculate_fcst_metrics(fixture$info, make_agent_metric_forecasts(fixture$info$forecast_selection)) + expect_identical(as.numeric(metric), 0.1) + log_best_run(fixture$agent, fixture$info, metric, check_best_run = FALSE) + current <- read_selection_file(fixture$info, "logs") + saved <- read_selection_file(fixture$parent, "logs", "-agent_best_run", "series") + expect_equal(current$weighted_mape, 0.1) + expect_equal(saved$weighted_mape, 0.1) + later <- fixture$info + later$run_name <- "rounded-tie" + later$forecast_selection$selections$series$rankings$WMAPE <- 0.100041 + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + + log_best_run(fixture$agent, later, + calculate_fcst_metrics(later, make_agent_metric_forecasts(later$forecast_selection))) + + saved <- read_selection_file(fixture$parent, "logs", "-agent_best_run", "series") + expect_identical(saved$best_run_name, fixture$info$run_name) +}) + +test_that("completed metrics weight signed selected backtests and govern global promotion", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + series <- fixture$info$selection_combos + rows <- data.frame(Combo = rep(series, each = 3), Model_ID = "chosen", Recipe_ID = "R1", + Run_Type = "Back_Test", Best_Model = "Yes", Target = c(0, -100, 300, 0, -200, 600)) + adjusted <- ifelse(rows$Target == 0, 0.1, rows$Target) + rows$Forecast <- adjusted * (1 + rep(c(0.1, 0.2), each = 3)) + unselected <- rows + unselected$Best_Model <- "No" + unselected$Model_ID <- "discarded" + unselected$Forecast <- Inf + future <- rows + future$Run_Type <- "Future_Forecast" + future$Forecast <- Inf + local_mocked_bindings( + list_files = function(...) stop("completed accuracy must not enumerate artifacts"), + read_series_history = function(...) stop("completed accuracy must use loaded rows"), + forecast_path_risk = function(...) stop("completed accuracy must not rescore future paths") + ) + selections <- fixture$info$forecast_selection$selections + metric <- calculate_fcst_metrics(fixture$info, dplyr::bind_rows(rows, unselected, future)) + expect_equal(as.numeric(metric), round((0.1 * 400.1 + 0.2 * 800.1) / 1200.2, 4)) + expect_equal(attr(metric, "forecast_accuracy")$by_series, stats::setNames(c(0.1, 0.2), series)) + log_best_run(fixture$agent, fixture$info, metric, check_best_run = FALSE) + current <- read_selection_file(fixture$info, "logs") + expect_equal(current$weighted_mape, 0.1667) + expect_equal(current$model_avg_wmape, 0.1667) + expect_equal(current$model_median_wmape, 0.1667) + expect_equal(current$model_std_wmape, 0) + for (index in seq_along(series)) { + saved <- read_selection_file(fixture$parent, "logs", "-agent_best_run", series[index]) + expect_equal(saved$weighted_mape, c(0.1, 0.2)[index]) + expect_equal(saved$model_avg_wmape, 0.1667) + } + expect_identical(fixture$info$forecast_selection$selections, selections) + + later <- fixture$info + later$run_name <- "better-native-worse-completed" + later$forecast_selection$selections <- lapply(selections, function(selected) { + selected$rankings$WMAPE <- 0.001 + selected + }) + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + rows$Forecast <- adjusted * (1 + rep(c(0.3, 0.4), each = 3)) + log_best_run(fixture$agent, later, calculate_fcst_metrics(later, rows)) + for (combo in series) { + saved <- read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + expect_identical(saved$best_run_name, fixture$info$run_name) + } + expect_equal(read_selection_file(later, "logs")$weighted_mape, 0.3667) +}) + +test_that("unavailable completed metrics cannot promote a global iteration", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + complete <- make_agent_metric_forecasts(fixture$info$forecast_selection) + log_best_run(fixture$agent, fixture$info, calculate_fcst_metrics(fixture$info, complete), + check_best_run = FALSE) + missing <- complete[1, ] + nonfinite <- complete + nonfinite$Forecast[1] <- Inf + unknown <- complete + unknown$Target[] <- NA_real_ + unselected <- complete + unselected$Best_Model <- "No" + for (rows in list(data.frame(), missing, nonfinite, unknown, unselected)) { + later <- fixture$info + later$run_name <- "unusable-completed-output" + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + metric <- calculate_fcst_metrics(later, rows) + expect_identical(as.numeric(metric), Inf) + expect_false(attr(metric, "selection_ok")) + expect_identical(log_best_run(fixture$agent, later, metric)$status, "rejected") + expect_true(is.na(read_selection_file(later, "logs")$weighted_mape)) + for (combo in fixture$info$selection_combos) { + saved <- read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + expect_identical(saved$best_run_name, fixture$info$run_name) + } + } +}) + +test_that("weekly zero-target completed accuracy controls the workflow goal", { + native <- data.frame(Combo = "series", Combo_ID = "series", Model_ID = "chosen", + Model_Name = "meanf", Model_Type = "local", Recipe_ID = "R1", Train_Test_ID = 2L, + Hyperparameter_ID = 1L, Best_Model = "Yes", Horizon = 1:2, + Date = as.Date("2024-01-01") + c(0, 7), Target = c(0, 70), Forecast = c(0, 70), + lo_95 = c(0, 70), lo_80 = c(0, 70), hi_80 = c(0, 70), hi_95 = c(0, 70)) + daily <- convert_weekly_to_daily(native, "week", TRUE) + native$Run_Type <- daily$Run_Type <- "Back_Test" + info <- list(forecast_selection = make_agent_policy_result(0.0014)) + expect_equal(as.numeric(calculate_fcst_metrics(info, native)), 0.0014) + expect_equal(as.numeric(calculate_fcst_metrics(info, daily)), 0.0099) + state <- new.env(parent = emptyenv()) + state$submissions <- 0L + state$refreshes <- 0L + state$metrics <- numeric() + chat <- new.env(parent = emptyenv()) + chat$set_system_prompt <- function(...) chat + local_mocked_bindings( + new_llm_session = function(llm) llm, + iterate_forecast_system_prompt = function(...) "prompt", + reason_inputs = function(...) list(models_to_run = "meanf"), + submit_fcst_run = function(...) { state$submissions <- state$submissions + 1L; info }, + get_fcst_output = function(...) daily, + log_best_run = function(weighted_mape, ...) { + state$metrics <- c(state$metrics, as.numeric(weighted_mape)) + "logged" + }, + load_reason_history = function(...) { + state$refreshes <- state$refreshes + 1L + list(total_runs = state$submissions) + }, + finalize_run = function(...) "finalized" + ) + result <- fcst_agent_workflow(list(llm = chat, agent_version = 1), combo = "series", + weighted_mape_goal = 0.005, parallel_processing = NULL, inner_parallel = FALSE, + num_cores = 1, max_iter = 2, previous_run_results = "No Previous Runs") + expect_identical(state$submissions, 2L) + expect_identical(state$refreshes, 1L) + expect_equal(state$metrics, rep(0.0099, 2)) + expect_identical(result$node, "stop") +}) + +test_that("the workflow does not stop below a goal only because of unrounded digits", { + state <- new.env(parent = emptyenv()) + state$submissions <- 0L + state$refreshes <- 0L + chat <- new.env(parent = emptyenv()) + chat$set_system_prompt <- function(...) chat + local_mocked_bindings( + new_llm_session = function(llm) llm, + iterate_forecast_system_prompt = function(...) "prompt", + reason_inputs = function(...) list(models_to_run = "arima"), + submit_fcst_run = function(...) { + state$submissions <- state$submissions + 1L + list(forecast_selection = make_agent_policy_result(if (state$submissions == 1L) 0.09996 else 0.08)) + }, + get_fcst_output = function(run_info) make_agent_metric_forecasts(run_info$forecast_selection), + log_best_run = function(...) "logged", + load_reason_history = function(...) { + state$refreshes <- state$refreshes + 1L + list(total_runs = state$submissions) + }, + finalize_run = function(...) "finalized" + ) + + result <- fcst_agent_workflow(list(llm = chat, agent_version = 1), combo = "series", + weighted_mape_goal = 0.1, parallel_processing = NULL, inner_parallel = FALSE, + num_cores = 1, max_iter = 2, previous_run_results = "No Previous Runs") + + expect_identical(state$submissions, 2L) + expect_identical(state$refreshes, 1L) + expect_identical(result$node, "stop") +}) + +test_that("global promotion uses the workflow's existing iteration history", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + series <- names(fixture$info$forecast_selection$selections) + log_best_run(fixture$agent, fixture$info, 0.095, check_best_run = FALSE) + for (index in seq_along(series)) { + previous <- read_selection_file(fixture$parent, "logs", "-agent_best_run", series[index]) + previous$model_type <- "local" + previous$best_run_name <- paste0("local-", index) + previous$weighted_mape <- c(0.07, 0.2)[index] + write_data(previous, combo = series[index], run_info = fixture$parent, + output_type = "log", folder = "logs", suffix = "-agent_best_run") + } + later <- fixture$info + later$run_name <- "worse-global-iteration" + later$forecast_selection$selections[[1]]$rankings$WMAPE <- 0.08 + later$forecast_selection$selections[[2]]$rankings$WMAPE <- 0.09 + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + history <- data.frame(run_name = "previous-global-iteration", agent_version = 2, + weighted_mape = 0.05, model_avg_wmape = 0.05, selection_status = "evaluated") + chat <- new.env(parent = emptyenv()) + chat$set_system_prompt <- function(...) chat + fixture$agent$llm <- chat + local_mocked_bindings( + new_llm_session = function(llm) llm, + resolve_agent_global_forecast_approaches = function(...) "bottoms_up", + iterate_forecast_system_prompt = function(...) "prompt", + reason_inputs = function(...) list(models_to_run = "meanf"), + submit_fcst_run = function(...) later, + get_fcst_output = function(run_info) make_agent_metric_forecasts(run_info$forecast_selection), + get_run_info = function(...) stop("promotion must reuse the loaded iteration history"), + list_files = function(...) stop("promotion must not enumerate artifacts"), + finalize_run = function(...) "finalized" + ) + + fcst_agent_workflow(fixture$agent, combo = NULL, weighted_mape_goal = 0.01, + parallel_processing = NULL, inner_parallel = FALSE, num_cores = 1, + max_iter = 1, previous_run_results = history) + + saved <- dplyr::bind_rows(lapply(series, function(combo) { + read_selection_file(fixture$parent, "logs", "-agent_best_run", combo) + })) + expect_identical(saved$best_run_name, c("local-1", "local-2")) + expect_identical(saved$model_type, rep("local", 2)) +}) + +test_that("an incomplete global result cannot satisfy the workflow accuracy goal", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + log_best_run(fixture$agent, fixture$info, 0.095, check_best_run = FALSE) + partial <- fixture$info + partial$run_name <- "partial-goal" + partial$forecast_selection$selections <- partial$forecast_selection$selections[1] + partial$forecast_selection$selections[[1]]$rankings$WMAPE <- 0.001 + partial$selection_combos <- names(partial$forecast_selection$selections) + partial_log <- fixture$log + partial_log$run_name <- partial$run_name + write_data(partial_log, combo = NULL, run_info = partial, output_type = "log", folder = "logs") + submissions <- 0L + refreshes <- 0L + chat <- new.env(parent = emptyenv()) + chat$set_system_prompt <- function(...) chat + fixture$agent$llm <- chat + local_mocked_bindings( + new_llm_session = function(llm) llm, + resolve_agent_global_forecast_approaches = function(...) "bottoms_up", + iterate_forecast_system_prompt = function(...) "prompt", + reason_inputs = function(...) list(models_to_run = "meanf"), + submit_fcst_run = function(...) { + submissions <<- submissions + 1L + partial + }, + get_fcst_output = function(run_info) make_agent_metric_forecasts(run_info$forecast_selection), + load_reason_history = function(...) { + refreshes <<- refreshes + 1L + new_reason_history("No Previous Runs", fixture$agent$agent_version) + }, + finalize_run = function(...) "finalized" + ) + + result <- fcst_agent_workflow(fixture$agent, combo = NULL, weighted_mape_goal = 0.01, + parallel_processing = NULL, inner_parallel = FALSE, num_cores = 1, + max_iter = 2, previous_run_results = "No Previous Runs") + + expect_identical(submissions, 2L) + expect_identical(refreshes, 1L) + expect_identical(result$completion_reason, "quality_rejected") + saved <- load_best_agent_run(fixture$agent) + expect_identical(unique(saved$best_run_name), fixture$info$run_name) +}) + +test_that("interrupted global promotion cannot be marked complete", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + series <- names(fixture$info$forecast_selection$selections) + log_best_run(fixture$agent, fixture$info, 0.095, check_best_run = FALSE) + later <- fixture$info + later$run_name <- "interrupted-iteration" + later$forecast_selection$selections[[1]]$rankings$WMAPE <- 0.05 + later$forecast_selection$selections[[2]]$rankings$WMAPE <- 0.06 + later_log <- fixture$log + later_log$run_name <- later$run_name + write_data(later_log, combo = NULL, run_info = later, output_type = "log", folder = "logs") + original_write <- write_data + local_mocked_bindings(write_data = function(...) { + arguments <- list(...) + if (identical(arguments$combo, series[2]) && identical(arguments$suffix, "-agent_best_run")) { + return(invisible(NULL)) + } + do.call(original_write, arguments) + }) + + expect_error(log_best_run(fixture$agent, later, 0.055), "does not match the selected iteration") + + current <- read_selection_file(later, "logs") + expect_false("selection_status" %in% names(current)) + expect_error(load_best_agent_run(fixture$agent), "single global iteration") + expect_error(finalize_run(fixture$agent), "single global iteration") +}) + +test_that("selected Agent logging verifies every exact file without enumeration", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + series <- names(fixture$info$forecast_selection$selections) + expected_paths <- vapply(series, function(combo) { + as.character(fs::path(fixture$parent$path, "logs", paste0( + hash_data(fixture$parent$project_name), "-", hash_data(fixture$parent$run_name), + "-", hash_data(combo), "-agent_best_run.csv"))) + }, character(1), USE.NAMES = FALSE) + reads <- character() + original_read <- read_file + local_mocked_bindings( + list_files = function(...) stop("selected logger must not enumerate files"), + read_file = function(run_info, path = NULL, file_list = NULL, ...) { + expect_null(path) + expect_length(file_list, 1L) + reads <<- c(reads, as.character(file_list)) + original_read(run_info, file_list = file_list, ...) + } + ) + result <- log_best_run(fixture$agent, fixture$info, 0, check_best_run = FALSE) + expect_identical(result, list(status = "evaluated", selected_combos = series)) + expect_length(reads, 3L) + expect_identical(utils::tail(reads, 2), expected_paths) + for (index in seq_along(series)) { + saved <- original_read(fixture$parent, file_list = expected_paths[index]) + expect_identical(saved$combo, series[index]) + expect_identical(saved$best_run_name, fixture$info$run_name) + expect_equal(saved$weighted_mape, + fixture$info$forecast_selection$selections[[index]]$rankings$WMAPE) + } +}) + +test_that("unrelated best-run files cannot hide a missing selected record", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir()) + write_data(fixture$log, combo = "Unrelated", run_info = fixture$parent, + output_type = "log", folder = "logs", suffix = "-agent_best_run") + missing_path <- as.character(fs::path(fixture$parent$path, "logs", paste0( + hash_data(fixture$parent$project_name), "-", hash_data(fixture$parent$run_name), + "-", hash_data("South--Revenue"), "-agent_best_run.csv"))) + original_write <- write_data + original_read <- read_file + local_mocked_bindings( + write_data = function(...) { + arguments <- list(...) + if (identical(arguments$combo, "South--Revenue") && + identical(arguments$suffix, "-agent_best_run")) return(invisible(NULL)) + do.call(original_write, arguments) + }, + read_file = function(run_info, file_list = NULL, ...) { + if (identical(as.character(file_list), missing_path)) return(tibble::tibble()) + original_read(run_info, file_list = file_list, ...) + } + ) + expect_error(log_best_run(fixture$agent, fixture$info, 0, check_best_run = FALSE), + "The exact forecast artifact is empty or unreadable") + expect_false(file.exists(missing_path)) + current <- read_selection_file(fixture$info, "logs") + expect_false("selection_status" %in% names(current)) + expect_equal(current$weighted_mape, fixture$log$weighted_mape) +}) + +test_that("local selected Agent logging verifies all written records directly", { + for (series_count in c(1L, 2L)) local({ + series <- c("North--Revenue", "South--Revenue")[seq_len(series_count)] + fixture <- make_selected_agent_log_fixture(withr::local_tempdir(), series, global = FALSE) + verified <- character() + original_read <- read_selection_file + local_mocked_bindings( + list_files = function(...) stop("selected logger must not enumerate files"), + read_selection_file = function(run_info, folder, suffix = NULL, combo = NULL, + optional = FALSE, cache = NULL) { + if (identical(suffix, "-agent_best_run")) { + expect_false(optional) + expect_null(cache) + verified <<- c(verified, combo) + } + original_read(run_info, folder, suffix, combo, optional, cache) + } + ) + result <- log_best_run(fixture$agent, fixture$info, 0, + combo = hash_data(series[1]), check_best_run = FALSE) + expect_identical(verified, series) + expect_identical(result, list(status = "evaluated", selected_combos = series)) + for (combo in series) { + saved <- original_read(fixture$parent, "logs", "-agent_best_run", combo) + expect_identical(saved$model_type, "local") + } + }) +}) + +test_that("selected record read failures prevent final attempt logging", { + for (failure_mode in c("empty", "unreadable", "provider")) local({ + fixture <- make_selected_agent_log_fixture(withr::local_tempdir(), "North--Revenue") + original_read <- read_file + local_mocked_bindings( + list_files = function(...) stop("selected logger must not enumerate files"), + read_file = function(run_info, file_list = NULL, ...) { + if (length(file_list) == 1L && endsWith(file_list, "-agent_best_run.csv")) { + return(switch(failure_mode, + empty = tibble::tibble(), unreadable = NULL, + provider = rlang::abort("selected record storage unavailable", class = "selected_record_read_error"))) + } + original_read(run_info, file_list = file_list, ...) + } + ) + expected <- if (failure_mode == "provider") "selected record storage unavailable" else + "The exact forecast artifact is empty or unreadable" + error <- expect_error(log_best_run(fixture$agent, fixture$info, 0, check_best_run = FALSE), expected) + if (failure_mode == "provider") expect_s3_class(error, "selected_record_read_error") + current <- read_selection_file(fixture$info, "logs") + expect_false("selection_status" %in% names(current)) + expect_equal(current$weighted_mape, fixture$log$weighted_mape) + }) +}) + +test_that("local selected logging verifies only new winners and preserves incumbent rules", { + fixture <- make_selected_agent_log_fixture(withr::local_tempdir(), + c("retained", "improved", "rejected"), global = FALSE) + fixture$info$forecast_selection$selections$rejected$selected_id <- NA_character_ + previous <- data.frame(best_run_name = "incumbent", agent_version = 2, weighted_mape = 0.09) + write_data(previous, combo = "retained", run_info = fixture$parent, + output_type = "log", folder = "logs", suffix = "-agent_best_run") + previous$weighted_mape <- 0.2 + write_data(previous, combo = "improved", run_info = fixture$parent, + output_type = "log", folder = "logs", suffix = "-agent_best_run") + reads <- list() + written <- character() + original_read <- read_selection_file + original_write <- write_data + local_mocked_bindings( + list_files = function(...) stop("selected logger must not enumerate files"), + read_selection_file = function(run_info, folder, suffix = NULL, combo = NULL, + optional = FALSE, cache = NULL) { + if (identical(suffix, "-agent_best_run")) { + reads[[length(reads) + 1L]] <<- list(series = combo, optional = optional) + } + original_read(run_info, folder, suffix, combo, optional, cache) + }, + write_data = function(...) { + arguments <- list(...) + if (identical(arguments$suffix, "-agent_best_run")) written <<- c(written, arguments$combo) + do.call(original_write, arguments) + } + ) + result <- log_best_run(fixture$agent, fixture$info, 0) + expect_identical(result, list(status = "partial", selected_combos = c("retained", "improved"))) + expect_identical(written, "improved") + expect_identical(reads, list(list(series = "retained", optional = TRUE), + list(series = "improved", optional = TRUE), list(series = "improved", optional = FALSE))) + saved <- original_read(fixture$parent, "logs", "-agent_best_run", "retained") + expect_identical(saved$best_run_name, "incumbent") + expect_equal(saved$weighted_mape, 0.09) + saved <- original_read(fixture$parent, "logs", "-agent_best_run", "improved") + expect_identical(saved$best_run_name, fixture$info$run_name) + expect_equal(saved$weighted_mape, 0.1) + + reads <- list() + written <- character() + expect_identical(log_best_run(fixture$agent, fixture$info, 0), result) + expect_length(written, 0L) + expect_identical(reads, list(list(series = "retained", optional = TRUE), + list(series = "improved", optional = TRUE))) + + fixture$agent$agent_version <- 3 + reads <- list() + expect_identical(log_best_run(fixture$agent, fixture$info, 0), result) + expect_identical(written, c("retained", "improved")) + expect_identical(reads, list(list(series = "retained", optional = TRUE), + list(series = "improved", optional = TRUE), list(series = "retained", optional = FALSE), + list(series = "improved", optional = FALSE))) + saved <- original_read(fixture$parent, "logs", "-agent_best_run", "retained") + expect_identical(saved$best_run_name, fixture$info$run_name) + expect_equal(saved$agent_version, 3) + + fixture$info$forecast_selection$selections <- lapply(fixture$info$forecast_selection$selections, function(selection) { + selection$selected_id <- NA_character_ + selection + }) + reads <- list() + written <- character() + expect_identical(log_best_run(fixture$agent, fixture$info, 0), + list(status = "rejected", selected_combos = character())) + expect_length(reads, 0L) + expect_length(written, 0L) + current <- original_read(fixture$info, "logs") + expect_identical(current$selection_status, "rejected") + expect_true(is.na(current$weighted_mape)) +}) \ No newline at end of file diff --git a/tests/testthat/test-agent-update-selection.R b/tests/testthat/test-agent-update-selection.R new file mode 100644 index 00000000..13a299d1 --- /dev/null +++ b/tests/testthat/test-agent-update-selection.R @@ -0,0 +1,430 @@ +make_global_update_selection_fixture <- function(date_type = "month", weekly_to_daily = FALSE, + zero_targets = FALSE, global = TRUE, + signed_targets = FALSE) { + path <- withr::local_tempdir(pattern = "finnts-global-selection-", .local_envir = parent.frame()) + combos <- if (global) c("first", "second") else "first" + combo_id <- if (global) "All-Data" else "first" + model_type <- if (global) "global" else "local" + previous <- set_run_info(project_name = paste0("global-selection_", hash_data(if (global) "all" else "first")), + run_name = "previous", path = path, data_output = "csv", add_unique_id = FALSE) + updated <- previous + updated$run_name <- "updated" + actuals <- rep(100, 36) + if (zero_targets) actuals[c(33, 35)] <- 0 + if (signed_targets) actuals[32] <- -100 + fixture <- make_selection_case(actuals = actuals, + futures = list(template = rep(100, 6)), errors = c(template = 0), date_type = date_type) + series <- fixture$context + series$history <- fixture$history + splits <- series$train_test_split + write_data(splits, combo = NULL, run_info = previous, output_type = "data", + folder = "prep_models", suffix = "-train_test_split") + models <- c("xgboost", "chronos2", "timegpt") + model_ids <- paste(models, model_type, "R1", sep = "--") + template <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::group_by(Train_Test_ID) %>% + dplyr::mutate(Horizon = dplyr::row_number()) %>% + dplyr::ungroup() + source <- dplyr::bind_rows(lapply(seq_along(models), function(model_index) { + dplyr::bind_rows(lapply(combos, function(combo) { + rows <- template + rows$Combo <- combo + rows$Combo_ID <- combo_id + rows$Model_Name <- models[model_index] + rows$Model_Type <- model_type + rows$Recipe_ID <- "R1" + rows$Model_ID <- model_ids[model_index] + rows$Hyperparameter_ID <- 1L + rows$Run_Type <- splits$Run_Type[match(rows$Train_Test_ID, splits$Train_Test_ID)] + rows$Forecast <- c(98, if (combo == "first") if (global) 102 else 104 else 100, 103)[model_index] + observed <- !is.na(rows$Target) + rows$Forecast[observed] <- rows$Forecast[observed] * rows$Target[observed] / 100 + rows$Best_Model <- if (combo == "second" && model_index == 2L) "Yes" else "No" + rows + })) + })) + source <- create_prediction_intervals(source, splits) + average_id <- paste(sort(model_ids[1:2]), collapse = "_") + average <- source[source$Combo == "first" & source$Model_ID == model_ids[1], ] + average$Model_ID <- average_id + average$Model_Name <- NA_character_ + average$Model_Type <- "local" + average$Recipe_ID <- "simple_average" + average$Forecast <- (average$Forecast + + source$Forecast[source$Combo == "first" & source$Model_ID == model_ids[2]]) / 2 + average$Best_Model <- "Yes" + average <- create_prediction_intervals(average, splits) + for (combo in combos) { + saved_source <- convert_weekly_to_daily(source[source$Combo == combo, ], date_type, weekly_to_daily) + write_data(saved_source, combo = combo, run_info = previous, + output_type = "data", folder = "forecasts", suffix = if (global) "-global_models" else "-single_models") + } + write_data(convert_weekly_to_daily(average, date_type, weekly_to_daily), combo = "first", run_info = previous, + output_type = "data", folder = "forecasts", suffix = "-average_models") + fitted <- dplyr::bind_rows(lapply(seq_along(models), function(model_index) { + make_fitted_selection_models(source[source$Model_ID == model_ids[model_index], ], models[model_index]) + })) + fitted$Combo_ID <- combo_id + fitted$Model_Type <- model_type + trained <- fitted[, c("Combo_ID", "Model_Name", "Model_Type", "Recipe_ID", "Model_Fit")] + trained$Model_ID <- model_ids + write_data(trained, combo = combo_id, run_info = previous, + output_type = "object", folder = "models", suffix = "-single_models") + log <- read_selection_file(previous, "logs") + settings <- list(models_to_run = paste(models, collapse = "---"), recipes_to_run = "R1", + external_regressors = NA_character_, lag_periods = NA_character_, rolling_window_periods = NA_character_, + seasonal_period = 12, forecast_approach = "bottoms_up", date_type = date_type, negative_forecast = signed_targets, + box_cox = FALSE, stationary = FALSE, feature_selection = FALSE, global_model_recipes = "R1", + average_models = TRUE, max_model_average = 3, weekly_to_daily = weekly_to_daily, pca = FALSE, + num_hyperparameters = 1, forecast_horizon = 6, multistep_horizon = FALSE, + run_global_models = global, run_local_models = !global, run_ensemble_models = FALSE, + clean_missing_values = TRUE, clean_outliers = FALSE, hist_end_date = max(fixture$history$Date)) + for (setting in names(settings)) log[[setting]] <- settings[[setting]] + write_data(log, combo = NULL, run_info = previous, output_type = "log", folder = "logs", suffix = NULL) + log$run_name <- updated$run_name + write_data(log, combo = NULL, run_info = updated, output_type = "log", folder = "logs", suffix = NULL) + list(previous = previous, updated = updated, log = log, source = source, fitted = fitted, + model_ids = model_ids, series = series, splits = splits, + winners = c(first = average_id, second = model_ids[2])[combos], + input = dplyr::bind_rows(lapply(combos, function(combo) { + dplyr::mutate(fixture$history, Combo = combo) + })), + agent = list(run_id = "updated", agent_version = 2, forecast_horizon = 6, + project_info = list(project_name = "global-selection", path = path, data_output = "csv", + object_output = "rds", combo_variables = "Series", date_type = date_type, weekly_to_daily = weekly_to_daily)), + best = data.frame(combo = combos, model_type = model_type, + best_run_name = previous$run_name, weighted_mape = 0.2)) +} + +local_global_update_selection_mocks <- function(fixture, .env = parent.frame()) { + state <- new.env(parent = emptyenv()) + state$fits <- list() + state$logged <- NULL + state$metric <- NULL + state$retunes <- logical() + state$reads <- character() + state$transform <- function(fitted, retune) fitted + original_reader <- read_file + testthat::local_mocked_bindings( + get_run_info = function(project_name, run_name, ...) { + log <- fixture$log + log$project_name <- project_name + log$run_name <- run_name + log + }, + validate_prev_run_log = function(log) log, + list_files = function(storage_object, path, ...) { + if (!grepl("/input_data/", path, fixed = TRUE)) stop("saved selection must use exact artifact reads") + "input.csv" + }, + read_file = function(run_info, path = NULL, file_list = NULL, ...) { + state$reads <- c(state$reads, path, file_list) + if (identical(file_list, "input.csv") || any(grepl("/input_data/", file_list, fixed = TRUE))) { + return(fixture$input) + } + original_reader(run_info, path = path, file_list = file_list, ...) + }, + set_run_info = function(...) fixture$updated, + prep_data = function(...) NULL, + prep_models = function(...) NULL, + get_prepped_models = function(...) tibble::tibble(Type = c("Train_Test_Splits", "Model_Hyperparameters"), + Data = list(fixture$splits, data.frame(Hyperparameter_ID = 1L))), + fit_models = function(trained_models_tbl, retune_hyperparameters, ...) { + state$fits[[length(state$fits) + 1L]] <- trained_models_tbl$Model_ID + state$retunes <- c(state$retunes, retune_hyperparameters) + fitted <- fixture$fitted[match(trained_models_tbl$Model_ID, fixture$model_ids), ] + state$transform(fitted, retune_hyperparameters) + }, + read_series_history = function(...) fixture$series, + validate_run_outputs = function(...) TRUE, + log_best_run = function(run_info, weighted_mape, ...) { + state$logged <- run_info$forecast_selection + state$metric <- weighted_mape + "logged" + }, + .package = "finnts", .env = .env + ) + state +} + +test_that("global updates refit selected components and retain each saved winner", { + fixture <- make_global_update_selection_fixture() + state <- local_global_update_selection_mocks(fixture) + result <- update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123) + expect_identical(result$status, "done") + expect_length(state$fits, 1L) + expect_setequal(state$fits[[1]], fixture$model_ids[1:2]) + expect_identical(state$logged$selections$first$selected_id, fixture$winners[["first"]]) + expect_identical(state$logged$selections$second$selected_id, fixture$winners[["second"]]) + expect_true(attr(state$metric, "selection_ok")) + expect_named(attr(state$metric, "model_accuracy"), + c("model_avg_wmape", "model_median_wmape", "model_std_wmape")) + expect_equal(as.numeric(state$metric), 0) + expect_equal(attr(state$metric, "forecast_accuracy"), + list(weighted_mape = 0, by_series = c(first = 0, second = 0))) + rows <- read_candidate_forecasts(fixture$updated, c("first", "second"), fixture$log) + chosen <- rows[rows$Best_Model == "Yes", ] + expect_equal(chosen$Forecast, rep(100, nrow(chosen))) + expect_false(any(rows$Model_ID == fixture$model_ids[3])) +}) + +test_that("weekly updates retain native aggregate and completed per-series accuracy", { + original_logger <- log_best_run + original_converter <- convert_weekly_to_daily + cases <- list( + list(global = TRUE, daily = TRUE, signed = FALSE, retune = FALSE), + list(global = FALSE, daily = TRUE, signed = TRUE, retune = FALSE), + list(global = FALSE, daily = FALSE, signed = FALSE, retune = TRUE), + list(global = TRUE, daily = TRUE, signed = TRUE, retune = TRUE) + ) + for (case in cases) local({ + fixture <- make_global_update_selection_fixture("week", case$daily, zero_targets = TRUE, + global = case$global, signed_targets = case$signed) + fixture$best$weighted_mape <- if (case$retune) 0 else if (case$global) 0.001 else 0.011 + state <- local_global_update_selection_mocks(fixture) + state$conversions <- 0L + local_mocked_bindings( + log_best_run = function(agent_info, run_info, weighted_mape, ...) { + state$metric <- weighted_mape + original_logger(agent_info, run_info, weighted_mape, ...) + }, + convert_weekly_to_daily = function(...) { + state$conversions <- state$conversions + 1L + original_converter(...) + } + ) + + result <- update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123) + + expect_identical(result$status, "done") + expect_identical(state$retunes, if (case$retune) c(FALSE, TRUE) else FALSE) + expect_identical(state$conversions, 1L) + expect_false(any(grepl("/forecasts/", state$reads, fixed = TRUE) & + grepl(hash_data(fixture$updated$run_name), state$reads, fixed = TRUE))) + native <- if (case$global) 0.0005 else 0.0105 + expect_equal(as.numeric(state$metric), native) + expect_equal(read_selection_file(fixture$updated, "logs")$weighted_mape, native) + parent <- fixture$agent$project_info + parent$run_name <- fixture$agent$run_id + saved_before <- list() + rows_before <- list() + for (combo in fixture$best$combo) { + rows <- read_selection_file(fixture$updated, "forecasts", + if (combo == "first") "-average_models" else "-global_models", combo) + rows_before[[combo]] <- rows + expect_identical("Date_Day" %in% names(rows), case$daily) + expect_false("Run_Type" %in% names(rows)) + expect_equal(nrow(rows), 12L * if (case$daily) 7L else 1L) + rows$Run_Type <- fixture$splits$Run_Type[match(rows$Train_Test_ID, fixture$splits$Train_Test_ID)] + expected <- round(calc_wmape(rows), 4) + expect_equal(expected, if (!case$daily) native else if (case$global) 0.0035 else 0.0135) + saved <- read_selection_file(parent, "logs", "-agent_best_run", combo) + saved_before[[combo]] <- saved + expect_equal(saved$weighted_mape, expected) + if (case$global) { + expect_equal(saved$model_avg_wmape, native) + expect_equal(saved$model_median_wmape, native) + expect_equal(saved$model_std_wmape, 0) + } else { + models <- read_selection_file(fixture$updated, "forecasts", "-single_models", combo) + models$Run_Type <- fixture$splits$Run_Type[match(models$Train_Test_ID, fixture$splits$Train_Test_ID)] + models$Best_Model <- "Yes" + accuracy <- vapply(split(models, models$Model_ID), calc_wmape, numeric(1)) + expect_equal(saved$model_avg_wmape, mean(accuracy)) + expect_equal(saved$model_median_wmape, stats::median(accuracy)) + expect_equal(saved$model_std_wmape, stats::sd(accuracy)) + expect_gt(saved$model_std_wmape, 0) + } + } + + repeated <- update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123) + + expect_identical(repeated$status, "done") + expect_identical(state$retunes, rep(if (case$retune) c(FALSE, TRUE) else FALSE, 2)) + expect_identical(state$conversions, 2L) + for (combo in fixture$best$combo) { + expect_equal(read_selection_file(parent, "logs", "-agent_best_run", combo), saved_before[[combo]]) + expect_equal(read_selection_file(fixture$updated, "forecasts", + if (combo == "first") "-average_models" else "-global_models", combo), rows_before[[combo]]) + } + }) +}) + +test_that("an unselected series prediction cannot invalidate another global winner", { + fixture <- make_global_update_selection_fixture() + state <- local_global_update_selection_mocks(fixture) + state$transform <- function(fitted, retune) { + model_index <- which(fitted$Model_Name == "xgboost") + rows <- fitted$Forecast_Tbl[[model_index]] + rows$Forecast[rows$Combo == "second"] <- Inf + fitted$Forecast_Tbl[[model_index]] <- rows + fitted + } + result <- update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123) + expect_length(result$quality_rejected_combos, 0L) + expect_setequal(names(state$logged$selections), c("first", "second")) + rows <- read_candidate_forecasts(fixture$updated, c("first", "second"), fixture$log) + expect_true(all(is.finite(rows$Forecast))) + expect_identical(unique(rows$Model_ID[rows$Combo == "second"]), fixture$winners[["second"]]) +}) + +test_that("global retuning retains saved subsets and rejects only required failures", { + fixture <- make_global_update_selection_fixture() + fixture$best$weighted_mape <- 0 + state <- local_global_update_selection_mocks(fixture) + state$transform <- function(fitted, retune) { + fitted$Forecast_Tbl <- lapply(fitted$Forecast_Tbl, function(rows) { + if (retune) { + rows$Forecast[rows$Combo == "first" & rows$Train_Test_ID == 1L] <- Inf + } else rows$Forecast <- rows$Forecast * 1.02 + rows + }) + fitted + } + result <- update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123) + expect_length(state$fits, 2L) + expect_true(all(vapply(state$fits, function(ids) setequal(ids, fixture$model_ids[1:2]), logical(1)))) + expect_identical(result$quality_rejected_combos, hash_data("first")) + expect_identical(names(state$logged$selections), "second") + expect_identical(state$logged$selections$second$selected_id, fixture$winners[["second"]]) + rows <- read_candidate_forecasts(fixture$updated, "second", fixture$log) + expect_equal(rows$Forecast, rep(100, nrow(rows))) +}) + +test_that("selected global component coverage cannot be repaired by its average", { + lapply(c("missing_row", "duplicate_row", "missing_component"), function(defect) { + fixture <- make_global_update_selection_fixture() + state <- local_global_update_selection_mocks(fixture) + state$transform <- function(fitted, retune) { + model_index <- which(fitted$Model_Name == "xgboost") + rows <- fitted$Forecast_Tbl[[model_index]] + affected <- which(rows$Combo == "first") + if (defect == "missing_row") rows <- rows[-affected[1], ] + if (defect == "duplicate_row") rows <- dplyr::bind_rows(rows, rows[affected[1], ]) + if (defect == "missing_component") rows <- rows[-affected, ] + fitted$Forecast_Tbl[[model_index]] <- rows + fitted + } + result <- update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123) + expect_identical(result$quality_rejected_combos, hash_data("first"), info = defect) + expect_identical(names(state$logged$selections), "second", info = defect) + }) +}) + +test_that("saved global winner evidence and fitted models are required", { + fixture <- make_global_update_selection_fixture() + state <- local_global_update_selection_mocks(fixture) + average <- read_selection_file(fixture$previous, "forecasts", "-average_models", "first") + average$Best_Model <- "No" + write_data(average, combo = "first", run_info = fixture$previous, + output_type = "data", folder = "forecasts", suffix = "-average_models") + expect_error(update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123), + "Saved global winner is missing or ambiguous") + expect_length(state$fits, 0L) + average$Best_Model <- "Yes" + write_data(average, combo = "first", run_info = fixture$previous, + output_type = "data", folder = "forecasts", suffix = "-average_models") + source <- read_selection_file(fixture$previous, "forecasts", "-global_models", "first") + source$Best_Model[source$Model_Name == "xgboost"] <- "Yes" + write_data(source, combo = "first", run_info = fixture$previous, + output_type = "data", folder = "forecasts", suffix = "-global_models") + expect_error(update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123), + "Saved global winner is missing or ambiguous") + expect_length(state$fits, 0L) + source$Best_Model <- "No" + write_data(source, combo = "first", run_info = fixture$previous, + output_type = "data", folder = "forecasts", suffix = "-global_models") + model_path <- fs::path(fixture$previous$path, "models", paste0(hash_data(fixture$previous$project_name), "-", + hash_data(fixture$previous$run_name), "-", hash_data("All-Data"), "-single_models.rds")) + trained <- read_file(fixture$previous, file_list = model_path) + write_data(trained[trained$Model_Name != "xgboost", ], combo = "All-Data", run_info = fixture$previous, + output_type = "object", folder = "models", suffix = "-single_models") + expect_error(update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123), + "Saved selected model fits are missing or ambiguous") + expect_length(state$fits, 0L) +}) + +test_that("global selected mappings survive persistence and input ordering", { + fixture <- make_global_update_selection_fixture() + state <- local_global_update_selection_mocks(fixture) + fixture$best <- fixture$best[2:1, ] + update_forecast_combo(fixture$agent, fixture$best, NULL, 1, FALSE, 123) + restored <- read_global_update_selection(fixture$updated, fixture$log, c("first", "second")) + expect_identical(restored$selected_ids, fixture$winners) + expect_setequal(restored$components$first, fixture$model_ids[1:2]) + expect_identical(restored$components$second, fixture$model_ids[2]) + rows <- read_candidate_forecasts(fixture$updated, c("first", "second"), fixture$log) + expect_false(anyDuplicated(rows[, c("Combo", "Model_ID", "Train_Test_ID", "Date")]) > 0) + expect_true(all(vapply(state$logged$selections, function(selection) !is.na(selection$selected_id), logical(1)))) +}) + +test_that("hierarchical global updates preserve heterogeneous source winners before solving", { + fixture <- make_reconciled_selection_fixture() + base <- fixture$forecasts[fixture$forecasts$Model_ID == "safe", ] + fitted <- make_fitted_selection_models(base) + saved <- adjust_forecast(fitted, fixture$project_info, "standard_hierarchy", FALSE) + average_id <- unique(saved$Model_ID[saved$Recipe_ID == "simple_average"]) + winners <- stats::setNames(rep(c("xgboost--global--R1", average_id), + length.out = length(fixture$metadata$hts_combos)), fixture$metadata$hts_combos) + saved$Best_Model <- ifelse(saved$Model_ID == unname(winners[saved$Combo]), "Yes", "No") + contexts <- stats::setNames(lapply(fixture$metadata$hts_combos, function(combo) { + context <- fixture$contexts[[1]] + context$history$Target <- base$Forecast[base$Combo == combo & base$Train_Test_ID == 1L][1] + context + }), fixture$metadata$hts_combos) + solver_input <- NULL + local_mocked_bindings( + read_selection_hierarchy = function(...) fixture$metadata, + read_candidate_forecasts = function(..., reconciled = TRUE) { + expect_false(reconciled) + saved + }, + read_series_history = function(run_info, combo, ...) contexts[[combo]], + reconcile = function(initial_fcst, ...) { + solver_input <<- initial_fcst + bottoms <- utils::tail(fixture$metadata$hts_combos, length(fixture$metadata$original_combos)) + rows <- initial_fcst[initial_fcst$Combo %in% bottoms, ] + rows$Combo <- fixture$metadata$original_combos[match(rows$Combo, bottoms)] + rows$Model_ID <- "Best-Model" + rows + } + ) + log <- data.frame(forecast_approach = "standard_hierarchy", date_type = "month", negative_forecast = FALSE) + mapping <- read_global_update_selection(fixture$project_info, log, fixture$metadata$original_combos) + expect_identical(mapping$selected_ids, winners) + assembled <- adjust_forecast(fitted, fixture$project_info, "standard_hierarchy", FALSE, + selected_models = mapping) + result <- assess_update_forecasts(assembled, fixture$project_info, log, fixture$splits, + expected_components = mapping$components, combos = fixture$metadata$original_combos) + expect_length(result$quality_rejected_combos, 0L) + expect_setequal(unique(solver_input$Combo), fixture$metadata$hts_combos) + expect_true(all(solver_input$Best_Model == "Yes")) + expect_identical(solver_input$Model_ID, unname(winners[solver_input$Combo])) + expect_setequal(names(result$selections), fixture$metadata$original_combos) +}) + +test_that("uniform global and legacy local assembly retain their component arithmetic", { + fixture <- make_selection_case(futures = list(only = rep(100, 6)), errors = c(only = 0.02)) + forecasts <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) + forecasts$Combo <- "series" + forecasts$Run_Type <- fixture$context$train_test_split$Run_Type[ + match(forecasts$Train_Test_ID, fixture$context$train_test_split$Train_Test_ID)] + fitted <- make_fitted_selection_models(forecasts) + legacy <- adjust_forecast(fitted, list(), "bottoms_up", FALSE) + average_id <- unique(legacy$Model_ID[legacy$Best_Model == "Yes"]) + mapping <- list(selected_ids = c(series = average_id), + components = list(series = strsplit(average_id, "_", fixed = TRUE)[[1]])) + mapped <- adjust_forecast(fitted[2:1, ], list(), "bottoms_up", FALSE, selected_models = mapping) + columns <- c("Combo", "Model_ID", "Train_Test_ID", "Date", "Forecast", "Target", "Best_Model") + expect_equal(dplyr::arrange(mapped[, columns], Combo, Model_ID, Train_Test_ID, Date), + dplyr::arrange(legacy[, columns], Combo, Model_ID, Train_Test_ID, Date)) + fitted$Model_Type <- "local" + fitted$Combo_ID <- "series" + local_average <- adjust_forecast(fitted, list(), "bottoms_up", FALSE) + expect_true(all(local_average$Best_Model[local_average$Recipe_ID == "simple_average"] == "Yes")) + local_single <- adjust_forecast(fitted[1, ], list(), "bottoms_up", FALSE) + expect_true(all(local_single$Best_Model == "Yes")) + columns <- c("Combo", "Train_Test_ID", "Date", "Forecast") + expect_equal(dplyr::arrange(local_single[, columns], Combo, Train_Test_ID, Date), + dplyr::arrange(tibble::as_tibble(fitted$Forecast_Tbl[[1]][, columns]), Combo, Train_Test_ID, Date)) +}) \ No newline at end of file diff --git a/tests/testthat/test-artifact-restarts.R b/tests/testthat/test-artifact-restarts.R index 429ee762..54ab5708 100644 --- a/tests/testthat/test-artifact-restarts.R +++ b/tests/testthat/test-artifact-restarts.R @@ -50,15 +50,65 @@ test_that("ensemble completion counts persisted outputs instead of worker return expect_equal(tracker$listings, 0L) }) +artifact_completed_final_outputs <- function(run_info, combos = "A", date_type = "month") { + log <- artifact_test_model_log(run_info, "standard_hierarchy") + log$hist_end_date <- as.Date("2024-01-01") + log$date_type <- date_type + write_data(log, NULL, run_info, "log", "logs") + future_date <- seq(log$hist_end_date, by = date_type, length.out = 2L)[2] + history <- tibble::tibble(Combo = "A", + Date = c(rev(seq(log$hist_end_date, by = paste("-1", date_type), length.out = 13L)), future_date), + Target = c(rep(100, 13), NA_real_)) + write_data(history, "A", run_info, "data", "prep_data", "-R1") + splits <- tibble::tibble(Run_Type = c("Future_Forecast", "Back_Test"), Train_Test_ID = c(1, 2), + Train_End = c(log$hist_end_date, history$Date[12]), + Test_End = c(future_date, log$hist_end_date)) + write_data(splits, NULL, run_info, "data", "prep_models", "-train_test_split") + forecast <- artifact_test_forecast(run_info, write_output = FALSE) + forecast$Date <- future_date + backtest <- forecast + backtest$Train_Test_ID <- 2 + backtest$Date <- as.Date("2024-01-01") + backtest$Target <- 100 + predictions <- dplyr::bind_rows(forecast, backtest) + predictions$Horizon <- 1 + predictions$Run_Type <- c("Future_Forecast", "Back_Test") + predictions$lo_80 <- 98 + predictions$lo_95 <- 95 + predictions$hi_80 <- 102 + predictions$hi_95 <- 105 + write_data(predictions, "A", run_info, "data", "forecasts", "-single_models") + average <- predictions + average$Model_ID <- "meanf--local--R1_snaive--local--R1" + average$Model_Name <- "model_average" + average$Best_Model <- "No" + write_data(average, "A", run_info, "data", "forecasts", "-average_models") + series <- list(history = history[history$Date <= log$hist_end_date, ], calendar = history$Date) + expect_identical(completed_forecast_selection(dplyr::bind_rows(predictions, average), series, splits)$selected_id, + "meanf--local--R1") + predictions <- dplyr::bind_rows(lapply(combos, function(combo) { + rows <- predictions + rows$Combo <- rows$Combo_ID <- combo + if (combo != "A") { + history$Combo <- combo + average$Combo <- average$Combo_ID <- combo + write_data(history, combo, run_info, "data", "prep_data", "-R1") + write_data(rows, combo, run_info, "data", "forecasts", "-single_models") + write_data(average, combo, run_info, "data", "forecasts", "-average_models") + } + rows + })) + write_data(list(original_combos = combos, hts_combos = combos), NULL, run_info, "object", "prep_data", "-hts_info") + predictions[, setdiff(names(predictions), "Run_Type")] +} + test_that("completed hierarchy restart reuses discovery and checks the exact reconciliation", { run_info <- artifact_test_run(withr::local_tempdir()) - artifact_test_model_log(run_info, "standard_hierarchy") - artifact_test_splits(run_info) - artifact_test_forecast(run_info) - artifact_test_forecast(run_info, suffix = "average_models") - write_data(tibble::tibble(value = 1), "Best-Model", run_info, "data", "forecasts", "-reconciled") + predictions <- artifact_completed_final_outputs(run_info) + write_data(predictions, "Best-Model", run_info, "data", "forecasts", "-reconciled") tracker <- local_artifact_spies(max_listings = 1L) testthat::local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), reconcile_hierarchical_data = function(...) stop("completed reconciliation reran", call. = FALSE), .package = "finnts" ) @@ -69,13 +119,11 @@ test_that("completed hierarchy restart reuses discovery and checks the exact rec test_that("missing reconciliation is not satisfied by another run output", { run_info <- artifact_test_run(withr::local_tempdir()) - artifact_test_model_log(run_info, "standard_hierarchy") - artifact_test_splits(run_info) - artifact_test_forecast(run_info) - artifact_test_forecast(run_info, suffix = "average_models") - write_data(tibble::tibble(value = 1), "unrelated", run_info, "data", "forecasts", "-reconciled") + predictions <- artifact_completed_final_outputs(run_info) + write_data(predictions, "unrelated", run_info, "data", "forecasts", "-reconciled") tracker <- local_artifact_spies(max_listings = 1L) testthat::local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), reconcile_hierarchical_data = function(...) stop("missing reconciliation dispatched", call. = FALSE), .package = "finnts" ) @@ -84,6 +132,227 @@ test_that("missing reconciliation is not satisfied by another run output", { expect_equal(tracker$listings, 1L) }) +test_that("damaged reconciled future rows are rebuilt without reselecting sources", { + for (defect in c("missing_future", "nonfinite_future")) { + run_info <- artifact_test_run(withr::local_tempdir()) + expected <- artifact_completed_final_outputs(run_info) + damaged <- expected + if (defect == "missing_future") { + damaged <- damaged[damaged$Train_Test_ID != 1, ] + } else { + damaged$Forecast[damaged$Train_Test_ID == 1] <- Inf + } + write_data(damaged, "Best-Model", run_info, "data", "forecasts", "-reconciled") + reconciliations <- 0L + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + train_models = function(...) stop("restart must not train models"), + select_series_forecasts = function(...) stop("complete sources must not be reselected"), + reconcile_hierarchical_data = function(run_info, ...) { + reconciliations <<- reconciliations + 1L + write_data(expected, "Best-Model", run_info, "data", "forecasts", "-reconciled") + }, + .package = "finnts" + ) + + result <- final_models(run_info) + + expect_equal(reconciliations, 1L, info = defect) + expect_equal(read_selection_file(run_info, "forecasts", "-reconciled", "Best-Model"), + expected, info = defect) + expect_length(result$rejected_combos, 0L) + } +}) + +for (format in c("csv", "rds", "parquet")) { + test_that(paste("reconciled restart repairs series and key coverage for", format), { + if (format == "parquet") skip_if_not_installed("arrow") + run_info <- artifact_test_run(withr::local_tempdir(), format) + expected <- artifact_completed_final_outputs(run_info, combos = c("A", "B")) + reconciliations <- 0L + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + train_models = function(...) stop("restart must not train models"), + select_series_forecasts = function(...) stop("complete sources must not be reselected"), + reconcile_hierarchical_data = function(run_info, ...) { + reconciliations <<- reconciliations + 1L + write_data(expected, "Best-Model", run_info, "data", "forecasts", "-reconciled") + }, + .package = "finnts" + ) + for (defect in c("missing_series", "extra_series", "missing_backtest", "duplicate_future", + "duplicate_backtest", "nonfinite_backtest", "missing_flag", "multiple_winners", "invalid_date", "empty")) { + damaged <- expected + if (defect == "missing_series") damaged <- damaged[damaged$Combo == "A", ] + if (defect == "extra_series") { + extra <- damaged[damaged$Combo == "A", ] + extra$Combo <- extra$Combo_ID <- "Unexpected" + damaged <- dplyr::bind_rows(damaged, extra) + } + if (defect == "missing_backtest") damaged <- damaged[-2, ] + if (defect == "duplicate_future") damaged <- dplyr::bind_rows(damaged, damaged[1, ]) + if (defect == "duplicate_backtest") damaged <- dplyr::bind_rows(damaged, damaged[2, ]) + if (defect == "nonfinite_backtest") damaged$Forecast[2] <- NaN + if (defect == "missing_flag") damaged$Best_Model <- NULL + if (defect == "multiple_winners") damaged$Model_ID[1] <- "other--local--R1" + if (defect == "invalid_date") { + damaged$Date <- as.character(damaged$Date) + damaged$Date[1] <- "invalid" + } + if (defect == "empty") damaged <- damaged[0, ] + write_data(damaged, "Best-Model", run_info, "data", "forecasts", "-reconciled") + reconciliations <- 0L + + result <- final_models(run_info) + + expect_equal(reconciliations, 1L, info = defect) + expect_setequal(names(result$selections), c("A", "B")) + expect_length(result$rejected_combos, 0L) + saved <- if (format == "parquet") { + arrow::read_parquet(artifact_test_path(run_info, "forecasts", "Best-Model", "-reconciled"), mmap = FALSE) + } else read_selection_file(run_info, "forecasts", "-reconciled", "Best-Model") + expect_equal(saved, expected, info = defect) + } + }) +} + +test_that("daily-expanded reconciliation requires every expected daily key", { + run_info <- artifact_test_run(withr::local_tempdir()) + expected <- artifact_completed_final_outputs(run_info, combos = c("A", "B"), date_type = "week") + expected <- convert_weekly_to_daily(expected, "week", TRUE) + reconciliations <- 0L + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + select_series_forecasts = function(...) stop("complete sources must not be reselected"), + reconcile_hierarchical_data = function(run_info, ...) { + reconciliations <<- reconciliations + 1L + write_data(expected, "Best-Model", run_info, "data", "forecasts", "-reconciled") + }, + .package = "finnts" + ) + for (defect in c("missing_day", "duplicate_day", "nonfinite_later_day", "missing_daily_column", "wrong_week")) { + damaged <- expected + if (defect == "missing_day") damaged <- damaged[-2, ] + if (defect == "duplicate_day") damaged <- dplyr::bind_rows(damaged, damaged[2, ]) + if (defect == "nonfinite_later_day") damaged$Forecast[2] <- Inf + if (defect == "missing_daily_column") damaged$Date_Day <- NULL + if (defect == "wrong_week") damaged$Date[2] <- damaged$Date[2] + 7 + write_data(damaged, "Best-Model", run_info, "data", "forecasts", "-reconciled") + reconciliations <- 0L + + result <- final_models(run_info, weekly_to_daily = TRUE) + + expect_equal(reconciliations, 1L, info = defect) + expect_length(result$rejected_combos, 0L) + expect_equal(read_selection_file(run_info, "forecasts", "-reconciled", "Best-Model"), expected, + info = defect) + } +}) + +test_that("valid reconciliation is read once and shares cached hierarchy history", { + for (settings in list( + list(date_type = "month", weekly_to_daily = FALSE), + list(date_type = "week", weekly_to_daily = FALSE), + list(date_type = "week", weekly_to_daily = TRUE) + )) local({ + run_info <- artifact_test_run(withr::local_tempdir()) + expected <- artifact_completed_final_outputs(run_info, combos = c("A", "B"), date_type = settings$date_type) + expected$Forecast[expected$Train_Test_ID == 1] <- 1e6 + expected <- convert_weekly_to_daily(expected, settings$date_type, settings$weekly_to_daily) + write_data(expected, "Best-Model", run_info, "data", "forecasts", "-reconciled") + tracker <- local_artifact_spies(max_listings = 1L) + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + train_models = function(...) stop("restart must not train models"), + select_series_forecasts = function(...) stop("complete sources must not be reselected"), + reconcile_hierarchical_data = function(...) stop("valid reconciliation must be reused"), + .package = "finnts" + ) + + result <- final_models(run_info, weekly_to_daily = settings$weekly_to_daily) + + expect_length(result$rejected_combos, 0L) + expect_equal(tracker$listings, 1L) + expect_equal(sum(tracker$payload_paths == artifact_test_path(run_info, "forecasts", "Best-Model", "-reconciled")), 1L) + expect_equal(sum(tracker$payload_paths == artifact_test_path(run_info, "prep_data", suffix = "-hts_info", extension = "rds")), 1L) + for (combo in c("A", "B")) { + expect_equal(sum(tracker$payload_paths == artifact_test_path(run_info, "prep_data", combo, "-R1")), 2L) + } + }) +}) + +test_that("invalid regenerated reconciliation cannot write a completion log", { + for (cached in c(FALSE, TRUE)) local({ + run_info <- artifact_test_run(withr::local_tempdir()) + predictions <- artifact_completed_final_outputs(run_info) + if (cached) { + write_data(predictions[-1, ], "Best-Model", run_info, "data", "forecasts", "-reconciled") + } + previous_log <- read_selection_file(run_info, "logs") + predictions$Forecast[1] <- Inf + reconciliations <- 0L + log_writes <- 0L + original_writer <- write_data + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + select_series_forecasts = function(...) stop("complete sources must not be reselected"), + reconcile_hierarchical_data = function(run_info, ...) { + reconciliations <<- reconciliations + 1L + original_writer(predictions, "Best-Model", run_info, "data", "forecasts", "-reconciled") + }, + write_data = function(x, combo, run_info, output_type, folder = NULL, suffix = NULL) { + if (identical(output_type, "log")) log_writes <<- log_writes + 1L + original_writer(x, combo, run_info, output_type, folder, suffix) + }, + .package = "finnts" + ) + + expect_error(final_models(run_info), "Reconciled forecasts are incomplete or invalid", fixed = TRUE) + expect_equal(reconciliations, 1L) + expect_equal(log_writes, 0L) + expect_equal(read_selection_file(run_info, "logs"), previous_log) + }) +}) + +test_that("reconciled artifact access and deserialization errors propagate", { + for (failure in c("metadata", "payload", "deserialization")) local({ + run_info <- artifact_test_run(withr::local_tempdir(), "rds") + predictions <- artifact_completed_final_outputs(run_info) + write_data(predictions, "Best-Model", run_info, "data", "forecasts", "-reconciled") + path <- artifact_test_path(run_info, "forecasts", "Best-Model", "-reconciled") + reconciliations <- 0L + original_reader <- read_file + original_info <- fs::file_info + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + reconcile_hierarchical_data = function(...) { reconciliations <<- reconciliations + 1L }, + .package = "finnts" + ) + if (failure == "metadata") { + local_mocked_bindings(file_info = function(path, ...) { + if (any(grepl("-reconciled", path, fixed = TRUE))) { + rlang::abort("reconciliation access denied", class = "reconciliation_storage_error") + } + original_info(path, ...) + }, .package = "fs") + } else if (failure == "payload") { + local_mocked_bindings(read_file = function(run_info, path = NULL, file_list = NULL, ...) { + if (any(grepl("-reconciled", c(path, file_list), fixed = TRUE))) { + rlang::abort("reconciliation access denied", class = "reconciliation_storage_error") + } + original_reader(run_info, path, file_list, ...) + }, .package = "finnts") + } else writeLines("invalid serialized artifact", path) + + if (failure == "deserialization") { + expect_error(final_models(run_info), "unknown input format|error reading from connection") + } else { + expect_error(final_models(run_info), class = "reconciliation_storage_error") + } + expect_equal(reconciliations, 0L) + }) +}) + local_artifact_logger <- function(agent_info, run_info, .env = parent.frame()) { log <- tibble::tibble(project_name = run_info$project_name, run_name = run_info$run_name, path = run_info$path, data_output = run_info$data_output, object_output = run_info$object_output, diff --git a/tests/testthat/test-best_models.R b/tests/testthat/test-best_models.R index 2ebec3ed..8721eb3d 100644 --- a/tests/testthat/test-best_models.R +++ b/tests/testthat/test-best_models.R @@ -6,129 +6,6 @@ # drops those folds from the per-model output, and historically the surviving # model could win Best_Model on a smaller, easier sample than its competitors. -# helpers tied to a fresh run_info for each test -locate_single_models_file <- function(run_info) { - forecasts_dir <- file.path(run_info$path, "forecasts") - run_hash <- hash_data(run_info$run_name) - pattern <- paste0( - "^", - hash_data(run_info$project_name), "-", - run_hash, "-.*-single_models\\.(csv|parquet)$" - ) - files <- list.files(forecasts_dir, pattern = pattern, full.names = TRUE) - if (length(files) != 1) { - stop( - "expected exactly 1 single_models file for run ", run_info$run_name, - " but found ", length(files) - ) - } - files -} - -read_fcst_file <- function(path) { - ext <- tools::file_ext(path) - if (ext == "parquet") { - arrow::read_parquet(path) - } else { - suppressMessages(vroom::vroom(path, show_col_types = FALSE, altrep = FALSE)) - } -} - -write_fcst_file <- function(x, path) { - ext <- tools::file_ext(path) - if (ext == "parquet") { - arrow::write_parquet(x, path) - } else { - vroom::vroom_write(x, path, delim = ",") - } -} - -make_best_models_fixture <- function() { - run_path <- tempfile("finnts-best-models-") - dir.create(run_path) - run_info <- set_run_info( - project_name = "best_models_test", - run_name = "partial_fold_coverage", - path = run_path, - add_unique_id = FALSE - ) - - log_path <- paste0( - "logs/", hash_data(run_info$project_name), "-", - hash_data(run_info$run_name), ".csv" - ) - log_data <- finnts:::read_file(run_info, path = log_path, return_type = "df") %>% - dplyr::mutate( - date_type = "month", - combo_variables = "Series", - forecast_approach = "bottoms_up", - negative_forecast = FALSE, - run_global_models = FALSE, - run_local_models = TRUE, - run_ensemble_models = FALSE - ) - finnts:::write_data( - log_data, - combo = NULL, - run_info = run_info, - output_type = "log", - folder = "logs", - suffix = NULL - ) - - splits <- tibble::tibble( - Run_Type = c("Future_Forecast", rep("Back_Test", 3)), - Train_Test_ID = 1:4, - Train_End = as.Date("2023-12-01") - c(0, 31, 62, 93), - Test_End = as.Date("2024-03-01") - c(0, 31, 62, 93) - ) - finnts:::write_data( - splits, - combo = NULL, - run_info = run_info, - output_type = "data", - folder = "prep_models", - suffix = "-train_test_split" - ) - - forecasts <- tidyr::expand_grid( - Model_Name = c("meanf", "snaive"), - Train_Test_ID = 1:4, - Horizon = 1:3 - ) %>% - dplyr::mutate( - Combo_ID = "Synthetic", - Combo = "Synthetic", - Model_Type = "local", - Recipe_ID = "R1", - Model_ID = paste(Model_Name, Model_Type, Recipe_ID, sep = "--"), - Hyperparameter_ID = 1, - Date = as.Date("2024-01-01") + ((Train_Test_ID - 1) * 31) + Horizon, - Target = ifelse(Train_Test_ID == 1, NA_real_, 100 + Horizon), - Forecast = dplyr::case_when( - Train_Test_ID == 1 ~ 100 + Horizon, - Model_Name == "meanf" ~ Target * 1.10, - Train_Test_ID == 2 ~ Target * 1.01, - Train_Test_ID == 3 ~ Target * 1.20, - TRUE ~ Target * 1.30 - ) - ) %>% - dplyr::select( - Combo_ID, Model_ID, Model_Name, Model_Type, Recipe_ID, - Train_Test_ID, Hyperparameter_ID, Combo, Horizon, Date, Target, Forecast - ) - finnts:::write_data( - forecasts, - combo = "Synthetic", - run_info = run_info, - output_type = "data", - folder = "forecasts", - suffix = "-single_models" - ) - - run_info -} - test_that("final_models excludes models with partial back test coverage from Best_Model selection", { skip_on_cran() diff --git a/tests/testthat/test-direct-artifact-reads.R b/tests/testthat/test-direct-artifact-reads.R index 51b2be3f..25b2bf03 100644 --- a/tests/testthat/test-direct-artifact-reads.R +++ b/tests/testthat/test-direct-artifact-reads.R @@ -32,6 +32,81 @@ test_that("single-combo forecast getter retains every existing model output", { expect_equal(tracker$listings, 1L) }) +for (format in c("csv", "rds", "parquet")) { + test_that(paste("standard hierarchical getter retains all reconciled models for", format), { + if (format == "parquet") skip_if_not_installed("arrow") + run_info <- artifact_test_run(withr::local_tempdir(), format) + artifact_test_log(run_info, combo_variables = "ID", forecast_approach = "standard_hierarchy") + artifact_test_splits(run_info) + models <- c("meanf--local--R1", "snaive--local--R1", "Best-Model") + for (model in models) { + rows <- artifact_test_forecast(run_info, write_output = FALSE) + rows$Model_ID <- model + rows$Forecast <- match(model, models) * 100 + rows$Best_Model <- if (model == "Best-Model") "Yes" else "No" + write_data(rows, model, run_info, "data", "forecasts", "-reconciled") + } + tracker <- local_artifact_spies(max_listings = 1L) + + result <- get_forecast_data(run_info) + + expect_setequal(result$Model_ID, models) + expect_equal(nrow(result), 3L) + expect_equal(result$Forecast, match(result$Model_ID, models) * 100) + expect_identical(result$Model_ID[result$Best_Model == "Yes"], "Best-Model") + expect_equal(tracker$listings, 1L) + }) +} + +test_that("hierarchical getters retain models and weekly rows without unrelated artifacts", { + for (approach in c("standard_hierarchy", "grouped_hierarchy")) { + for (daily in c(FALSE, TRUE)) local({ + run_info <- artifact_test_run(withr::local_tempdir()) + artifact_test_log(run_info, date_type = "week", combo_variables = "ID", forecast_approach = approach) + artifact_test_splits(run_info) + models <- c("meanf--local--R1", "snaive--local--R1", "Best-Model") + expected <- dplyr::bind_rows(lapply(models, function(model) { + rows <- artifact_test_forecast(run_info, write_output = FALSE) + rows$Model_ID <- model + rows$Forecast <- match(model, models) * 700 + rows$Best_Model <- if (model == "Best-Model") "Yes" else "No" + if (daily) { + rows <- rows[rep(1L, 7), ] + rows$Date_Day <- rows$Date + 0:6 + rows$Forecast <- rows$Forecast / 7 + } + write_data(rows, model, run_info, "data", "forecasts", "-reconciled") + rows + })) + unrelated <- run_info + unrelated$run_name <- "unrelated-run" + write_data(expected, "Best-Model", unrelated, "data", "forecasts", "-reconciled") + write_data(expected, "batch", run_info, "data", "forecasts", "-condensed") + artifact_test_forecast(run_info) + tracker <- local_artifact_spies(max_listings = 1L) + + result <- get_forecast_data(run_info) + + expect_setequal(result$Model_ID, models) + columns <- c("Combo", "Model_ID", "Date", if (daily) "Date_Day", "Forecast", "Best_Model") + expect_equal(dplyr::arrange(result[, columns], Model_ID, Date), + dplyr::arrange(expected[, columns], Model_ID, Date)) + expect_equal(tracker$listings, 1L) + paths <- vapply(models, function(model) as.character(artifact_test_path(run_info, "forecasts", model, "-reconciled")), character(1)) + expect_true(all(vapply(paths, function(path) sum(tracker$payload_paths == path) == 1L, logical(1)))) + }) + } +}) + +test_that("per-model reconciled output cannot replace a missing required best artifact", { + run_info <- artifact_test_run(withr::local_tempdir()) + artifact_test_log(run_info, combo_variables = "ID", forecast_approach = "standard_hierarchy") + artifact_test_splits(run_info) + rows <- artifact_test_forecast(run_info, write_output = FALSE) + write_data(rows, "meanf--local--R1", run_info, "data", "forecasts", "-reconciled") + expect_error(get_forecast_data(run_info), "Missing required Finn artifact.*reconciled") +}) + test_that("trained model getter reads exactly the known combo model files", { run_info <- artifact_test_run(withr::local_tempdir()) run_info$combo <- hash_data("A") diff --git a/tests/testthat/test-final-models-restart.R b/tests/testthat/test-final-models-restart.R new file mode 100644 index 00000000..2b259469 --- /dev/null +++ b/tests/testthat/test-final-models-restart.R @@ -0,0 +1,265 @@ +make_restart_average_predictions <- function(info) { + path <- locate_single_models_file(info) + rows <- read_fcst_file(path) + actuals <- ifelse(rows$Train_Test_ID == 1, + 100 + as.integer(format(as.Date(rows$Date), "%m")), rows$Target) + rows$Forecast <- actuals * ifelse(rows$Model_Name == "meanf", 1.1, 0.9) + write_fcst_file(rows, path) + rows +} + +test_that("unfinished Best_Model flags are repaired by rerunning selection and averages", { + evaluations <- 0L + original_selector <- select_series_forecasts + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + train_models = function(...) stop("retry must not train models"), + fit_models = function(...) stop("retry must not fit models"), + select_series_forecasts = function(...) { + evaluations <<- evaluations + 1L + original_selector(...) + } + ) + info <- make_best_models_fixture() + rows <- make_restart_average_predictions(info) + rows$Best_Model <- "No" + write_fcst_file(rows, locate_single_models_file(info)) + result <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + expect_identical(evaluations, 2L) + expect_setequal(strsplit(result$selections$Synthetic$selected_id, "_", fixed = TRUE)[[1]], + unique(rows$Model_ID)) + average <- read_selection_file(info, "forecasts", "-average_models", "Synthetic") + expect_true(all(average$Best_Model == "Yes")) + expect_true(all(read_fcst_file(locate_single_models_file(info))$Best_Model == "No")) + published <- get_forecast_data(info) + expect_identical(unique(published$Model_ID[published$Best_Model == "Yes"]), + result$selections$Synthetic$selected_id) +}) + +test_that("a completed saved average survives a retry before completion logging", { + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + train_models = function(...) stop("retry must not train models") + ) + info <- make_best_models_fixture() + info$combo <- hash_data("Synthetic") + make_restart_average_predictions(info) + initial <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + log <- read_selection_file(info, "logs") + log$weighted_mape <- NA_real_ + write_data(log, combo = NULL, run_info = info, output_type = "log", folder = "logs", suffix = NULL) + local_mocked_bindings(select_series_forecasts = function(...) stop("a complete saved winner must not be reselected")) + result <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + expect_identical(result$selections$Synthetic$selected_id, initial$selections$Synthetic$selected_id) + expect_equal(agent_selection_summary(result)$weighted_mape, 0) + expect_length(result$rejected_combos, 0L) +}) + +test_that("a finite completion log cannot hide invalid saved winner flags", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + for (defect in c("all_no", "missing_flag", "multiple_winners")) { + info <- make_best_models_fixture() + make_restart_average_predictions(info) + initial <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + average <- read_selection_file(info, "forecasts", "-average_models", "Synthetic") + rows <- read_fcst_file(locate_single_models_file(info)) + if (defect == "multiple_winners") { + rows$Best_Model[rows$Model_Name == "meanf"] <- "Yes" + write_fcst_file(rows, locate_single_models_file(info)) + } else { + average$Best_Model <- if (defect == "all_no") "No" else NA_character_ + write_data(average, combo = "Synthetic", run_info = info, + output_type = "data", folder = "forecasts", suffix = "-average_models") + } + result <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + expect_identical(result$selections$Synthetic$selected_id, initial$selections$Synthetic$selected_id, + info = defect) + saved <- dplyr::bind_rows(read_fcst_file(locate_single_models_file(info)), + read_selection_file(info, "forecasts", "-average_models", "Synthetic")) + expect_false(anyNA(saved$Best_Model), info = defect) + expect_identical(unique(saved$Model_ID[saved$Best_Model == "Yes"]), + initial$selections$Synthetic$selected_id, info = defect) + } +}) + +test_that("average file existence cannot suppress a complete retry result", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + make_restart_average_predictions(info) + initial <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + log <- read_selection_file(info, "logs") + log$weighted_mape <- NA_real_ + write_data(log, combo = NULL, run_info = info, output_type = "log", folder = "logs", suffix = NULL) + local_mocked_bindings(select_series_forecasts = function(...) stop("complete series must not be reselected")) + result <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + expect_true(is.list(result) && "Synthetic" %in% names(result$selections)) + if (is.list(result)) { + expect_identical(result$selections$Synthetic$selected_id, initial$selections$Synthetic$selected_id) + } +}) + +test_that("multi-series retries retain completed and newly finalized results", { + evaluated <- character() + original_selector <- select_series_forecasts + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + rows <- make_restart_average_predictions(info) + first <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + history <- read_selection_file(info, "prep_data", "-R1", "Synthetic") + history$Combo <- "Other" + write_data(history, combo = "Other", run_info = info, + output_type = "data", folder = "prep_data", suffix = "-R1") + rows$Combo <- "Other" + rows$Combo_ID <- "Other" + write_data(rows, combo = "Other", run_info = info, + output_type = "data", folder = "forecasts", suffix = "-single_models") + log <- read_selection_file(info, "logs") + log$weighted_mape <- NA_real_ + write_data(log, combo = NULL, run_info = info, output_type = "log", folder = "logs", suffix = NULL) + local_mocked_bindings( + select_series_forecasts = function(predictions, ...) { + evaluated <<- c(evaluated, unique(predictions$Combo)) + original_selector(predictions, ...) + }, + train_models = function(...) stop("retry must not train models") + ) + result <- final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + expect_setequal(names(result$selections), c("Synthetic", "Other")) + expect_identical(result$selections$Synthetic$selected_id, first$selections$Synthetic$selected_id) + expect_identical(evaluated, c("Other", "Other")) + expect_setequal(unique(get_forecast_data(info)$Combo), c("Synthetic", "Other")) + expect_equal(agent_selection_summary(result)$weighted_mape, 0) +}) + +test_that("saved average reuse requires its original component predictions", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + make_restart_average_predictions(info) + final_models(info, average_models = TRUE, weekly_to_daily = FALSE) + rows <- read_fcst_file(locate_single_models_file(info)) + rows <- rows[rows$Model_Name != "meanf", ] + write_fcst_file(rows, locate_single_models_file(info)) + expect_error(final_models(info, average_models = TRUE, weekly_to_daily = FALSE), + "component predictions are missing") +}) + +test_that("prediction read errors are not treated as absent model families", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + original_reader <- read_file + local_mocked_bindings(read_file = function(run_info, path = NULL, file_list = NULL, ...) { + requested <- if (is.null(file_list)) path else file_list + if (any(grepl("-single_models", requested, fixed = TRUE))) stop("prediction storage unavailable") + original_reader(run_info, path = path, file_list = file_list, ...) + }) + expect_error(final_models(info, weekly_to_daily = FALSE), "prediction storage unavailable") +}) + +test_that("partial weekly hierarchy retries repair one source without changing delivered values", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + fixture <- make_hierarchical_selection_artifacts(date_type = "week", horizon = 3L, + backtest_scenarios = 1L) + info <- fixture$run_info + initial <- final_models(info, average_models = FALSE, weekly_to_daily = TRUE) + expected <- get_forecast_data(info) + source_combo <- fixture$metadata$hts_combos[1] + source <- read_selection_file(info, "forecasts", "-single_models", source_combo) + source$Best_Model <- NA_character_ + source <- convert_weekly_to_daily(source, "week", TRUE) + write_data(source, combo = source_combo, run_info = info, + output_type = "data", folder = "forecasts", suffix = "-single_models") + evaluated <- character() + original_selector <- select_series_forecasts + local_mocked_bindings( + train_models = function(...) stop("retry must not train models"), + select_series_forecasts = function(predictions, ...) { + evaluated <<- c(evaluated, unique(predictions$Combo)) + original_selector(predictions, ...) + } + ) + repaired <- final_models(info, average_models = FALSE, weekly_to_daily = TRUE) + expect_setequal(names(repaired$selections), fixture$metadata$original_combos) + expect_identical(evaluated, rep(source_combo, 2L)) + expect_equal(agent_selection_summary(repaired)$weighted_mape, + agent_selection_summary(initial)$weighted_mape, tolerance = 1e-7) + delivered <- get_forecast_data(info) + columns <- c("Combo", "Model_ID", "Train_Test_ID", "Date", "Date_Day", "Forecast", "Target", "Best_Model") + expect_equal(dplyr::arrange(delivered[, columns], Combo, Model_ID, Train_Test_ID, Date, Date_Day), + dplyr::arrange(expected[, columns], Combo, Model_ID, Train_Test_ID, Date, Date_Day), tolerance = 1e-7) + expect_false(any(grepl("\\.[xy]$", names(delivered)))) + local_mocked_bindings( + select_series_forecasts = function(...) stop("complete hierarchy must not be reselected"), + reconcile_hierarchical_data = function(...) stop("unchanged hierarchy must not be reconciled again") + ) + resumed <- final_models(info, average_models = FALSE, weekly_to_daily = TRUE) + expect_equal(agent_selection_summary(resumed), agent_selection_summary(repaired), tolerance = 1e-7) +}) + +test_that("grouped hierarchy retries rebuild damaged reconciled output from complete sources", { + for (date_type in c("month", "week")) local({ + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + fixture <- make_hierarchical_selection_artifacts(approach = "grouped_hierarchy", + date_type = date_type, horizon = 2L, backtest_scenarios = 1L) + info <- fixture$run_info + initial <- final_models(info, average_models = FALSE, weekly_to_daily = TRUE) + expected <- get_forecast_data(info) + damaged <- read_selection_file(info, "forecasts", "-reconciled", "Best-Model") + if (date_type == "month") { + damaged <- damaged[damaged$Combo != fixture$metadata$original_combos[1], ] + } else damaged <- damaged[-2, ] + write_data(damaged, "Best-Model", info, "data", "forecasts", "-reconciled") + reconciliations <- 0L + original_reconcile <- reconcile_hierarchical_data + local_mocked_bindings( + train_models = function(...) stop("restart must not train models"), + select_series_forecasts = function(...) stop("complete hierarchy sources must not be reselected"), + reconcile_hierarchical_data = function(...) { + reconciliations <<- reconciliations + 1L + original_reconcile(...) + } + ) + + repaired <- final_models(info, average_models = FALSE, weekly_to_daily = TRUE) + + expect_equal(reconciliations, 1L) + expect_length(repaired$rejected_combos, 0L) + expect_equal(get_forecast_data(info), expected, tolerance = 1e-7) + expect_equal(agent_selection_summary(repaired), agent_selection_summary(initial), tolerance = 1e-7) + local_mocked_bindings(reconcile_hierarchical_data = function(...) stop("repaired output must be reused")) + expect_no_error(final_models(info, average_models = FALSE, weekly_to_daily = TRUE)) + }) +}) + +test_that("explicitly completed rejections are not evaluated again on retry", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + info$allow_quality_rejection <- TRUE + rows <- read_fcst_file(locate_single_models_file(info)) + rows$Forecast <- Inf + write_fcst_file(rows, locate_single_models_file(info)) + initial <- final_models(info, weekly_to_daily = FALSE) + log <- record_agent_selection_attempt(read_selection_file(info, "logs"), initial, + list(agent_version = 1, forecast_approach = "bottoms_up")) + write_data(log, combo = NULL, run_info = info, output_type = "log", folder = "logs", suffix = NULL) + local_mocked_bindings(select_series_forecasts = function(...) stop("completed rejection must not be reassessed")) + result <- final_models(info, weekly_to_daily = FALSE) + expect_identical(result$rejected_combos, "Synthetic") + expect_identical(agent_selection_summary(result)$status, "rejected") + expect_true(is.na(read_selection_file(info, "logs")$weighted_mape)) +}) \ No newline at end of file diff --git a/tests/testthat/test-forecast-selection-corners.R b/tests/testthat/test-forecast-selection-corners.R new file mode 100644 index 00000000..3bce49b1 --- /dev/null +++ b/tests/testthat/test-forecast-selection-corners.R @@ -0,0 +1,556 @@ +local_corner_test_safety <- function(.env = parent.frame()) { + unexpected_work <- function(...) { + stop("Selection corner tests must not perform I/O, fit models, or reconcile.", call. = FALSE) + } + testthat::local_mocked_bindings( + read_file = unexpected_work, list_files = unexpected_work, write_data = unexpected_work, + prep_data = unexpected_work, prep_models = unexpected_work, train_models = unexpected_work, + fit_models = unexpected_work, final_models = unexpected_work, reconcile = unexpected_work, + .package = "finnts", .env = .env + ) +} + +test_that("selection requires finite actuals inside the recent reference window", { + local_corner_test_safety() + for (unusable in c(NA_real_, NaN, Inf, -Inf)) { + fixture <- make_selection_case(actuals = c(rep(100, 36), rep(unusable, 36))) + expect_error(do.call(select_forecast_candidate, fixture), + "usable historical actuals.*reference window") + } +}) + +test_that("partly missing and zero reference windows remain usable", { + local_corner_test_safety() + for (recent_value in c(0, 100)) { + fixture <- make_selection_case(actuals = c(rep(100, 36), rep(NA_real_, 35), recent_value), + futures = list(only = rep(recent_value, 6)), errors = c(only = 0.03)) + fixture$backtests$Forecast <- recent_value + expect_silent(reference <- forecast_reference(fixture$history, 6L, fixture$context)) + expect_equal(reference$reference * if (reference$normalization > 0) reference$normalization else 1, + rep(recent_value, 6)) + expect_silent(result <- do.call(select_forecast_candidate, fixture)) + expect_identical(result$selected_id, "only") + expect_true(result$rankings$Eligible) + expect_equal(result$rankings$Risk, 0) + expect_true(is.finite(result$rankings$WMAPE)) + expect_true(is.na(result$rankings$Seasonal_Fidelity)) + } +}) + +test_that("future values cannot rescue an unusable historical window", { + local_corner_test_safety() + fixture <- make_selection_case(actuals = c(rep(100, 36), rep(NA_real_, 36))) + fixture$forecasts$Target <- 100 + fixture$history <- rbind(fixture$history, + data.frame(Date = max(fixture$history$Date) + 1, Target = 100)) + expect_error(do.call(select_forecast_candidate, fixture), "reference window") + fixture$history$Target <- NA_real_ + expect_error(do.call(select_forecast_candidate, fixture), "unique dated historical actuals") +}) + +test_that("empty candidate pools have an explicit input error", { + local_corner_test_safety() + fixture <- make_selection_case() + fixture$context$candidate_ids <- character() + expect_error(do.call(select_forecast_candidate, fixture), "at least one candidate") + series <- fixture$context + series$history <- fixture$history + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts)[0, ] + expect_error(select_series_forecasts(predictions, series, series$train_test_split), + "at least one candidate") +}) + +test_that("single and all-invalid pools retain their selection semantics", { + local_corner_test_safety() + fixture <- make_selection_case(futures = list(only = rep(200, 6)), errors = c(only = 0.08)) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "only") + expect_true(result$rankings$Eligible) + expect_gt(result$rankings$Violations, 0L) + fixture$forecasts$Forecast[1] <- Inf + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, NA_character_) + expect_false(result$rankings$Eligible) + fixture <- make_selection_case() + fixture$forecasts$Forecast <- Inf + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, NA_character_) + expect_false(any(result$rankings$Eligible)) + summary <- agent_selection_summary(list(selections = list(series = result))) + expect_false(summary$acceptable) + expect_identical(summary$status, "rejected") + expect_identical(summary$weighted_mape, Inf) +}) + +test_that("required keys cannot be replaced while preserving row counts", { + local_corner_test_safety() + fixture <- make_selection_case(futures = list(accurate = rep(100, 6), safe = rep(100, 6)), + errors = c(accurate = 0.02, safe = 0.023)) + keys <- c("Train_Test_ID", "Date") + defects <- c("duplicate", "missing", "extra", "off_calendar", "wrong_fold", "missing_date", "missing_fold") + for (table in c("backtests", "forecasts")) { + for (defect in defects) { + altered <- fixture + rows <- altered[[table]] + indices <- which(rows$Model_ID == "accurate") + if (defect == "duplicate") rows[indices[1], keys] <- rows[indices[2], keys] + if (defect == "missing") rows <- rows[-indices[1], ] + if (defect == "extra") rows <- rbind(rows, rows[indices[1], ]) + if (defect == "off_calendar") rows$Date[indices[1]] <- rows$Date[indices[1]] + 1 + if (defect == "wrong_fold") rows$Train_Test_ID[indices[1]] <- 97L + if (defect == "missing_date") rows$Date[indices[1]] <- as.Date(NA) + if (defect == "missing_fold") rows$Train_Test_ID[indices[1]] <- NA_integer_ + altered[[table]] <- rows + expected <- fixture[[table]][fixture[[table]]$Model_ID == "accurate", keys] + actual <- rows[rows$Model_ID == "accurate", keys] + expect_false(forecast_keys_complete(actual, expected), info = paste(table, defect)) + if (!defect %in% c("missing", "extra")) expect_equal(nrow(actual), nrow(expected)) + result <- do.call(select_forecast_candidate, altered) + expect_identical(result$selected_id, "safe") + expect_false(result$rankings$Eligible[result$rankings$Model_ID == "accurate"]) + expect_true(result$rankings$Eligible[result$rankings$Model_ID == "safe"]) + reason <- if (table == "backtests") "incomplete_backtests" else "incomplete_forecast" + expect_true(reason %in% result$rankings$Reasons[[match("accurate", result$rankings$Model_ID)]]) + } + } + expected <- fixture$backtests[fixture$backtests$Model_ID == "safe", keys] + equivalent <- expected[nrow(expected):1, ] + equivalent$Train_Test_ID <- as.character(equivalent$Train_Test_ID) + equivalent$Date <- as.character(equivalent$Date) + expect_true(forecast_keys_complete(equivalent, expected)) + expect_false(forecast_keys_complete(expected[0, ], expected[0, ])) +}) + +test_that("validation-only rows are excluded from candidate evaluation", { + local_corner_test_safety() + fixture <- make_selection_case() + expected <- do.call(select_forecast_candidate, fixture) + validation <- fixture$backtests + validation$Train_Test_ID <- 99L + validation$Forecast <- Inf + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts, validation) + splits <- fixture$context$train_test_split + validation_split <- splits[2, ] + validation_split$Train_Test_ID <- 99L + validation_split$Run_Type <- "Validation" + splits <- rbind(splits, validation_split) + series <- fixture$context + series$history <- fixture$history + expect_equal(select_series_forecasts(predictions, series, splits), expected) +}) + +test_that("backtest accuracy uses original signed zero and missing actuals", { + local_corner_test_safety() + dates <- as.Date("2024-01-01") + 0:4 + history <- data.frame(Date = dates, Target = c(-10, 0, 20, NA_real_, Inf)) + backtests <- data.frame(Train_Test_ID = c(rep(2L, 5), 3L, 3L), + Date = dates[c(1:5, 1, 3)], Forecast = c(-9, 0, 24, 999, 999, -8, 18), Target = -999) + accuracy <- forecast_backtest_accuracy(history, backtests) + expect_equal(accuracy$WMAPE, 9.1 / 60.1, tolerance = 1e-12) + expect_equal(accuracy$Log_Weight, log(60.1), tolerance = 1e-12) + rounded <- data.frame(Date = dates[1], Forecast = -8.76544) + expect_equal(forecast_backtest_accuracy(history, rounded)$WMAPE, 0.1235) + backtests$Target <- 1e100 + expect_identical(forecast_backtest_accuracy(history, backtests), accuracy) + backtests$Forecast <- 0 + expect_equal(forecast_backtest_accuracy(history, backtests)$WMAPE, 1) + backtests$Forecast[4] <- NA_real_ + expect_true(is.na(forecast_backtest_accuracy(history, backtests)$WMAPE)) + backtests$Forecast <- 0 + history$Target <- NA_real_ + unavailable <- forecast_backtest_accuracy(history, backtests) + expect_true(is.na(unavailable$WMAPE)) + expect_true(is.na(unavailable$Log_Weight)) +}) + +test_that("missing backtest actuals cannot create an eligible accuracy score", { + local_corner_test_safety() + fixture <- make_selection_case(actuals = c(rep(100, 30), rep(NA_real_, 6))) + fixture$backtests$Forecast <- 100 + fixture$backtests$Target <- 100 + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, NA_character_) + expect_false(any(result$rankings$Eligible)) + expect_true(all(vapply(result$rankings$Reasons, function(reasons) { + "unavailable_accuracy" %in% reasons + }, logical(1)))) +}) + +test_that("Agent accuracy respects unequal volumes without losing completeness", { + local_corner_test_safety() + selection <- function(wmape, volume) { + list(selected_id = "chosen", rankings = tibble::tibble( + Model_ID = "chosen", Eligible = TRUE, WMAPE = wmape, Log_Weight = log(volume), + Risk = 0, Violations = 0L, Reasons = list(character()), Seasonal_Fidelity = NA_real_)) + } + complete <- list(selections = list(small = selection(0.1, 10), large = selection(0.2, 1000))) + summary <- agent_selection_summary(complete) + expect_equal(summary$weighted_mape, 201 / 1010, tolerance = 1e-12) + expect_true(summary$acceptable) + scaled <- list(selections = list(small = selection(0.1, 1e251), large = selection(0.2, 1e253))) + expect_equal(agent_selection_summary(scaled)$weighted_mape, summary$weighted_mape, tolerance = 1e-12) + partial <- list(selections = list(small = complete$selections$small, large = NULL)) + summary <- agent_selection_summary(partial) + expect_identical(summary$status, "partial") + expect_identical(summary$weighted_mape, Inf) + expect_false(summary$acceptable) + expect_identical(rank_agent_run_selections(list(partial, complete))$best_run_index, 2L) +}) + +test_that("catastrophic magnitude boundaries apply to both prediction periods", { + local_corner_test_safety() + fixture <- make_selection_case(futures = list(accurate = rep(100, 6), safe = rep(100, 6))) + for (table in c("backtests", "forecasts")) { + for (direction in c(-1, 1)) { + for (multiple in c(100 - 1e-7, 100, 100 + 1e-7)) { + altered <- fixture + index <- which(altered[[table]]$Model_ID == "accurate")[1] + altered[[table]]$Forecast[index] <- direction * 100 * multiple + result <- do.call(select_forecast_candidate, altered) + candidate <- result$rankings[result$rankings$Model_ID == "accurate", ] + expect_identical(candidate$Eligible, multiple <= 100) + expect_identical("catastrophic_magnitude" %in% candidate$Reasons[[1]], multiple > 100) + expect_true(result$rankings$Eligible[result$rankings$Model_ID == "safe"]) + } + } + } +}) + +test_that("zero-history forecasts use soft level checks instead of magnitude ratios", { + local_corner_test_safety() + fixture <- make_selection_case(actuals = rep(0, 36), + futures = list(zero = rep(0, 6), nonzero = rep(1e9, 6)), errors = c(zero = 0, nonzero = 0)) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "zero") + expect_true(all(result$rankings$Eligible)) + nonzero <- result$rankings[result$rankings$Model_ID == "nonzero", ] + expect_identical(nonzero$Reasons[[1]], "unsupported_level") + expect_equal(nonzero$Risk, 1) + expect_equal(nonzero$WMAPE, 1) +}) + +test_that("zero-width level matches do not erase nonzero deviations", { + local_corner_test_safety() + for (unit_scale in c(1e-80, 1, 1e80)) { + for (direction in c(-1, 1)) { + history <- data.frame(Date = seq(as.Date("2000-01-01"), by = "week", length.out = 260), + Target = direction * unit_scale * c(rep(0, 257), 500, 100, 100)) + context <- list(date_type = "week", hist_end_date = max(history$Date)) + reference <- forecast_reference(history, 3, context) + expect_identical(reference$scale, 0) + expect_identical(reference$width, 0) + expect_gt(reference$normalization, 0) + expect_silent(matched <- forecast_path_risk(rep(0, 3), reference)) + expect_identical(matched$components[["level"]], 0) + expect_identical(matched$risk, 0) + + reference$reference <- direction * c(0, 0.2, 1) + forecast <- direction * unit_scale * c(0, 105, 500) + expect_silent(deviating <- forecast_path_risk(forecast, reference)) + expect_identical(deviating$components[["level"]], .Machine$double.xmax) + expect_identical(deviating$risk, .Machine$double.xmax) + expect_identical(deviating$reasons, "level_deviation") + } + } +}) + +test_that("zero-scale trend comparisons have explicit matching and deviating results", { + local_corner_test_safety() + history <- data.frame(Date = seq(as.Date("2000-01-01"), by = "week", length.out = 260), + Target = c(rep(0, 257), 500, 100, 100)) + reference <- forecast_reference(history, 52, list(date_type = "week", hist_end_date = max(history$Date))) + for (level in c(105, 100)) { + expect_silent(result <- forecast_path_risk(rep(level, 52), reference)) + expect_identical(result$components[["level"]], .Machine$double.xmax) + expect_identical(result$components[["trend"]], 0) + expect_identical(result$reasons, "level_deviation") + expect_true(is.finite(result$risk)) + } + expect_silent(sloped <- forecast_path_risk(105 + seq_len(52), reference)) + expect_identical(sloped$components[["trend"]], .Machine$double.xmax) + expect_true(all(c("level_deviation", "trend_deviation") %in% sloped$reasons)) + expect_true(all(is.finite(sloped$components[!is.na(sloped$components)]))) +}) + +test_that("mixed forecast widths preserve exact matches and ordinary ratios", { + local_corner_test_safety() + fixture <- make_selection_case(actuals = rep(100, 36), futures = list(only = rep(100, 3)), + errors = c(only = 0.03)) + reference <- forecast_reference(fixture$history, 3, fixture$context) + reference$trend <- list(mode = "additive", projection = rep(1, 3), widths = c(0, 0.1, 0)) + expect_silent(result <- forecast_path_risk(c(100, 120, 100), reference)) + expect_equal(result$components[["level"]], 1, tolerance = 1e-12) + expect_identical(result$reasons, "level_deviation") + expect_silent(deviating <- forecast_path_risk(c(100, 120, 105), reference)) + expect_identical(deviating$components[["level"]], .Machine$double.xmax) + + reference$trend <- NULL + for (width in c(0.05, 1e-100, .Machine$double.xmin)) { + reference$width <- width + forecast <- c(100, 105, 95) + expected <- min(.Machine$double.xmax, + max(0, max(abs(forecast / reference$normalization - reference$reference) / + (6 * width * sqrt(seq_along(forecast)))) - 1)) + expect_silent(result <- forecast_path_risk(forecast, reference)) + expect_equal(result$components[["level"]], expected, tolerance = 1e-12) + } +}) + +test_that("accuracy ceilings retain their numerical tolerance", { + local_corner_test_safety() + for (best in c(0, 0.08, 0.2)) { + ceiling <- best + max(0.005, 0.05 * best) + tolerance <- 8 * .Machine$double.eps + for (difference in c(-1e-6, 0, tolerance / 2, tolerance * 4)) { + rankings <- tibble::tibble(Model_ID = c("accuracy", "fidelity"), Eligible = TRUE, + WMAPE = c(best, ceiling + difference), Risk = 0, Violations = 0L, + Reasons = list(character(), character()), Seasonal_Fidelity = c(1, 0)) + expected <- if (difference <= tolerance) "fidelity" else "accuracy" + expect_identical(rank_forecast_candidates(rankings)$selected_id, expected) + expect_identical(rank_forecast_candidates(rankings[2:1, ])$selected_id, expected) + } + } +}) + +test_that("unknown fidelity affects only its tied shortlisted cohort", { + local_corner_test_safety() + rankings <- tibble::tibble(Model_ID = c("accuracy", "fidelity", "other", "unknown"), + Eligible = TRUE, WMAPE = c(0.08, 0.083, 0.084, 0.082), Risk = c(0, 0, 0.2, 0.2), + Violations = c(0L, 0L, 1L, 1L), Reasons = rep(list(character()), 4), + Seasonal_Fidelity = c(0.5, 0, 0, NA_real_)) + for (unknown in c(NA_real_, NaN, Inf)) { + rows <- rankings + rows$Seasonal_Fidelity[4] <- unknown + expect_identical(rank_forecast_candidates(rows)$selected_id, "fidelity") + rows$Risk[4] <- 0 + rows$Violations[4] <- 0L + expect_identical(rank_forecast_candidates(rows)$selected_id, "accuracy") + rows$WMAPE[4] <- 0.1 + expect_identical(rank_forecast_candidates(rows)$selected_id, "fidelity") + rows$Eligible[4] <- FALSE + rows$WMAPE[4] <- 0 + expect_identical(rank_forecast_candidates(rows)$selected_id, "fidelity") + } + rankings$Risk <- c(2, 1, 1, 3) + rankings$Violations <- c(1L, 1L, 2L, 1L) + expect_identical(rank_forecast_candidates(rankings)$selected_id, "fidelity") + rankings$Seasonal_Fidelity <- NULL + expect_identical(rank_forecast_candidates(rankings)$selected_id, "fidelity") +}) + +test_that("replacement selectors must satisfy the existing structural contract", { + local_corner_test_safety() + fixture <- make_selection_case() + valid <- do.call(select_forecast_candidate, fixture) + duplicate <- valid + duplicate$rankings <- rbind(valid$rankings, valid$rankings[1, ]) + missing <- valid + missing$rankings <- valid$rankings[-1, ] + extra <- valid + extra_row <- valid$rankings[1, ] + extra_row$Model_ID <- "extra" + extra$rankings <- rbind(valid$rankings, extra_row) + missing_column <- valid + missing_column$rankings$Risk <- NULL + multiple <- valid + multiple$selected_id <- c("accurate", "safe") + unknown <- valid + unknown$selected_id <- "unknown" + series <- fixture$context + series$history <- fixture$history + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) + for (invalid in list(duplicate, missing, extra, missing_column, multiple, unknown)) { + expect_error(select_series_forecasts(predictions, series, series$train_test_split, + selector = function(...) invalid), "invalid selection contract") + } + invalid <- valid + invalid$rankings$Eligible[invalid$rankings$Model_ID == invalid$selected_id] <- FALSE + expect_error(select_series_forecasts(predictions, series, series$train_test_split, + selector = function(...) invalid), "ineligible candidate") + reordered <- valid + reordered$rankings <- reordered$rankings[2:1, ] + reordered$rankings$Seasonal_Fidelity <- NULL + expect_identical(select_series_forecasts(predictions, series, series$train_test_split, + selector = function(...) reordered), reordered) +}) + +test_that("seasonal evidence thresholds preserve assessed and unassessed states", { + local_corner_test_safety() + profile <- 10 * cos(2 * pi * (seq_len(12) - 0.5) / 12) + fixture <- make_selection_case(100 + rep(profile, 3), + futures = list(only = 100 + profile), errors = c(only = 0.03)) + reference <- forecast_reference(fixture$history, 12L, fixture$context) + for (strength in c(0.6 - 1e-7, 0.6, 0.6 + 1e-7)) { + controlled <- reference + controlled$seasonal_strength <- strength + risk <- forecast_path_risk(100 - profile, controlled) + expect_identical("seasonal_phase" %in% risk$reasons, strength >= 0.6) + expect_identical(is.finite(risk$seasonal_fidelity), strength >= 0.6) + } + for (period in c(2L, 3L)) { + pattern <- if (period == 2L) c(10, -10) else c(5, -10, 5) + fixture <- make_selection_case(100 + rep(pattern, 12), + futures = list(only = 100 - pattern), errors = c(only = 0.03), period = period) + controlled <- forecast_reference(fixture$history, period, fixture$context) + controlled$seasonal_strength <- 1 + risk <- forecast_path_risk(100 - pattern, controlled) + expect_identical("seasonal_phase" %in% risk$reasons, period >= 3L) + expect_identical(is.finite(risk$seasonal_fidelity), period >= 3L) + } + tolerance <- 0.2 * diff(range(reference$profile)) + reference$amplitude_tolerance <- tolerance + for (amplitude in c(0.8, 1, 1.2, 1.5)) { + risk <- forecast_path_risk(100 + amplitude * profile, reference) + expect_equal(risk$seasonal_fidelity, max(0, abs(amplitude - 1) - 0.2), tolerance = 1e-10) + } + reference$normalization <- 1 + reference$reference <- rep(100, 3) + reference$width <- 100 + reference$short_seasonality <- list(profile = c(1, 0, -1), trend = 0, + phase_noise = 2, amplitude_tolerance = 0.1) + for (amplitude in c(0.5, 1, 2)) { + risk <- forecast_path_risk(100 + amplitude * c(-1, 0, 1), reference) + expect_identical("seasonal_phase" %in% risk$reasons, amplitude > 1) + expect_identical(is.na(risk$components[["seasonality"]]), amplitude <= 1) + expect_true(is.finite(risk$seasonal_fidelity)) + } +}) + +test_that("seasonal comparisons align offset cutoffs and incomplete future cycles", { + local_corner_test_safety() + settings <- list(list(cadence = "day", period = 7L), list(cadence = "month", period = 12L), + list(cadence = "quarter", period = 4L)) + for (setting in settings) { + period <- setting$period + for (offset in c(1L, period - 1L)) { + history_size <- 3L * period + offset + history <- 100 + 10 * cos(2 * pi * (seq_len(history_size) - 0.5) / period) + for (horizon in c(period - 1L, period, period + 1L, 2L * period + 1L)) { + future <- 100 + 10 * cos(2 * pi * (history_size + seq_len(horizon) - 0.5) / period) + fixture <- make_selection_case(history, futures = list(intact = future, reversed = 200 - future), + errors = c(intact = 0.083, reversed = 0.08), date_type = setting$cadence) + result <- do.call(select_forecast_candidate, fixture) + intact <- result$rankings[result$rankings$Model_ID == "intact", ] + reversed <- result$rankings[result$rankings$Model_ID == "reversed", ] + expect_identical(result$selected_id, "intact", info = paste(setting$cadence, offset, horizon)) + expect_true(all(result$rankings$Eligible)) + expect_true(all(is.finite(result$rankings$Risk) & result$rankings$Risk >= 0)) + expect_true(all(is.finite(result$rankings$Seasonal_Fidelity) & result$rankings$Seasonal_Fidelity >= 0)) + expect_false("seasonal_phase" %in% intact$Reasons[[1]]) + expect_true("seasonal_phase" %in% reversed$Reasons[[1]]) + } + } + } +}) + +test_that("weekly invalid values stay within their complete forecast key", { + local_corner_test_safety() + dates <- as.Date("2026-01-01") + c(0, 7) + native <- expand.grid(Combo = c("A", "B"), Model_ID = c("arima", "ets"), Train_Test_ID = 1:2, + Date = dates, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE) + native$Forecast <- 7 * seq_len(nrow(native)) + native$Target <- ifelse(native$Train_Test_ID == 1L, NA_real_, native$Forecast + 7) + expanded <- native[rep(seq_len(nrow(native)), each = 7L), ] + expanded$Date_Day <- expanded$Date + rep(0:6, nrow(native)) + expanded$Forecast <- expanded$Forecast / 7 + expanded$Target <- expanded$Target / 7 + keys <- c("Combo", "Model_ID", "Train_Test_ID", "Date") + for (combo in c("A", "B")) { + altered <- expanded + group <- altered$Combo == combo & altered$Model_ID == "arima" & + altered$Train_Test_ID == 2L & altered$Date == dates[2] + altered$Forecast[group & altered$Date_Day == dates[2] + 1] <- Inf + altered$Forecast[group & altered$Date_Day == dates[2] + 5] <- -Inf + expected <- native + invalid <- expected$Combo == combo & expected$Model_ID == "arima" & + expected$Train_Test_ID == 2L & expected$Date == dates[2] + expected$Forecast[invalid] <- NaN + expected <- dplyr::arrange(tibble::as_tibble(expected), Combo, Model_ID, Train_Test_ID, Date) + for (reverse in c(FALSE, TRUE)) { + rows <- if (reverse) altered[rev(seq_len(nrow(altered))), ] else altered + result <- native_forecast_rows(rows, "week") + expect_equal(nrow(result), nrow(native)) + expect_false(anyDuplicated(result[, keys]) > 0) + expect_equal(sum(!is.finite(result$Forecast)), 1L) + expect_equal(dplyr::arrange(tibble::as_tibble(result), Combo, Model_ID, Train_Test_ID, Date), expected) + } + } +}) + +test_that("bounded generated cases preserve selection invariants", { + local_corner_test_safety() + withr::local_seed(20260905) + cadences <- c("day", "week", "month", "quarter", "year") + for (case_index in seq_len(48L)) { + cadence <- cadences[(case_index - 1L) %% length(cadences) + 1L] + period <- switch(cadence, day = 7L, week = 52L, month = 12L, quarter = 4L, year = 1L) + history_size <- sample(12:72, 1) + horizon <- sample(1:25, 1) + candidate_count <- (case_index - 1L) %% 4L + 1L + direction <- sample(c(-1, 1), 1) + slope <- sample(c(-0.1, 0, 0.1), 1) + positions <- seq_len(history_size) + actuals <- direction * (100 + slope * positions + 10 * sin(2 * pi * positions / period)) + positions <- history_size + seq_len(horizon) + continued <- direction * (100 + slope * positions + 10 * sin(2 * pi * positions / period)) + model_ids <- sprintf("candidate-%02d", seq_len(candidate_count)) + futures <- stats::setNames(list(continued, rep(stats::median(actuals), horizon), + 1.7 * continued, 100000 * continued)[seq_len(candidate_count)], model_ids) + errors <- stats::setNames(sample(seq(0.02, 0.18, by = 0.0005), candidate_count), model_ids) + fixture <- make_selection_case(actuals, futures, errors, date_type = cadence) + result <- do.call(select_forecast_candidate, fixture) + expect_true(result$selected_id %in% model_ids, info = paste("generated case", case_index)) + chosen <- result$rankings[result$rankings$Model_ID == result$selected_id, ] + expect_true(chosen$Eligible) + expected_accuracy <- vapply(model_ids, function(model_id) { + rows <- fixture$backtests[fixture$backtests$Model_ID == model_id, ] + truth <- fixture$history$Target[match(rows$Date, fixture$history$Date)] + sum(round(abs((rows$Forecast - truth) / abs(truth)), 4) * abs(truth)) / sum(abs(truth)) + }, numeric(1)) + expect_equal(result$rankings$WMAPE[match(model_ids, result$rankings$Model_ID)], + unname(expected_accuracy), tolerance = 1e-12) + eligible <- result$rankings[result$rankings$Eligible, ] + best <- min(eligible$WMAPE) + ceiling <- best + max(0.005, 0.05 * best) + expect_lte(chosen$WMAPE, ceiling + 8 * .Machine$double.eps) + finalists <- eligible[eligible$WMAPE <= ceiling + 8 * .Machine$double.eps, ] + finalists <- finalists[finalists$Risk == min(finalists$Risk), ] + finalists <- finalists[finalists$Violations == min(finalists$Violations), ] + if (all(is.finite(finalists$Seasonal_Fidelity) & finalists$Seasonal_Fidelity >= 0)) { + finalists <- finalists[finalists$Seasonal_Fidelity == min(finalists$Seasonal_Fidelity), ] + } + finalists <- finalists[finalists$WMAPE == min(finalists$WMAPE), ] + expect_identical(result$selected_id, sort(finalists$Model_ID, method = "radix")[1]) + + shuffled <- fixture + shuffled$history <- shuffled$history[sample.int(nrow(shuffled$history)), ] + for (table in c("backtests", "forecasts")) { + shuffled[[table]] <- shuffled[[table]][sample.int(nrow(shuffled[[table]])), ] + } + shuffled$context$candidate_ids <- sample(model_ids) + expect_identical(do.call(select_forecast_candidate, shuffled)$selected_id, result$selected_id) + + extra <- fixture + backtest <- fixture$backtests[fixture$backtests$Model_ID == model_ids[1], ] + future <- fixture$forecasts[fixture$forecasts$Model_ID == model_ids[1], ] + backtest$Model_ID <- "hard-invalid" + future$Model_ID <- "hard-invalid" + backtest$Forecast <- backtest$Target + future$Forecast[1] <- Inf + extra$backtests <- rbind(extra$backtests, backtest) + extra$forecasts <- rbind(extra$forecasts, future) + augmented <- do.call(select_forecast_candidate, extra) + expect_identical(augmented$selected_id, result$selected_id) + expect_false(augmented$rankings$Eligible[augmented$rankings$Model_ID == "hard-invalid"]) + + scaled <- fixture + unit_scale <- if (case_index %% 2L) 1e-50 else 1e50 + scaled$history$Target <- scaled$history$Target * unit_scale + for (table in c("backtests", "forecasts")) { + scaled[[table]]$Forecast <- scaled[[table]]$Forecast * unit_scale + scaled[[table]]$Target <- scaled[[table]]$Target * unit_scale + } + scaled$forecasts$Target <- -1e200 + expect_identical(do.call(select_forecast_candidate, scaled)$selected_id, result$selected_id) + } +}) \ No newline at end of file diff --git a/tests/testthat/test-forecast-selection-trend.R b/tests/testthat/test-forecast-selection-trend.R new file mode 100644 index 00000000..6dc6de04 --- /dev/null +++ b/tests/testthat/test-forecast-selection-trend.R @@ -0,0 +1,393 @@ +test_that("supported compounding keeps its quality and eligibility over long horizons", { + actuals <- 100 * 1.25^(0:11) + for (forecast_horizon in c(16L, 24L)) { + expected <- utils::tail(actuals, 1) * 1.25^seq_len(forecast_horizon) + fixture <- make_selection_case( + actuals = actuals, + futures = list(growth = expected, flat = rep(utils::tail(actuals, 1), forecast_horizon)), + errors = c(growth = 0.01, flat = 0.013), date_type = "year" + ) + original <- fixture + selection <- do.call(select_forecast_candidate, fixture) + growth <- selection$rankings[selection$rankings$Model_ID == "growth", ] + + expect_true(growth$Eligible, info = paste("horizon", forecast_horizon)) + expect_equal(growth$Checks[[1]][["level"]], 0, tolerance = 1e-10) + expect_equal(growth$Checks[[1]][["trend"]], 0, tolerance = 1e-10) + expect_identical(selection$selected_id, "growth") + expect_identical(fixture, original) + } +}) + +test_that("multi-year additive and proportional paths retain supported seasonality", { + for (date_type in c("month", "quarter")) { + period <- if (date_type == "month") 12L else 4L + history_size <- 5L * period + for (forecast_horizon in period * 1:3) { + for (mode in c("additive", "log")) { + positions <- seq_len(history_size + forecast_horizon) + seasonal <- cos(2 * pi * (positions - 0.5) / period) + values <- if (mode == "additive") { + 100 + 2 * positions + 10 * seasonal + } else 100 * exp(0.04 * positions + 0.1 * seasonal) + actuals <- values[seq_len(history_size)] + expected <- utils::tail(values, forecast_horizon) + fixture <- make_selection_case(actuals, + futures = list(growth = expected, flat = rep(utils::tail(actuals, 1), forecast_horizon)), + errors = c(growth = 0.01, flat = 0.013), date_type = date_type) + reference <- forecast_reference(fixture$history, forecast_horizon, fixture$context) + selection <- do.call(select_forecast_candidate, fixture) + growth <- selection$rankings[selection$rankings$Model_ID == "growth", ] + + expect_identical(reference$trend$mode, mode) + expect_equal(reference$trend$projection, if (mode == "log") { + log(expected) - log(max(actuals)) + } else expected / max(actuals), tolerance = 1e-10) + expect_true(growth$Eligible) + expect_equal(growth$Checks[[1]][["level"]], 0, tolerance = 1e-10) + expect_equal(growth$Checks[[1]][["trend"]], 0, tolerance = 1e-10) + expect_identical(selection$selected_id, "growth") + } + } + } +}) + +test_that("supported seasonal phases align at offset cutoffs and partial horizons", { + detrended_profile <- function(pattern) { + centered_time <- seq_along(pattern) - mean(seq_along(pattern)) + residual <- pattern - mean(pattern) - + centered_time * sum(centered_time * pattern) / sum(centered_time^2) + phases <- rep(seq_len(12), length.out = length(pattern)) + vapply(seq_len(12), function(phase) stats::median(residual[phases == phase]), numeric(1)) + } + for (mode in c("additive", "log")) { + for (forecast_horizon in c(3L, 12L, 24L)) { + history_size <- 50L + positions <- seq_len(history_size + forecast_horizon) + seasonal <- cos(2 * pi * (positions - 0.5) / 12) + values <- if (mode == "additive") { + 100 + positions + 20 * seasonal + } else 100 * exp(0.02 * positions + 0.2 * seasonal) + future_positions <- history_size + seq_len(forecast_horizon) + reversed <- if (mode == "additive") { + 100 + future_positions - 20 * seasonal[future_positions] + } else 100 * exp(0.02 * future_positions - 0.2 * seasonal[future_positions]) + fixture <- make_selection_case(values[seq_len(history_size)], + futures = list(intact = utils::tail(values, forecast_horizon), reversed = reversed), + errors = c(intact = 0.013, reversed = 0.01)) + selection <- do.call(select_forecast_candidate, fixture) + intact <- selection$rankings[selection$rankings$Model_ID == "intact", ] + reversed_score <- selection$rankings[selection$rankings$Model_ID == "reversed", ] + expected_fidelity <- 0 + if (forecast_horizon >= 12) { + window_size <- min(history_size, max(36, 2 * forecast_horizon)) + complete_size <- 12 * floor(window_size / 12) + historical_amplitude <- diff(range(detrended_profile( + utils::tail(seasonal[seq_len(history_size)], complete_size)))) + future_amplitude <- diff(range(detrended_profile(seasonal[future_positions]))) + expected_fidelity <- max(0, abs(future_amplitude - historical_amplitude) / + historical_amplitude - 0.05) + } + + expect_true(intact$Eligible) + expect_equal(intact$Checks[[1]][["level"]], 0, tolerance = 1e-10) + expect_equal(intact$Seasonal_Fidelity, expected_fidelity, tolerance = 1e-10) + expect_true("seasonal_phase" %in% reversed_score$Reasons[[1]]) + expect_identical(selection$selected_id, "intact") + } + } +}) + +test_that("unsupported trend evidence retains legacy reference scoring", { + actuals <- 100 + seq_len(48) + base <- make_selection_case(actuals, futures = list(only = 149:160), errors = c(only = 0.03)) + fixtures <- list( + flat = make_selection_case(rep(100, 48)), + two_cycles = make_selection_case(101:124), + zero = make_selection_case(rep(0, 48)), + recent_step = make_selection_case(c(rep(100, 40), rep(200, 8))), + unstable = make_selection_case(100 + rep(c(0, 2, -3, 1), 12)), + irregular = base, missing = base, nonfinite = base, + unobserved = base, unknown_observed = base + ) + fixtures$irregular$history$Date[20] <- fixtures$irregular$history$Date[20] + 1 + fixtures$missing$history$Target[20] <- NA_real_ + fixtures$nonfinite$history$Target[20] <- Inf + fixtures$unobserved$history$Observed <- TRUE + fixtures$unobserved$history$Observed[20] <- FALSE + fixtures$unknown_observed$history$Observed <- TRUE + fixtures$unknown_observed$history$Observed[20] <- NA + + for (fixture in fixtures) { + horizon <- length(unique(fixture$forecasts$Date)) + reference <- forecast_reference(fixture$history, horizon, fixture$context) + expect_null(reference$trend) + legacy <- reference + legacy$trend <- NULL + candidate <- fixture$forecasts$Forecast[fixture$forecasts$Model_ID == fixture$forecasts$Model_ID[1]] + expect_identical(forecast_path_risk(candidate, reference), forecast_path_risk(candidate, legacy)) + } +}) + +test_that("signed histories and nonpositive log forecasts remain finite and unclipped", { + for (actuals in list(-100 - seq_len(36), seq(-0.02, 0.015, length.out = 36))) { + expected <- utils::tail(actuals, 1) + stats::median(diff(actuals)) * 1:12 + fixture <- make_selection_case(actuals, + futures = list(only = expected), errors = c(only = 0.03), date_type = "year") + reference <- forecast_reference(fixture$history, 12, fixture$context) + expect_identical(reference$trend$mode, "additive") + expect_equal(forecast_path_risk(expected, reference)$components[["level"]], 0) + } + actuals <- 100 * 1.1^(0:35) + for (invalid_value in c(0, -1)) { + fixture <- make_selection_case(actuals, + futures = list(only = c(invalid_value, utils::tail(actuals, 1) * 1.1^(2:12))), + errors = c(only = 0.03), date_type = "year") + original <- fixture$forecasts + expect_warning(selection <- do.call(select_forecast_candidate, fixture), NA) + expect_true(selection$rankings$Eligible) + expect_true("level_deviation" %in% selection$rankings$Reasons[[1]]) + expect_gte(selection$rankings$Risk, 1) + expect_true(is.na(selection$rankings$Checks[[1]][["trend"]])) + expect_true(is.na(selection$rankings$Seasonal_Fidelity)) + expect_identical(fixture$forecasts, original) + } +}) + +test_that("supported future magnitude bounds retain exact backtest protection", { + actuals <- 100 * 1.25^(0:11) + expected <- utils::tail(actuals, 1) * 1.25^(1:24) + fixture <- make_selection_case(actuals, + futures = list(growth = expected, safe = rep(utils::tail(actuals, 1), 24)), + errors = c(growth = 0.01, safe = 0.013), date_type = "year") + for (direction in c(-1, 1)) { + for (multiple in c(100 - 1e-7, 100, 100 + 1e-7)) { + altered <- fixture + index <- utils::tail(which(altered$forecasts$Model_ID == "growth"), 1) + altered$forecasts$Forecast[index] <- direction * multiple * utils::tail(expected, 1) + result <- do.call(select_forecast_candidate, altered) + score <- result$rankings[result$rankings$Model_ID == "growth", ] + expect_identical(score$Eligible, multiple <= 100) + expect_identical("catastrophic_magnitude" %in% score$Reasons[[1]], multiple > 100) + } + } + historical_scale <- max(as.numeric(stats::quantile(abs(actuals), 0.95)), + stats::mad(actuals), stats::mad(diff(actuals))) + fixture$backtests$Forecast[fixture$backtests$Model_ID == "growth"] <- 101 * historical_scale + result <- do.call(select_forecast_candidate, fixture) + expect_false(result$rankings$Eligible[result$rankings$Model_ID == "growth"]) + expect_true("catastrophic_magnitude" %in% + result$rankings$Reasons[[which(result$rankings$Model_ID == "growth")]]) +}) + +test_that("invalid trend projections fall back without numerical warnings", { + fixture <- make_selection_case(100 * 10^(0:11), + futures = list(only = rep(1, 400)), errors = c(only = 0.03), date_type = "year") + expect_warning(reference <- forecast_reference(fixture$history, 400, fixture$context), NA) + expect_null(reference$trend) + decreasing <- make_selection_case(100 * 0.5^(0:11), + futures = list(only = rep(1, 2000)), errors = c(only = 0.03), date_type = "year") + expect_warning(reference <- forecast_reference(decreasing$history, 2000, decreasing$context), NA) + expect_null(reference$trend) +}) + +test_that("reference fitting and uncertainty follow independent drift formulas", { + actuals <- 100 + seq_len(36) + fixture <- make_selection_case(actuals, + futures = list(only = 137:148), errors = c(only = 0.03), date_type = "year") + reference <- forecast_reference(fixture$history, 12, fixture$context) + expected_scale <- as.numeric(stats::quantile(utils::tail(actuals, 24) / 136, 0.95)) + expect_identical(reference$trend$mode, "additive") + expect_equal(reference$trend$drift, 1 / 136, tolerance = 1e-12) + expect_equal(reference$trend$projection, (137:148) / 136, tolerance = 1e-12) + expect_equal(reference$trend$widths, 6 * 0.05 * expected_scale * sqrt(1:12), + tolerance = 1e-12) + + actuals <- 100 * 1.1^(0:35) + fixture <- make_selection_case(actuals, + futures = list(only = utils::tail(actuals, 1) * 1.1^(1:12)), + errors = c(only = 0.03), date_type = "year") + reference <- forecast_reference(fixture$history, 12, fixture$context) + expect_identical(reference$trend$mode, "log") + expect_equal(reference$trend$drift, log(1.1), tolerance = 1e-12) + expect_equal(reference$trend$projection, log(1.1) * 1:12, tolerance = 1e-12) + expect_equal(reference$trend$widths, 6 * log1p(0.05) * sqrt(1:12), tolerance = 1e-12) +}) + +test_that("both chronological blocks must support the proposed drift", { + original_fit <- forecast_trend_fit + for (error_fraction in c(0.79, 0.81)) { + local({ + captured_fraction <- error_fraction + calls <- list() + local_mocked_bindings(forecast_trend_fit = function(values, period, horizon) { + calls[[length(calls) + 1L]] <<- values + if (any(values < 0)) return(NULL) + result <- original_fit(values, period, horizon) + if (!is.null(result) && length(values) < 12) { + result$projection <- result$projection + captured_fraction * 2.5 / 256 + } + result + }) + fixture <- make_selection_case(245:256, + futures = list(only = 257:260), errors = c(only = 0.03), date_type = "year") + reference <- forecast_reference(fixture$history, 4, fixture$context) + expect_identical(!is.null(reference$trend), captured_fraction < 0.8) + additive_calls <- calls[vapply(calls, function(values) all(values > 0), logical(1))] + expect_equal(vapply(additive_calls, length, integer(1)), c(12L, 10L, 11L)) + for (values in additive_calls) { + expect_equal(values, (245:256)[seq_along(values)] / 256) + } + }) + } +}) + +test_that("trend scoring detects immediate and delayed unsupported growth", { + actuals <- 100 * exp(0.04 * seq_len(48)) + expected <- utils::tail(actuals, 1) * exp(0.04 * seq_len(24)) + immediate <- expected + immediate[1] <- 20 * immediate[1] + delayed <- expected * exp(c(rep(0, 12), 0.3 * seq_len(12))) + fixture <- make_selection_case(actuals, + futures = list(intact = expected, immediate = immediate, delayed = delayed), + errors = c(intact = 0.013, immediate = 0.01, delayed = 0.011)) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "intact") + for (candidate in c("immediate", "delayed")) { + score <- result$rankings[result$rankings$Model_ID == candidate, ] + expect_true(score$Risk > 0 || !score$Eligible) + expect_true(any(c("level_deviation", "trend_deviation", "catastrophic_magnitude") %in% + score$Reasons[[1]])) + } + spike <- make_selection_case(c(rep(100, 35), 400), + futures = list(returning = rep(100, 6), persistent = rep(400, 6)), + errors = c(returning = 0.01, persistent = 0.013), date_type = "year") + expect_identical(do.call(select_forecast_candidate, spike)$selected_id, "returning") +}) + +test_that("trend support is independent of units order and future values", { + actuals <- 100 * exp(0.04 * seq_len(48)) + expected <- utils::tail(actuals, 1) * exp(0.04 * seq_len(24)) + fixture <- make_selection_case(actuals, + futures = list(growth = expected, flat = rep(utils::tail(actuals, 1), 24)), + errors = c(growth = 0.01, flat = 0.013)) + baseline <- do.call(select_forecast_candidate, fixture) + reference <- prepare_forecast_evaluation(fixture$history, fixture$context)$reference + for (unit_scale in c(1e-100, 1e100)) { + altered <- fixture + altered$history$Target <- altered$history$Target * unit_scale + for (table in c("forecasts", "backtests")) { + altered[[table]]$Forecast <- altered[[table]]$Forecast * unit_scale + altered[[table]]$Target <- altered[[table]]$Target * unit_scale + altered[[table]] <- altered[[table]][rev(seq_len(nrow(altered[[table]]))), ] + } + altered$history <- altered$history[rev(seq_len(nrow(altered$history))), ] + selected <- do.call(select_forecast_candidate, altered) + expect_identical(selected$selected_id, baseline$selected_id) + expect_equal(selected$rankings$Risk, baseline$rankings$Risk, tolerance = 1e-10) + expect_equal(selected$rankings$WMAPE, baseline$rankings$WMAPE, tolerance = 1e-10) + } + future_history <- data.frame(Date = unique(fixture$forecasts$Date), Target = 1e200) + altered_history <- rbind(fixture$history, future_history) + altered_context <- fixture$context + altered_context$candidate_ids <- c("unrelated", "candidate") + expect_identical(prepare_forecast_evaluation(altered_history, altered_context)$reference, reference) + altered <- fixture + altered$forecasts$Target <- 1e200 + expect_identical(do.call(select_forecast_candidate, altered), baseline) +}) + +test_that("cached trend references are reused regardless of candidate count", { + original_reference <- forecast_trend_reference + calls <- 0L + local_mocked_bindings(forecast_trend_reference = function(...) { + calls <<- calls + 1L + original_reference(...) + }) + actuals <- 100 + seq_len(48) + fixture <- make_selection_case(actuals, + futures = list(growth = 149:160, flat = rep(148, 12)), + errors = c(growth = 0.01, flat = 0.013)) + evaluation <- prepare_forecast_evaluation(fixture$history, fixture$context) + expect_identical(calls, 1L) + fixture$context$forecast_evaluation <- evaluation + first <- do.call(select_forecast_candidate, fixture) + expanded <- fixture + for (table in c("backtests", "forecasts")) { + copies <- expanded[[table]][expanded[[table]]$Model_ID == "growth", ] + copies$Model_ID <- "second_growth" + expanded[[table]] <- rbind(expanded[[table]], copies) + } + second <- do.call(select_forecast_candidate, expanded) + expect_identical(first$selected_id, second$selected_id) + expect_identical(calls, 1L) + expect_identical(fixture$context$forecast_evaluation, evaluation) +}) + +make_trend_selection_artifacts <- function(fixture) { + dates <- seq(as.Date("2020-01-01"), by = "month", length.out = 60) + values <- 100 * exp(0.1 * seq_along(dates)) + history <- data.frame(Combo = "Synthetic", Date = dates, + Target = c(values[1:48], rep(NA_real_, 12))) + write_data(history, combo = "Synthetic", run_info = fixture$run_info, + output_type = "data", folder = "prep_data", suffix = "-R1") + rows <- fixture$forecasts + rows$Target <- ifelse(rows$Train_Test_ID == 1, NA_real_, values[match(rows$Date, dates)]) + errors <- c(arima = 0.01, meanf = 0.013, snaive = 0.014, ets = 0.005) + rows$Forecast <- rows$Target * (1 + errors[rows$Model_Name]) + future <- rows$Train_Test_ID == 1 + rows$Forecast[future] <- values[match(rows$Date[future], dates)] + rows$Forecast[future & rows$Model_Name == "meanf"] <- values[48] + rows$Forecast[future & rows$Model_Name == "snaive"] <- 1.02 * rows$Forecast[future & rows$Model_Name == "snaive"] + rows$Forecast[future & rows$Model_Name == "ets"] <- 1000 * rows$Forecast[future & rows$Model_Name == "ets"] + write_data(rows, combo = "Synthetic", run_info = fixture$run_info, + output_type = "data", folder = "forecasts", suffix = "-single_models") + fixture$forecasts <- rows + fixture +} + +test_that("final_models uses trend scores without changing constituent predictions", { + evaluations <- list() + original_selector <- select_series_forecasts + local_mocked_bindings( + par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }, + select_series_forecasts = function(predictions, ...) { + evaluations[[length(evaluations) + 1L]] <<- predictions + original_selector(predictions, ...) + } + ) + catalogue <- data.frame(Model_Name = c("arima", "meanf", "snaive", "ets"), + Model_Type = "local", Recipe_ID = "R1") + catalogue$Model_ID <- paste(catalogue$Model_Name, "local", "R1", sep = "--") + fixture <- make_catalogue_selection_fixture("trend", catalogue) + fixture <- make_trend_selection_artifacts(fixture) + result <- final_models(fixture$run_info, average_models = TRUE, max_model_average = 3, + weekly_to_daily = FALSE, num_cores = 1) + rankings <- result$selections$Synthetic$rankings + expect_length(evaluations, 2L) + expect_equal(nrow(rankings), 7L) + expect_identical(result$selections$Synthetic$selected_id, "arima--local--R1") + average_ids <- rankings$Model_ID[grepl("_", rankings$Model_ID, fixed = TRUE)] + expect_length(average_ids, 4L) + expect_false(any(grepl("ets--local--R1", average_ids, fixed = TRUE))) + for (model_id in average_ids) { + members <- strsplit(model_id, "_", fixed = TRUE)[[1]] + components <- lapply(members, function(member) { + rows <- fixture$forecasts[fixture$forecasts$Model_ID == member, ] + rows[order(rows$Train_Test_ID, rows$Date), ] + }) + measured <- evaluations[[2]][evaluations[[2]]$Model_ID == model_id, ] + measured <- measured[order(measured$Train_Test_ID, measured$Date), ] + expected <- Reduce(`+`, lapply(components, `[[`, "Forecast")) / length(components) + expect_equal(measured$Forecast, expected, tolerance = 1e-10) + } + retained <- read_fcst_file(locate_single_models_file(fixture$run_info)) + key <- function(rows) paste(rows$Model_ID, rows$Train_Test_ID, rows$Date) + expect_equal(retained$Forecast[match(key(fixture$forecasts), key(retained))], + fixture$forecasts$Forecast, tolerance = 1e-10) + expect_identical(unique(retained$Model_ID[retained$Best_Model == "Yes"]), "arima--local--R1") + saved_average <- read_selection_file(fixture$run_info, "forecasts", "-average_models", "Synthetic") + expect_true(all(saved_average$Best_Model == "No")) +}) \ No newline at end of file diff --git a/tests/testthat/test-forecast-selection.R b/tests/testthat/test-forecast-selection.R new file mode 100644 index 00000000..8edb40a3 --- /dev/null +++ b/tests/testthat/test-forecast-selection.R @@ -0,0 +1,709 @@ +test_that("final_models rejects an explosive accuracy winner and its averages", { + local_mocked_bindings( + par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + } + ) + run_info <- make_best_models_fixture() + forecast_path <- locate_single_models_file(run_info) + predictions <- read_fcst_file(forecast_path) %>% + dplyr::mutate( + Forecast = dplyr::case_when( + Train_Test_ID == 1 & Model_Name == "meanf" ~ 100000 * (100 + Horizon), + Train_Test_ID == 1 ~ 100 + Horizon, + Model_Name == "meanf" ~ Target * 1.01, + TRUE ~ Target * 1.08 + ) + ) + write_fcst_file(predictions, forecast_path) + + final_models(run_info, average_models = TRUE) + + forecasts <- get_forecast_data(run_info) + selected <- forecasts %>% dplyr::filter(Best_Model == "Yes") + expect_identical(unique(selected$Model_ID), "snaive--local--R1") + expect_true(all(selected$Forecast[selected$Run_Type == "Future_Forecast"] < 1000)) + rejected <- forecasts %>% dplyr::filter(Model_Name == "meanf") + expect_gt(nrow(rejected), 0) + expect_true(all(rejected$Best_Model == "No")) +}) + +test_that("the saved nonwinning average uses forecast quality as well as accuracy", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + run_info <- make_best_models_fixture() + forecast_path <- locate_single_models_file(run_info) + template <- read_fcst_file(forecast_path) %>% dplyr::filter(Model_Name == "meanf") + models <- c("meanf", "snaive", "naive") + errors <- c(0.01, 0.012, 0.014) + predictions <- dplyr::bind_rows(lapply(seq_along(models), function(model_index) { + template %>% dplyr::mutate( + Model_Name = models[model_index], + Model_ID = paste(Model_Name, Model_Type, Recipe_ID, sep = "--"), + Forecast = ifelse(Train_Test_ID == 1, + (100 + Horizon) * ifelse(Model_Name == "snaive", 3, 1), + Target * (1 + errors[model_index])) + ) + })) + write_fcst_file(predictions, forecast_path) + + final_models(run_info, average_models = TRUE) + + average <- read_selection_file(run_info, "forecasts", "-average_models", "Synthetic") + individuals <- read_fcst_file(forecast_path) + expect_identical(unique(individuals$Model_ID[individuals$Best_Model == "Yes"]), "meanf--local--R1") + expect_setequal(strsplit(unique(average$Model_ID), "_", fixed = TRUE)[[1]], + c("meanf--local--R1", "naive--local--R1")) + expect_true(all(average$Best_Model == "No")) + expect_equal(average$Forecast[average$Train_Test_ID == 1], 101:103) +}) + +test_that("sliding historical trend medians preserve direct-window risk scores", { + original_runmed <- stats::runmed + lapply(c(4L, 5L, 6L, 11L, 12L, 24L), function(horizon) { + expect_identical(stats::runmed, original_runmed) + actuals <- 100 + seq_len(48) + 4 * sin(seq_len(48)) + fixture <- make_selection_case(actuals = actuals, + futures = list(only = rep(150, horizon)), errors = c(only = 0.03)) + expected <- do.call(select_forecast_candidate, fixture) + reference <- forecast_reference(fixture$history, horizon, fixture$context) + values <- reference$values + forecast <- fixture$forecasts$Forecast / reference$normalization + if (is.finite(reference$seasonal_strength) && reference$seasonal_strength >= 0.6) { + phases <- ((seq_along(values) - length(values) - 1) %% reference$period) + 1 + values <- values - reference$profile[phases] + forecast <- forecast - rep(reference$profile, length.out = horizon) + } + slopes <- vapply(seq_len(length(values) - horizon + 1L), function(start) { + stats::median(diff(values[seq.int(start, length.out = horizon)])) + }, numeric(1)) + slope_scale <- max(stats::mad(slopes), 0.05 * reference$scale / horizon) + direct_risk <- max(0, abs(stats::median(diff(forecast)) - stats::median(slopes)) / + (6 * slope_scale) - 1) + expect_equal(expected$rankings$Checks[[1]][["trend"]], direct_risk, tolerance = 1e-12) + reference_calls <- 0L + local_mocked_bindings(runmed = function(values, k, ...) { + reference_calls <<- reference_calls + 1L + half <- (k - 1L) / 2L + result <- rep(NA_real_, length(values)) + positions <- seq.int(half + 1L, length(values) - half) + result[positions] <- vapply(positions, function(position) { + stats::median(values[seq.int(position - half, position + half)]) + }, numeric(1)) + result + }, .package = "stats") + expect_equal(do.call(select_forecast_candidate, fixture), expected, tolerance = 1e-12) + expect_identical(reference_calls, as.integer(horizon %% 2L == 0L)) + }) + expect_identical(stats::runmed, original_runmed) +}) + +test_that("catalogue benchmark covers supported recipes and every pair and triple", { + evaluated <- list() + original_selector <- select_series_forecasts + local_mocked_bindings( + par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }, + select_series_forecasts = function(predictions, ...) { + evaluated[[length(evaluated) + 1L]] <<- predictions + original_selector(predictions, ...) + } + ) + catalogue <- selection_benchmark_catalogue() + expect_equal(nrow(catalogue), 41L) + expect_false(anyDuplicated(catalogue$Model_ID) > 0) + expect_setequal(catalogue$Model_Name[catalogue$Recipe_ID == "R2"], list_r2_models()) + expect_equal(choose(nrow(catalogue), 2) + choose(nrow(catalogue), 3), 11480) + category <- ifelse(catalogue$Recipe_ID == "ensemble", "ensemble", + ifelse(catalogue$Model_Type == "global", "global", catalogue$Recipe_ID)) + small_catalogue <- catalogue[match(c("R1", "R2", "global", "ensemble"), category), ] + expect_equal(nrow(small_catalogue), 4L) + expect_false(anyNA(small_catalogue$Model_ID)) + fixture <- make_catalogue_selection_fixture("smoke", small_catalogue, distinct_forecasts = TRUE) + result <- final_models(fixture$run_info, average_models = TRUE, max_model_average = 3, + weekly_to_daily = FALSE, parallel_processing = NULL, inner_parallel = FALSE, num_cores = 1) + rankings <- result$selections$Synthetic$rankings + expect_length(evaluated, 2L) + expect_equal(nrow(rankings), 4 + choose(4, 2) + choose(4, 3)) + expect_true(all(rankings$Eligible)) + model_ids <- sort(small_catalogue$Model_ID) + combinations <- c(utils::combn(model_ids, 2, simplify = FALSE), utils::combn(model_ids, 3, simplify = FALSE)) + average_ids <- vapply(combinations, paste, character(1), collapse = "_") + expect_setequal(rankings$Model_ID, c(model_ids, average_ids)) + expect_setequal(unique(evaluated[[2]]$Model_ID), c(model_ids, average_ids)) + direct_averages <- stats::setNames(lapply(seq_along(combinations), function(index) { + components <- lapply(combinations[[index]], function(model_id) { + rows <- fixture$forecasts[fixture$forecasts$Model_ID == model_id, ] + rows[order(rows$Train_Test_ID, rows$Date), ] + }) + measured <- evaluated[[2]][evaluated[[2]]$Model_ID == average_ids[index], ] + measured <- measured[order(measured$Train_Test_ID, measured$Date), ] + expected <- Reduce(`+`, lapply(components, `[[`, "Forecast")) / length(components) + expect_equal(measured$Train_Test_ID, components[[1]]$Train_Test_ID) + expect_equal(measured$Date, components[[1]]$Date) + expect_equal(measured$Forecast, expected, tolerance = 1e-10) + expected + }), average_ids) + average <- read_selection_file(fixture$run_info, "forecasts", "-average_models", "Synthetic") + expect_equal(average$Forecast[order(average$Train_Test_ID, average$Date)], + direct_averages[[unique(average$Model_ID)]], tolerance = 1e-10) + expect_true(all(average$Best_Model == "No")) +}) + +test_that("prepared history restores original actuals from R1 and R2", { + actuals <- 100 + seq_len(36) + 5 * sin(seq_len(36)) + actuals[15] <- 400 + cleaned <- actuals + cleaned[15] <- 115 + for (recipe in c("R1", "R2")) { + for (difference_order in 0:2) { + for (box_cox in c(FALSE, TRUE)) { + fixture <- make_selection_history_recipe( + actuals, cleaned, difference_order, box_cox, recipe + ) + reconstructed <- normalize_series_history( + fixture$data, fixture$hist_end_date, recipe, + fixture$combo_info, stationary = difference_order > 0, + box_cox = box_cox + ) + expect_equal(reconstructed$history, fixture$expected, + tolerance = 1e-7, + info = paste(recipe, difference_order, box_cox) + ) + } + } + } +}) + +test_that("history uses Target only when Target_Original is absent", { + fixture <- make_selection_history_recipe(101:124) + fixture$data$Target_Original[4] <- NA_real_ + original <- normalize_series_history(fixture$data, fixture$hist_end_date) + expect_true(is.na(original$history$Target[4])) + fixture$data$Target_Original <- NULL + fallback <- normalize_series_history(fixture$data, fixture$hist_end_date) + expect_equal(fallback$history$Target, 101:124) +}) + +test_that("history reconstruction preserves the second original value after cleaning", { + actuals <- as.numeric(101:136) + actuals[2] <- 300 + cleaned <- actuals + cleaned[2] <- 102 + fixture <- make_selection_history_recipe(actuals, cleaned, difference_order = 2) + reconstructed <- normalize_series_history( + fixture$data, fixture$hist_end_date, "R1", + fixture$combo_info, stationary = TRUE + ) + expect_equal(reconstructed$history, fixture$expected) +}) + +test_that("history normalization validates dates and R2 origins", { + fixture <- make_selection_history_recipe(101:112, recipe = "R2") + reversed <- fixture$data[rev(seq_len(nrow(fixture$data))), ] + expect_equal( + normalize_series_history(reversed, fixture$hist_end_date, "R2")$history, + fixture$expected + ) + duplicate <- dplyr::bind_rows(fixture$data, fixture$data[1, ]) + expect_error(normalize_series_history(duplicate, fixture$hist_end_date, "R2"), "one observation per date") + fixture$data$Origin[2] <- 100 + expect_error(normalize_series_history(fixture$data, fixture$hist_end_date, "R2"), "inconsistent") +}) + +test_that("history reads exact artifacts once and never lists directories", { + run_info <- make_best_models_fixture() + exact_log <- file.path(run_info$path, "logs", paste0( + hash_data(run_info$project_name), "-", hash_data(run_info$run_name), ".csv" + )) + run_log <- read_file(run_info, file_list = exact_log) + original_reader <- read_file + reads <- character() + local_mocked_bindings( + list_files = function(...) stop("Directory listing is forbidden"), + read_file = function(run_info, path = NULL, file_list = NULL, ...) { + expect_null(path) + expect_length(file_list, 1) + expect_false(grepl("*", file_list, fixed = TRUE)) + reads <<- c(reads, file_list) + original_reader(run_info, file_list = file_list, ...) + } + ) + cache <- new.env(parent = emptyenv()) + first <- read_series_history(run_info, "Synthetic", run_log, cache) + second <- read_series_history(run_info, "Synthetic", run_log, cache) + expect_identical(first, second) + expect_length(reads, 1) + expect_match(reads, "-R1\\.csv$") +}) + +test_that("selection prefers a safer forecast inside the accuracy allowance", { + fixture <- make_selection_case() + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "safe") + expect_gt(result$rankings$Risk[result$rankings$Model_ID == "accurate"], 0) + fixture$backtests$Forecast[fixture$backtests$Model_ID == "safe"] <- 108.6 + expect_identical(do.call(select_forecast_candidate, fixture)$selected_id, "accurate") +}) + +test_that("the accuracy allowance uses absolute and relative limits", { + for (best_error in c(0, 0.02, 0.08, 0.20)) { + allowance <- max(0.005, best_error * 0.05) + fixture <- make_selection_case(errors = c(accurate = best_error, safe = best_error + allowance)) + expect_identical(do.call(select_forecast_candidate, fixture)$selected_id, "safe") + fixture$backtests$Forecast[fixture$backtests$Model_ID == "safe"] <- 100 * (1 + best_error + allowance + 0.001) + expect_identical(do.call(select_forecast_candidate, fixture)$selected_id, "accurate") + } +}) + +test_that("one and two seasonal cycles remain selectable", { + for (cycles in 1:2) { + seasonal <- rep(c(80, 90, 100, 110, 120, 130, 120, 110, 100, 90, 80, 70), cycles) + fixture <- make_selection_case( + actuals = seasonal, futures = list(seasonal = seasonal[1:12]), + errors = c(seasonal = 0.03) + ) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "seasonal") + expect_true(result$rankings$Eligible) + expect_equal(result$rankings$Violations, 0L) + } +}) + +test_that("strong repeated seasonal phase reversal receives a soft concern", { + profile <- 100 + 20 * sin(2 * pi * (1:12) / 12) + fixture <- make_selection_case( + actuals = rep(profile, 3), futures = list(reversed = 200 - profile, seasonal = profile), + errors = c(reversed = 0.04, seasonal = 0.043) + ) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "seasonal") + expect_true(all(result$rankings$Eligible)) + expect_true("seasonal_phase" %in% unlist(result$rankings$Reasons)) +}) + +test_that("seasonal amplitude preference distinguishes eligible near-accuracy candidates", { + profile <- cos(2 * pi * (seq_len(12) - 0.5) / 12) + fixture <- make_selection_case(100 + rep(10 * profile, 4), + futures = list(diluted = 100 + 5 * profile, intact = 100 + 10 * profile), + errors = c(diluted = 0.0815, intact = 0.083)) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "intact") + expect_true(all(result$rankings$Eligible)) + expect_true(all(result$rankings$Risk == 0)) + expect_true(all(result$rankings$Violations == 0L)) + expect_equal(result$rankings$Seasonal_Fidelity[match(c("diluted", "intact"), result$rankings$Model_ID)], + c(0.45, 0), tolerance = 1e-10) + for (unit_scale in c(1e-100, 1e100)) { + scaled <- fixture + scaled$history$Target <- scaled$history$Target * unit_scale + for (table in c("backtests", "forecasts")) { + scaled[[table]]$Forecast <- scaled[[table]]$Forecast * unit_scale + scaled[[table]]$Target <- scaled[[table]]$Target * unit_scale + scaled[[table]] <- scaled[[table]][rev(seq_len(nrow(scaled[[table]]))), ] + } + selected <- do.call(select_forecast_candidate, scaled) + expect_identical(selected$selected_id, result$selected_id) + expect_equal(selected$rankings$Seasonal_Fidelity, result$rankings$Seasonal_Fidelity, tolerance = 1e-10) + } +}) + +test_that("seasonal preference respects risk accuracy and unassessed ties", { + rankings <- tibble::tibble(Model_ID = c("accuracy", "seasonal"), Eligible = TRUE, + WMAPE = c(0.08, 0.083), Risk = 0, Violations = 0L, + Reasons = list(character(), character()), Seasonal_Fidelity = c(0.5, 0)) + expect_identical(rank_forecast_candidates(rankings)$selected_id, "seasonal") + rankings$Risk[2] <- 0.1 + expect_identical(rank_forecast_candidates(rankings)$selected_id, "accuracy") + rankings$Risk[2] <- 0 + rankings$Violations[2] <- 1L + expect_identical(rank_forecast_candidates(rankings)$selected_id, "accuracy") + rankings$Violations[2] <- 0L + rankings$WMAPE[2] <- 0.086 + expect_identical(rank_forecast_candidates(rankings)$selected_id, "accuracy") + rankings$WMAPE[2] <- 0.083 + rankings$Seasonal_Fidelity[1] <- NA_real_ + expect_identical(rank_forecast_candidates(rankings)$selected_id, "accuracy") + rankings$Seasonal_Fidelity <- c(0.5, NA_real_) + expect_identical(rank_forecast_candidates(rankings)$selected_id, "accuracy") + rankings$Seasonal_Fidelity <- NULL + expect_identical(rank_forecast_candidates(rankings)$selected_id, "accuracy") + rankings$Seasonal_Fidelity <- c(0, 0) + rankings$WMAPE <- c(0.08, 0.08) + expect_identical(rank_forecast_candidates(rankings[2:1, ])$selected_id, "accuracy") +}) + +test_that("historical amplitude variation permits continued seasonal damping", { + profile <- cos(2 * pi * (seq_len(12) - 0.5) / 12) + actuals <- 100 + unlist(lapply(c(20, 16, 12), function(amplitude) amplitude * profile)) + fixture <- make_selection_case(actuals, + futures = list(continued = 100 + 10 * profile, fixed = 100 + 16 * profile), + errors = c(continued = 0.08, fixed = 0.0801)) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "continued") + expect_true(all(result$rankings$Eligible)) + expect_true(all(result$rankings$Violations == 0L)) + expect_equal(result$rankings$Seasonal_Fidelity, c(0, 0), tolerance = 1e-10) +}) + +test_that("seasonal preference uses each cadence and the smallest configured period", { + settings <- list( + list(cadence = "day", period = 7L, configured = NULL), + list(cadence = "week", period = 52L, configured = NULL), + list(cadence = "month", period = 12L, configured = NULL), + list(cadence = "quarter", period = 4L, configured = NULL), + list(cadence = "week", period = 12L, configured = "52---12---24") + ) + for (setting in settings) { + profile <- cos(2 * pi * (seq_len(setting$period) - 0.5) / setting$period) + fixture <- make_selection_case(100 + rep(10 * profile, 3), + futures = list(diluted = 100 + 5 * profile, intact = 100 + 10 * profile), + errors = c(diluted = 0.08, intact = 0.083), date_type = setting$cadence, period = setting$configured) + expect_equal(forecast_seasonal_period(fixture$context), setting$period) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "intact") + expect_true(all(result$rankings$Eligible)) + expect_true(all(is.finite(result$rankings$Seasonal_Fidelity))) + } + fixture <- make_selection_case(date_type = "year") + expect_equal(forecast_seasonal_period(fixture$context), 1L) + expect_true(all(is.na(do.call(select_forecast_candidate, fixture)$rankings$Seasonal_Fidelity))) +}) + +test_that("short seasonal forecasts do not reward reversal or flat cancellation", { + profile <- cos(2 * pi * (seq_len(12) - 0.5) / 12) + fixture <- make_selection_case(100 + rep(10 * profile, 4), + futures = list(reversed = 100 - 10 * profile[1:3], cancelled = rep(100, 3), + intact = 100 + 10 * profile[1:3]), + errors = c(reversed = 0.08, cancelled = 0.0815, intact = 0.083)) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "intact") + expect_true(all(result$rankings$Eligible)) + reversed <- result$rankings[result$rankings$Model_ID == "reversed", ] + expect_gt(reversed$Risk, 0) + expect_true("seasonal_phase" %in% reversed$Reasons[[1]]) + expect_equal(result$rankings$Seasonal_Fidelity[match(c("cancelled", "intact"), result$rankings$Model_ID)], + c(0.95, 0), tolerance = 1e-10) + expect_equal(result$rankings$Violations[result$rankings$Model_ID == "cancelled"], 0L) +}) + +test_that("short seasonal assessment requires historical and phase evidence", { + profile <- cos(2 * pi * (seq_len(12) - 0.5) / 12) + for (setting in list(c(1L, 3L), c(4L, 1L), c(4L, 2L))) { + horizon <- setting[2] + fixture <- make_selection_case(100 + rep(10 * profile, setting[1]), + futures = list(reversed = 100 - 10 * profile[seq_len(horizon)], + intact = 100 + 10 * profile[seq_len(horizon)]), errors = c(reversed = 0.08, intact = 0.083)) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "reversed") + expect_true(all(result$rankings$Eligible)) + expect_true(all(is.na(result$rankings$Seasonal_Fidelity))) + expect_true(all(is.na(vapply(result$rankings$Checks, `[[`, numeric(1), "seasonality")))) + } + for (actuals in list(rep(100, 48), 100 + rep(c(0, 0, 0, 5, 10, 15, 15, 10, 5, 0, 0, 0), 4))) { + fixture <- make_selection_case(actuals, futures = list(only = rep(100, 3)), errors = c(only = 0.03)) + result <- do.call(select_forecast_candidate, fixture) + expect_true(result$rankings$Eligible) + expect_true(is.na(result$rankings$Seasonal_Fidelity)) + expect_true(is.na(result$rankings$Checks[[1]][["seasonality"]])) + } +}) + +test_that("short seasonal comparisons preserve a supported historical trend", { + profile <- cos(2 * pi * (seq_len(12) - 0.5) / 12) + fixture <- make_selection_case(100 + seq_len(48) + rep(10 * profile, 4), + futures = list(only = 100 + 49:51 + 10 * profile[1:3]), errors = c(only = 0.03)) + result <- do.call(select_forecast_candidate, fixture) + expect_true(result$rankings$Eligible) + expect_equal(result$rankings$Violations, 0L) + expect_equal(result$rankings$Seasonal_Fidelity, 0, tolerance = 1e-10) +}) + +test_that("nonfinite forecasts survive cleanup and cannot win", { + invalid <- c(Inf, -Inf, NaN, NA_real_) + input <- data.frame(Forecast = c(invalid, -3, 0, 2)) + for (allow_negative in c(FALSE, TRUE)) { + result <- negative_fcst_adj(input, allow_negative) + expect_identical(result$Forecast[1:4], invalid) + expect_equal(result$Forecast[5:7], c(if (allow_negative) -3 else 0, 0, 2)) + } + for (value in invalid) { + fixture <- make_selection_case() + fixture$forecasts$Forecast[1] <- value + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "safe") + expect_false(result$rankings$Eligible[result$rankings$Model_ID == "accurate"]) + } +}) + +test_that("invalid ensemble inputs cannot be hidden by missing-value filling", { + fixture <- make_selection_case() + fixture$forecasts$Forecast[1] <- NA_real_ + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) + context <- fixture$context + context$history <- fixture$history + screened <- screen_ensemble_inputs(predictions, context, context$train_test_split) + expect_identical(unique(screened$Model_ID), "safe") + expect_true(all(is.finite(screened$Forecast))) +}) + +test_that("hard-rejected extra keys do not change valid ensemble inputs", { + fixture <- make_selection_case( + futures = list(first = rep(100, 6), second = rep(100, 6), rejected = rep(100, 6)), + errors = c(first = 0.02, second = 0.03, rejected = 0.01) + ) + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) + context <- fixture$context + context$history <- fixture$history + control <- predictions[predictions$Model_ID != "rejected", , drop = FALSE] + expect_identical(screen_ensemble_inputs(control, context, context$train_test_split), control) + + for (split_id in c(1L, 2L)) { + extra <- predictions[which(predictions$Model_ID == "rejected" & + predictions$Train_Test_ID == split_id)[1], , drop = FALSE] + extra$Date <- max(predictions$Date[predictions$Train_Test_ID == split_id]) + 1 + damaged <- dplyr::bind_rows(predictions, extra) + selection <- select_series_forecasts(damaged, context, context$train_test_split) + expect_setequal(selection$rankings$Model_ID[selection$rankings$Eligible], c("first", "second")) + + for (reversed in c(FALSE, TRUE)) { + rows <- if (reversed) damaged[rev(seq_len(nrow(damaged))), , drop = FALSE] else damaged + expected <- rows[rows$Model_ID != "rejected", , drop = FALSE] + screened <- screen_ensemble_inputs(rows, context, context$train_test_split) + expect_identical(screened, expected, info = paste("split", split_id, "reversed", reversed)) + } + } +}) + +test_that("ensemble screening retains hard eligibility and empty-pool behavior", { + fixture <- make_selection_case() + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) + context <- fixture$context + context$history <- fixture$history + expect_identical(screen_ensemble_inputs(predictions, context, context$train_test_split), predictions) + + for (split_id in c(1L, 2L)) { + affected <- which(predictions$Model_ID == "accurate" & predictions$Train_Test_ID == split_id)[1] + for (defect in c("missing", "duplicate", "nonfinite")) { + rows <- predictions + if (defect == "missing") rows <- rows[-affected, , drop = FALSE] + if (defect == "duplicate") rows <- dplyr::bind_rows(rows, rows[affected, , drop = FALSE]) + if (defect == "nonfinite") rows$Forecast[affected] <- Inf + expect_identical(screen_ensemble_inputs(rows, context, context$train_test_split), + rows[rows$Model_ID == "safe", , drop = FALSE], info = paste("split", split_id, defect)) + } + } + + predictions$Forecast <- Inf + expect_identical(screen_ensemble_inputs(predictions, context, context$train_test_split), + predictions[0, , drop = FALSE]) +}) + +test_that("ensemble screening preserves validation rows and checks their coverage", { + fixture <- make_selection_case() + context <- fixture$context + context$history <- fixture$history + validation_split <- context$train_test_split[2, , drop = FALSE] + validation_split$Train_Test_ID <- 3L + validation_split$Run_Type <- "Validation" + splits <- dplyr::bind_rows(context$train_test_split, validation_split) + validation <- fixture$backtests + validation$Train_Test_ID <- 3L + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts, validation) + expect_identical(screen_ensemble_inputs(predictions, context, splits), predictions) + + affected <- which(predictions$Model_ID == "accurate" & predictions$Train_Test_ID == 3L)[1] + for (defect in c("missing", "duplicate", "nonfinite")) { + rows <- predictions + if (defect == "missing") rows <- rows[-affected, , drop = FALSE] + if (defect == "duplicate") rows <- dplyr::bind_rows(rows, rows[affected, , drop = FALSE]) + if (defect == "nonfinite") rows$Forecast[affected] <- NA_real_ + expect_identical(screen_ensemble_inputs(rows, context, splits), + rows[rows$Model_ID == "safe", , drop = FALSE], info = defect) + } +}) + +test_that("selection validates coverage and supports sole or rejected candidates", { + fixture <- make_selection_case() + fixture$forecasts <- fixture$forecasts[-1, ] + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "safe") + expect_true("incomplete_forecast" %in% unlist(result$rankings$Reasons)) + fixture$forecasts$Forecast <- Inf + expect_true(is.na(do.call(select_forecast_candidate, fixture)$selected_id)) + fixture <- make_selection_case(futures = list(only = rep(100, 2)), errors = c(only = 0)) + expect_identical(do.call(select_forecast_candidate, fixture)$selected_id, "only") +}) + +test_that("selection handles data shapes across all supported cadences", { + shapes <- list( + zero = rep(0, 24), constant = rep(100, 24), signed = rep(c(-80, -100, -90, -110), 6), + sparse = rep(c(0, 0, 100, 0), 6), trending = 100 + 1:24, + noisy = 100 + rep(c(-5, 9, -2, 7), 6) + ) + for (date_type in c("day", "week", "month", "quarter", "year")) { + for (shape in shapes) { + fixture <- make_selection_case(shape, + futures = list(only = rep(stats::median(shape), 3)), + errors = c(only = 0.03), date_type = date_type + ) + result <- do.call(select_forecast_candidate, fixture) + expect_identical(result$selected_id, "only") + expect_true(all(is.finite(result$rankings$Risk))) + } + } +}) + +test_that("selection is invariant to row order, units and future target values", { + fixture <- make_selection_case() + expected <- do.call(select_forecast_candidate, fixture)$selected_id + for (scale in c(1e-100, 1, 1e100)) { + scaled <- fixture + scaled$history$Target <- scaled$history$Target * scale + for (table in c("backtests", "forecasts")) { + scaled[[table]]$Target <- scaled[[table]]$Target * scale + scaled[[table]]$Forecast <- scaled[[table]]$Forecast * scale + scaled[[table]] <- scaled[[table]][rev(seq_len(nrow(scaled[[table]]))), ] + } + scaled$forecasts$Target <- -1e200 + expect_identical(do.call(select_forecast_candidate, scaled)$selected_id, expected) + } +}) + +test_that("a replacement selector is called and its structural contract checked", { + fixture <- make_selection_case() + series_data <- fixture$context + series_data$history <- fixture$history + predictions <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) + replacement <- function(history, backtests, forecasts, context) { + result <- select_forecast_candidate(history, backtests, forecasts, context) + result$selected_id <- "accurate" + result + } + expect_identical( + select_series_forecasts(predictions, series_data, series_data$train_test_split, selector = replacement)$selected_id, + "accurate" + ) + expect_error(select_series_forecasts(predictions, series_data, series_data$train_test_split, + selector = function(...) list(selected_id = "absent", rankings = data.frame())), "invalid selection contract") +}) + +test_that("R2-only history uses one exact recipe read", { + fixture <- make_selection_history_recipe(101:124, recipe = "R2") + reads <- character() + local_mocked_bindings( + list_files = function(...) stop("must not list"), + read_file = function(run_info, file_list, ...) { + reads <<- c(reads, file_list) + expect_match(file_list, "-R2\\.csv$") + fixture$data + } + ) + result <- read_series_history(list(project_name = "project", run_name = "run", path = tempdir(), data_output = "csv"), + "Synthetic", data.frame(hist_end_date = fixture$hist_end_date, recipes_to_run = "R2", date_type = "month")) + expect_equal(result$history, fixture$expected) + expect_length(reads, 1) +}) + +test_that("weekly collapse preserves invalid values from every expanded day", { + fixture <- make_selection_case(actuals = rep(100, 104), + futures = list(accurate = rep(100, 3), safe = rep(100, 3)), + errors = c(accurate = 0.02, safe = 0.023), date_type = "week") + native <- dplyr::bind_rows(fixture$backtests, fixture$forecasts) %>% + dplyr::mutate(Combo = "Synthetic") + expanded <- native[rep(seq_len(nrow(native)), each = 7L), ] + expanded$Date_Day <- expanded$Date + rep(0:6, nrow(native)) + expanded$Forecast <- expanded$Forecast / 7 + expanded$Target <- expanded$Target / 7 + expect_identical(native_forecast_rows(native, "week"), native) + expect_equal(tibble::as_tibble(native_forecast_rows(expanded, "week")), tibble::as_tibble(native)) + outcomes <- list() + for (value in c(Inf, -Inf, NaN, NA_real_)) { + for (day in c(0L, 3L, 6L)) { + invalid <- expanded + affected <- invalid$Model_ID == "accurate" & invalid$Train_Test_ID == 1L & + invalid$Date_Day == min(fixture$forecasts$Date) + day + invalid$Forecast[affected] <- value + for (reversed in c(FALSE, TRUE)) { + rows <- if (reversed) invalid[rev(seq_len(nrow(invalid))), ] else invalid + collapsed <- native_forecast_rows(rows, "week") + context <- fixture$context + context$history <- fixture$history + selected <- select_series_forecasts(collapsed, context, context$train_test_split) + screened <- screen_ensemble_inputs(collapsed, context, context$train_test_split) + outcomes[[length(outcomes) + 1L]] <- data.frame( + Invalid_Preserved = any(!is.finite(collapsed$Forecast[collapsed$Model_ID == "accurate"])), + Selected = selected$selected_id, + Accurate_Eligible = selected$rankings$Eligible[selected$rankings$Model_ID == "accurate"], + Safe_Eligible = selected$rankings$Eligible[selected$rankings$Model_ID == "safe"], + Invalid_Screened = !"accurate" %in% screened$Model_ID) + } + } + } + outcomes <- dplyr::bind_rows(outcomes) + expect_equal(nrow(outcomes), 24L) + expect_true(all(outcomes$Invalid_Preserved)) + expect_true(all(outcomes$Selected == "safe")) + expect_false(any(outcomes$Accurate_Eligible)) + expect_true(all(outcomes$Safe_Eligible)) + expect_true(all(outcomes$Invalid_Screened)) +}) + +test_that("invalid predictions remain invalid after artifact serialization", { + data <- data.frame(Forecast = c(1, Inf, -Inf, NaN, NA_real_)) + csv <- withr::local_tempfile(fileext = ".csv") + write_fcst_file(negative_fcst_adj(data, FALSE), csv) + restored <- read_fcst_file(csv) + expect_identical(is.finite(restored$Forecast), c(TRUE, FALSE, FALSE, FALSE, FALSE)) + expect_identical(restored$Forecast[2:3], c(Inf, -Inf)) + if (requireNamespace("arrow", quietly = TRUE)) { + parquet <- withr::local_tempfile(fileext = ".parquet") + write_fcst_file(negative_fcst_adj(data, FALSE), parquet) + restored <- read_fcst_file(parquet) + expect_identical(is.finite(restored$Forecast), c(TRUE, FALSE, FALSE, FALSE, FALSE)) + } +}) + +test_that("cutoff replay rejects explosions without rejecting usable reference paths", { + shapes <- list( + stable = rep(100, 60), trend = 100 + seq_len(60), + seasonal = 100 + 20 * sin(2 * pi * seq_len(60) / 12), + shift = c(rep(100, 30), rep(140, 30)), sparse = rep(c(0, 0, 0, 100, 0, 0), 10) + ) + outcomes <- list() + for (shape in names(shapes)) { + for (cutoff in c(12, 24, 36, 48)) { + history <- shapes[[shape]][seq_len(cutoff)] + reference <- rep(utils::tail(history, min(12, cutoff)), length.out = 6) + fixture <- make_selection_case(history, + futures = list(explosive = rep(1e8, 6), reference = reference), + errors = c(explosive = 0.01, reference = 0.04)) + selected <- do.call(select_forecast_candidate, fixture) + holdout <- shapes[[shape]][cutoff + 1:6] + outcomes[[length(outcomes) + 1L]] <- data.frame( + Shape = shape, Cutoff = cutoff, Selected = selected$selected_id, + Rejected_Reference = !selected$rankings$Eligible[selected$rankings$Model_ID == "reference"], + Holdout_Error = sum(abs(reference - holdout)) / max(sum(abs(holdout)), 0.1) + ) + } + } + replay <- dplyr::bind_rows(outcomes) + expect_equal(nrow(replay), 20) + expect_true(all(replay$Selected == "reference")) + expect_false(any(replay$Rejected_Reference)) + expect_true(all(is.finite(replay$Holdout_Error))) +}) + +test_that("finished selection reruns compare only their unchanged input settings", { + local_mocked_bindings(par_start = function(...) { + list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`) + }) + info <- make_best_models_fixture() + final_models(info) + first <- get_forecast_data(info) + expect_no_error(final_models(info)) + expect_equal(get_forecast_data(info), first) + expect_error(final_models(info, weekly_to_daily = FALSE), "Inputs have recently changed") +}) \ No newline at end of file diff --git a/tests/testthat/test-load_run_results.R b/tests/testthat/test-load_run_results.R index b6b4c4fe..bd29b318 100644 --- a/tests/testthat/test-load_run_results.R +++ b/tests/testthat/test-load_run_results.R @@ -1,8 +1,70 @@ # tests/testthat/test-load_run_results.R -# Tests for numeric type safety in the type-coercion logic used by load_run_results() +# Tests for iteration ranking and numeric type safety in load_run_results() # -# These tests exercise the coercion + bind_rows logic directly, without -# calling the full load_run_results() (which needs disk I/O via get_run_info). +# Ranking tests call load_run_results() with an in-memory run-log source. +# The original coercion tests below retain their direct bind_rows coverage. + +test_that("run history retains the original near-best model-pool signal", { + cases <- list( + list(wmape = c(0.1, 0.1), average = c(0.2, 0.15), winner = 2L), + list(wmape = c(0.1, 0.105), average = c(0.2, 0.15), winner = 2L), + list(wmape = c(0.1, 0.11), average = c(0.2, 0.15), winner = 2L), + list(wmape = c(0.1, 0.1101), average = c(0.2, 0.15), winner = 1L), + list(wmape = c(0.1, 0.105), average = c(0.2, 0.2), winner = 1L), + list(wmape = c(0.1, 0.105), average = c(0.2, 0.25), winner = 1L), + list(wmape = c(0.1, 0.105), average = c(0.2, NA_real_), winner = 1L), + list(wmape = c(0.1, 0.105), average = c(NA_real_, 0.15), winner = 1L), + list(wmape = c(0.12, 0.1, 0.108), average = c(0.05, 0.2, 0.15), winner = 3L), + list(wmape = c(0, 0.0001), average = c(0.2, 0.15), winner = 1L) + ) + for (case in cases) local({ + combo <- hash_data("North--Revenue") + logs <- data.frame( + project_name = paste0("project_", combo), + run_name = paste0("agent_parent_", combo, "_", seq_along(case$wmape)), + created = sprintf("2026-01-01 00:00:%02d", seq_along(case$wmape)), + agent_version = 1, agent_forecast_approach = "bottoms_up", + weighted_mape = case$wmape, model_avg_wmape = case$average, + selection_status = "evaluated" + ) + reads <- 0L + local_mocked_bindings( + get_run_info = function(...) { reads <<- reads + 1L; logs }, + assess_agent_run = function(...) stop("iteration ranking must not restore forecasts"), + read_series_history = function(...) stop("iteration ranking must not reload prepared history") + ) + agent <- list(agent_version = 1, forecast_approach = "bottoms_up", + project_info = list(project_name = "project", path = tempdir())) + + result <- load_run_results(agent, combo) + + expect_identical(result$run_number[result$best_run == "yes"], case$winner) + expect_equal(result$model_avg_wmape, case$average) + expect_identical(reads, 1L) + }) +}) + +test_that("near-best ranking excludes other versions and incomplete iterations", { + combo <- hash_data("North--Revenue") + logs <- data.frame( + project_name = paste0("project_", combo), + run_name = paste0("agent_parent_", combo, "_", 1:5), + created = sprintf("2026-01-01 00:00:%02d", 1:5), + agent_version = c(1, 1, 1, 0, 1), agent_forecast_approach = "bottoms_up", + weighted_mape = c(0.1, 0.105, 0.001, 0.0001, 0.106), + model_avg_wmape = c(0.2, 0.18, 0.01, 0.001, 0.15), + selection_status = c("evaluated", "evaluated", "rejected", "evaluated", "partial") + ) + local_mocked_bindings(get_run_info = function(...) logs) + agent <- list(agent_version = 1, forecast_approach = "bottoms_up", + project_info = list(project_name = "project", path = tempdir())) + + result <- load_run_results(agent, combo) + + expect_identical(result$run_number[result$best_run == "yes"], 2L) + expect_true(all(result$best_run[result$agent_version == 0] == "no")) + expect_true(all(result$best_run[result$selection_status %in% c("partial", "rejected")] == "no")) +}) # helper: simulate the coercion + bind_rows logic from load_run_results coerce_and_bind <- function(previous_runs, current_run_log) { diff --git a/tests/testthat/test-multistep-daily-regression.R b/tests/testthat/test-multistep-daily-regression.R index 310d3d98..081a356f 100644 --- a/tests/testthat/test-multistep-daily-regression.R +++ b/tests/testthat/test-multistep-daily-regression.R @@ -63,6 +63,32 @@ run_daily_multistep_case <- function(clean_outliers, seed = 123 ) + hyperparameter_path <- paste0( + "/prep_models/", hash_data(run_info$project_name), "-", + hash_data(run_info$run_name), "-model_hyperparameters.", run_info$object_output + ) + hyperparameters <- finnts:::read_file(run_info, path = hyperparameter_path, return_type = "df") + original_hyperparameters <- hyperparameters + for (model_index in seq_len(nrow(hyperparameters))) { + if (hyperparameters$Model[[model_index]] == "xgboost") { + hyperparameters$Hyperparameters[[model_index]]$trees <- 20L + hyperparameters$Hyperparameters[[model_index]]$tree_depth <- 2L + } else if (hyperparameters$Model[[model_index]] == "cubist") { + hyperparameters$Hyperparameters[[model_index]]$committees <- 1L + hyperparameters$Hyperparameters[[model_index]]$max_rules <- 10L + } + } + if (any(hyperparameters$Model %in% c("xgboost", "cubist"))) { + finnts:::write_data( + x = hyperparameters, + combo = NULL, + run_info = run_info, + output_type = "object", + folder = "prep_models", + suffix = "-model_hyperparameters" + ) + } + train_models( run_info = run_info, run_global_models = FALSE, @@ -78,7 +104,9 @@ run_daily_multistep_case <- function(clean_outliers, forecast = output$forecast, trained = get_trained_models(run_info), prepared = get_prepped_data(run_info, recipe = "R1"), - splits = output$splits + splits = output$splits, + original_hyperparameters = original_hyperparameters, + hyperparameters = hyperparameters ) } @@ -86,6 +114,27 @@ expect_complete_multistep_output <- function(result, expected_models) { forecast <- result$forecast %>% dplyr::filter(Model_Name %in% expected_models) + grid <- result$hyperparameters + original_grid <- result$original_hyperparameters + metadata_columns <- setdiff(names(original_grid), "Hyperparameters") + expect_identical(names(grid), names(original_grid)) + expect_identical(grid[, metadata_columns, drop = FALSE], + original_grid[, metadata_columns, drop = FALSE]) + for (grid_index in seq_len(nrow(grid))) { + parameters <- grid$Hyperparameters[[grid_index]] + original_parameters <- original_grid$Hyperparameters[[grid_index]] + bounded_parameters <- switch(grid$Model[[grid_index]], + xgboost = c("trees", "tree_depth"), + cubist = c("committees", "max_rules"), + character() + ) + unchanged_parameters <- setdiff(names(original_parameters), bounded_parameters) + expect_identical(names(parameters), names(original_parameters)) + expect_identical(nrow(parameters), nrow(original_parameters)) + expect_identical(parameters[, unchanged_parameters, drop = FALSE], + original_parameters[, unchanged_parameters, drop = FALSE], info = grid$Model[[grid_index]]) + } + expect_setequal(unique(result$trained$Model_Name), expected_models) expect_setequal(unique(forecast$Model_Name), expected_models) expect_true(all(c("Future_Forecast", "Back_Test", "Validation") %in% unique(forecast$Run_Type))) @@ -99,6 +148,15 @@ expect_complete_multistep_output <- function(result, expected_models) { expected_lags <- finnts:::get_multi_lags(lag_periods, forecast_horizon = 92) fitted_model <- workflow$fit$fit$fit + model_name <- result$trained$Model_Name[[model_index]] + if (model_name == "xgboost") { + expect_equal(rlang::eval_tidy(spec$args$trees), 20) + expect_equal(rlang::eval_tidy(spec$args$tree_depth), 2) + } else if (model_name == "cubist") { + expect_equal(rlang::eval_tidy(spec$args$committees), 1) + expect_equal(rlang::eval_tidy(spec$args$max_rules), 10) + } + expect_equal( names(fitted_model$models), paste0("model_lag_", expected_lags), diff --git a/tests/testthat/test-read-write-data.R b/tests/testthat/test-read-write-data.R index 2412e08d..ddce73b0 100644 --- a/tests/testthat/test-read-write-data.R +++ b/tests/testthat/test-read-write-data.R @@ -60,6 +60,167 @@ test_that("read_file permits an explicitly optional missing table", { expect_equal(nrow(result), 0) }) +for (provider in c("blob_container", "ms_drive")) { + test_that(paste("selection reads accept a confirmed missing optional artifact on", provider), { + transport <- local_artifact_provider(provider) + run_info <- artifact_test_run("remote-only-artifacts") + run_info$storage_object <- transport$storage_object + + result <- tryCatch(read_selection_file(run_info, "forecasts", "-average_models", "A", + optional = TRUE), error = identity) + + expect_s3_class(result, "data.frame") + if (is.data.frame(result)) expect_equal(nrow(result), 0L) + expect_equal(transport$root_checks, 1L) + }) +} + +for (provider in c("blob_container", "ms_drive")) { + for (format in c("csv", "rds", "parquet")) { + test_that(paste("exact", provider, "reads download and parse", format, "once"), { + if (format == "parquet") skip_if_not_installed("arrow") + source <- artifact_test_run(withr::local_tempdir(), format) + expected <- artifact_test_recipe(source, "A", "R1") + remote <- source + remote$path <- "provider-artifacts" + transport <- local_artifact_provider(provider) + remote$storage_object <- transport$storage_object + path <- artifact_test_path(remote, "forecasts", "A", "-average_models") + transport$files[[as.character(path)]] <- artifact_test_path(source, "prep_data", "A", "-R1") + cache <- new.env(parent = emptyenv()) + + result <- read_selection_file(remote, "forecasts", "-average_models", "A", cache = cache) + cached <- read_selection_file(remote, "forecasts", "-average_models", "A", cache = cache) + + expect_equal(result, expected) + expect_equal(cached, expected) + expect_identical(transport$lookups, as.character(path)) + expect_identical(transport$downloads, as.character(path)) + expect_equal(transport$root_checks, 0L) + transport$files[[as.character(path)]] <- NULL + expect_equal(nrow(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE)), 0L) + expect_error(read_selection_file(remote, "forecasts", "-average_models", "A"), class = "http_404") + transport$files[[as.character(path)]] <- artifact_test_path(source, "prep_data", "A", "-R1") + expect_equal(read_selection_file(remote, "forecasts", "-average_models", "A"), expected) + expect_length(unique(transport$destinations), 2L) + }) + } + + test_that(paste("optional", provider, "reads propagate provider and parsing failures"), { + source <- artifact_test_run(withr::local_tempdir(), "rds") + artifact_test_recipe(source, "A", "R1") + remote <- source + remote$path <- "provider-artifacts" + transport <- local_artifact_provider(provider) + remote$storage_object <- transport$storage_object + path <- artifact_test_path(remote, "forecasts", "A", "-average_models") + for (status in c(401L, 403L, 429L, 500L)) { + condition <- artifact_http_error(status, "provider failure") + transport$lookup_error <- condition + observed <- tryCatch(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), + error = identity) + expect_identical(observed, condition) + } + transport$lookup_error <- simpleError("unclassified provider failure") + expect_error(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), + "unclassified provider failure", fixed = TRUE) + transport$lookup_error <- NULL + for (status in c(403L, 404L)) { + transport$root_error <- artifact_http_error(status, "storage root unavailable") + observed <- tryCatch(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), + error = identity) + expect_identical(observed, transport$root_error) + } + transport$root_error <- NULL + payload <- artifact_test_path(source, "prep_data", "A", "-R1") + transport$files[[as.character(path)]] <- payload + transport$download_error <- artifact_http_error(500L, "download failed") + expect_error(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), class = "http_500") + if (provider == "ms_drive") { + transport$download_error <- artifact_http_error(404L, "download URL unavailable") + expect_error(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), class = "http_404") + transport$folder <- TRUE + expect_error(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), + "not a regular file", fixed = TRUE) + transport$folder <- FALSE + } + transport$download_error <- NULL + writeLines("invalid serialized artifact", payload) + expect_error(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), + "unknown input format|error reading from connection") + remote$data_output <- "csv" + empty <- withr::local_tempfile(fileext = ".csv") + writeLines("Forecast", empty) + transport$files[[as.character(artifact_test_path(remote, "forecasts", "A", "-average_models"))]] <- empty + expect_error(read_selection_file(remote, "forecasts", "-average_models", "A", optional = TRUE), + "exact forecast artifact is empty or unreadable", fixed = TRUE) + }) +} + +for (provider in c("blob_container", "ms_drive")) { + test_that(paste("standard hierarchical retrieval reads all provider models on", provider), { + source <- artifact_test_run(withr::local_tempdir(), "rds") + artifact_test_log(source, combo_variables = "ID", forecast_approach = "grouped_hierarchy") + artifact_test_splits(source) + models <- c("meanf--local--R1", "snaive--local--R1", "Best-Model") + for (model in models) { + rows <- artifact_test_forecast(source, write_output = FALSE) + rows$Model_ID <- model + rows$Best_Model <- if (model == "Best-Model") "Yes" else "No" + write_data(rows, model, source, "data", "forecasts", "-reconciled") + } + remote <- source + remote$path <- "provider-artifacts" + transport <- local_artifact_provider(provider) + remote$storage_object <- transport$storage_object + files <- c(artifact_test_path(source, "logs", extension = "csv"), + artifact_test_path(source, "prep_models", suffix = "-train_test_split"), + vapply(models, function(model) as.character(artifact_test_path(source, "forecasts", model, "-reconciled")), character(1))) + remote_files <- fs::path(remote$path, c("logs", "prep_models", rep("forecasts", 3)), fs::path_file(files)) + transport$files <- stats::setNames(as.list(files), as.character(remote_files)) + listings <- 0L + local_mocked_bindings(list_files = function(storage_object, path, fail_on_error = FALSE) { + expect_match(path, "-reconciled[.]rds$") + expect_true(fail_on_error) + listings <<- listings + 1L + files <- remote_files[3:5] + if (provider == "ms_drive") fs::path_file(files) else files + }) + + result <- get_forecast_data(remote) + + expect_setequal(result$Model_ID, models) + expect_identical(result$Model_ID[result$Best_Model == "Yes"], "Best-Model") + expect_equal(listings, 1L) + expect_setequal(transport$downloads, as.character(remote_files)) + expect_length(transport$downloads, 5L) + }) + + test_that(paste("selection history and hierarchy metadata use exact provider transfer on", provider), { + source <- artifact_test_run(withr::local_tempdir(), "rds") + history <- artifact_test_recipe(source, "A", "R1") + hierarchy <- list(original_combos = "A", hts_combos = "A") + write_data(hierarchy, NULL, source, "object", "prep_data", "-hts_info") + remote <- source + remote$path <- "provider-artifacts" + transport <- local_artifact_provider(provider) + remote$storage_object <- transport$storage_object + history_path <- artifact_test_path(remote, "prep_data", "A", "-R1") + hierarchy_path <- artifact_test_path(remote, "prep_data", suffix = "-hts_info", extension = "rds") + transport$files[[as.character(history_path)]] <- artifact_test_path(source, "prep_data", "A", "-R1") + transport$files[[as.character(hierarchy_path)]] <- artifact_test_path(source, "prep_data", suffix = "-hts_info", extension = "rds") + log <- tibble::tibble(hist_end_date = max(history$Date), recipes_to_run = "R1", date_type = "day") + cache <- new.env(parent = emptyenv()) + + expect_equal(read_series_history(remote, "A", log, cache)$history, + as.data.frame(history[, c("Date", "Target")])) + expect_equal(read_selection_hierarchy(remote, cache), hierarchy) + expect_equal(read_selection_hierarchy(remote, cache), hierarchy) + expect_setequal(transport$downloads, as.character(c(history_path, hierarchy_path))) + expect_length(transport$downloads, 2L) + }) +} + test_that("strict CSV fallback preserves valid empty and populated files", { run_info <- artifact_test_run(withr::local_tempdir()) paths <- file.path(run_info$path, paste0("fallback-", seq_len(3), ".csv")) diff --git a/tests/testthat/test-reconciled-forecast-selection.R b/tests/testthat/test-reconciled-forecast-selection.R new file mode 100644 index 00000000..86ab6b80 --- /dev/null +++ b/tests/testthat/test-reconciled-forecast-selection.R @@ -0,0 +1,247 @@ +test_that("outer reconciliation publishes the selected mixture without post-quality switching", { + fixture <- make_reconciled_selection_fixture() + fixture$project_info$combo_variables <- "Series" + fixture$project_info$weekly_to_daily <- FALSE + fixture$agent_info$project_info <- fixture$project_info + fixture$agent_info$run_id <- "outer" + fixture$run_inputs$negative_forecast <- FALSE + fixture$forecasts$Model_ID <- ifelse(fixture$forecasts$Best_Model == "Yes", + ifelse(match(fixture$forecasts$Combo, fixture$metadata$hts_combos) %% 2L == 0L, + "arima--local--R1", "ets--local--R1"), "meanf--local--R1") + reconciliations <- list() + evaluations <- 0L + published <- NULL + original_selector <- select_series_forecasts + local_mocked_bindings( + check_agent_info = function(...) NULL, + get_best_agent_run = function(...) fixture$run_inputs, + load_agent_forecast = function(...) fixture$forecasts, + list_files = function(...) stop("known split must not require directory discovery"), + local_artifact_files = function(file_list, ...) { + expect_length(file_list, 1L) + expect_match(file_list, "-train_test_split[.]csv$") + expect_false(grepl("*", file_list, fixed = TRUE)) + file_list + }, + read_file = function(...) fixture$splits, + read_selection_hierarchy = function(...) fixture$metadata, + read_selection_file = function(...) data.frame(forecast_approach = "bottoms_up"), + read_series_history = function(run_info, combo, ...) { + fixture$contexts[[match(combo, fixture$run_inputs$combo)]] + }, + reconcile = function(initial_fcst, ...) { + reconciliations[[length(reconciliations) + 1L]] <<- initial_fcst + rows <- initial_fcst[initial_fcst$Combo %in% fixture$run_inputs$combo, ] + rows$Combo <- fixture$metadata$original_combos[match(rows$Combo, fixture$run_inputs$combo)] + rows$Combo_ID <- rows$Combo + rows$Model_ID <- "Best-Model" + rows$Best_Model <- "Yes" + rows$Hyperparameter_ID <- NA_real_ + rows$Run_Type <- NULL + rows + }, + select_series_forecasts = function(...) { + evaluations <<- evaluations + 1L + original_selector(...) + }, + create_prediction_intervals = function(data, ...) data, + convert_weekly_to_daily = function(data, ...) data, + write_data = function(x, ...) { published <<- x } + ) + reconcile_agent_forecast(fixture$agent_info, fixture$project_info) + expect_length(reconciliations, 1L) + expect_setequal(unique(reconciliations[[1]]$Model_ID), c("arima--local--R1", "ets--local--R1")) + expect_identical(evaluations, 0L) + future <- published[published$Train_Test_ID == 1, ] + expect_equal(future$Forecast, 3 * unname(fixture$values[future$Combo])) + expect_true(all(published$Best_Model == "Yes")) + expect_identical(unique(published$Model_ID), "Best-Model") + + average_id <- "arima--local--R1_glmnet--local--R2" + averaged <- fixture$forecasts$Model_ID == "arima--local--R1" + fixture$forecasts$Model_ID[averaged] <- average_id + fixture$forecasts$Recipe_ID[averaged] <- "simple_average" + reconcile_agent_forecast(fixture$agent_info, fixture$project_info) + expect_length(reconciliations, 2L) + expect_setequal(unique(reconciliations[[2]]$Model_ID), c(average_id, "ets--local--R1")) + expect_true(all(reconciliations[[2]]$Best_Model == "Yes")) + expect_identical(unique(published$Model_ID), "Best-Model") + expect_identical(evaluations, 0L) +}) + +test_that("standard reconciliation never promotes a uniform alternative after selection", { + fixture <- make_reconciled_selection_fixture() + accurate <- fixture$forecasts[fixture$forecasts$Model_ID == "accurate", ] + safe <- fixture$forecasts[fixture$forecasts$Model_ID == "safe", ] + forecasts <- dplyr::bind_rows(lapply(c("arima", "ets", "meanf"), function(model) { + rows <- if (model == "meanf") safe else accurate + rows$Model_Name <- model + rows$Model_Type <- "local" + rows$Recipe_ID <- "R1" + rows$Model_ID <- paste(model, "local", "R1", sep = "--") + chosen <- ifelse(match(rows$Combo, fixture$metadata$hts_combos) %% 2L == 0L, "arima", "ets") + rows$Best_Model <- ifelse(model == chosen, "Yes", "No") + rows$Run_Type <- NULL + rows + })) + stored <- new.env(parent = emptyenv()) + evaluations <- 0L + original_selector <- select_series_forecasts + local_mocked_bindings( + par_start = function(...) list(cl = NULL, packages = character(), foreach_operator = foreach::`%do%`), + list_files = function(...) character(), + read_file = function(run_info, path, return_type = "df", ...) { + if (return_type == "object") return(fixture$metadata) + if (grepl("train_test_split", path, fixed = TRUE)) return(fixture$splits) + if (grepl("hts_data", path, fixed = TRUE)) return(fixture$history) + forecasts + }, + read_selection_file = function(run_info, folder, combo = NULL, ...) { + if (folder == "logs") data.frame(forecast_approach = "standard_hierarchy") else stored[[combo]] + }, + select_series_forecasts = function(...) { evaluations <<- evaluations + 1L; original_selector(...) }, + write_data = function(x, combo, ...) { stored[[combo]] <- x } + ) + info <- fixture$project_info + info$path <- tempdir() + reconcile_hierarchical_data(info, NULL, "standard_hierarchy", FALSE, FALSE, "month", 1) + expect_identical(evaluations, 0L) + expect_true(exists("meanf--local--R1", stored, inherits = FALSE)) + best <- stored[["Best-Model"]] + future <- best[best$Train_Test_ID == 1, ] + expect_equal(future$Forecast, 3 * unname(fixture$values[future$Combo]), tolerance = 1e-7) + expect_true(all(best$Best_Model == "Yes")) +}) + +test_that("accuracy-only comparison avoids quality evaluation without changing its forecasts", { + fixture <- make_pre_reconciliation_case("clean", "all", shape = "flat") + quality_calls <- 0L + original_selector <- select_series_forecasts + local_mocked_bindings(select_series_forecasts = function(...) { + quality_calls <<- quality_calls + 1L + original_selector(...) + }) + baseline <- select_pre_reconciliation_inputs(fixture, quality = FALSE) + expect_identical(quality_calls, 0L) + for (combo in names(fixture$contexts)) { + rows <- fixture$forecasts[fixture$forecasts$Combo == combo, ] + model_ids <- sort(unique(rows$Model_ID)) + template <- rows[rows$Model_ID == model_ids[1], ] + template <- template[order(template$Train_Test_ID, template$Date), ] + forecasts <- vapply(model_ids, function(model_id) { + model <- rows[rows$Model_ID == model_id, ] + model$Forecast[order(model$Train_Test_ID, model$Date)] + }, numeric(nrow(template))) + components <- c(as.list(seq_along(model_ids)), + utils::combn(seq_along(model_ids), 2, simplify = FALSE), list(seq_along(model_ids))) + candidate_ids <- vapply(components, function(indices) paste(model_ids[indices], collapse = "_"), character(1)) + candidates <- vapply(components, function(indices) { + rowMeans(forecasts[, indices, drop = FALSE]) + }, numeric(nrow(template))) + backtest <- template$Train_Test_ID %in% fixture$splits$Train_Test_ID[fixture$splits$Run_Type == "Back_Test"] + history <- fixture$contexts[[combo]]$history + actuals <- history$Target[match(template$Date[backtest], history$Date)] + actuals[actuals == 0] <- 0.1 + errors <- apply(candidates[backtest, , drop = FALSE], 2, function(prediction) { + stats::weighted.mean(round(abs((prediction - actuals) / abs(actuals)), 4), abs(actuals)) + }) + winner <- order(errors, candidate_ids)[1] + selected <- baseline$forecasts[baseline$forecasts$Combo == combo, ] + selected <- selected[order(selected$Train_Test_ID, selected$Date), ] + expect_identical(unique(selected$Model_ID), candidate_ids[winner]) + expect_equal(selected$Train_Test_ID, template$Train_Test_ID) + expect_equal(selected$Date, template$Date) + expect_equal(selected$Forecast, candidates[, winner], tolerance = 1e-12) + expect_equal(forecast_backtest_accuracy(history, selected[backtest, ])$WMAPE, + errors[winner], tolerance = 1e-12) + } + malformed <- fixture + malformed$forecasts$Model_ID[1] <- "" + expect_error(select_pre_reconciliation_inputs(malformed, quality = FALSE), + "Candidate identities must be nonmissing") + malformed <- fixture + malformed$contexts[[1]]$history$Date[2] <- malformed$contexts[[1]]$history$Date[1] + expect_error(select_pre_reconciliation_inputs(malformed, quality = FALSE), + "unique dated historical actuals") +}) + +test_that("preselection reduces pathological bottom forecasts through real hts", { + for (approach in c("standard_hierarchy", "grouped_hierarchy")) { + for (pathology in c("magnitude", "phase", "trend")) { + result <- measure_pre_selection_case(make_pre_reconciliation_case(pathology, "all", approach)) + expect_true(result$Meets_Expectation, info = paste(approach, pathology)) + expect_gt(result$Before_Error, 0.01) + expect_lt(result$After_Error, result$Before_Error / 2) + expect_true(result$Preselection_Accuracy_OK) + } + } +}) + +test_that("seasonal amplitude preference avoids flattened reconciled forecasts", { + for (approach in c("standard_hierarchy", "grouped_hierarchy")) { + result <- measure_pre_selection_case(make_pre_reconciliation_case("flatten", "all", approach)) + expect_true(result$Meets_Expectation) + expect_equal(result$Before_Error, 0.06439506, tolerance = 1e-7) + expect_lt(result$After_Error, 1e-6) + expect_lt(result$After_Amplitude, 1e-6) + expect_equal(result$After_Phase, 1, tolerance = 1e-7) + expect_true(result$Preselection_Accuracy_OK) + } +}) + +test_that("supported short seasonal selection improves real hts output", { + result <- measure_pre_selection_case(make_pre_reconciliation_case("phase", "all", horizon = 3L)) + expect_true(result$Meets_Expectation) + expect_gt(result$Before_Error, 0.1) + expect_lt(result$After_Error, result$Before_Error / 2) + expect_gt(result$After_Phase, 0) + expect_true(result$Preselection_Accuracy_OK) +}) + +test_that("preselection fixes finite shocks without damaging uninjected siblings", { + result <- measure_pre_selection_case(make_pre_reconciliation_case("level", "leaf")) + expect_gt(result$Before_Endpoint, 1) + expect_gt(result$Before_Sibling, 0) + expect_lt(result$After_Endpoint, 1e-7) + expect_lt(result$After_Sibling, 1e-7) +}) + +test_that("short evidence and accuracy allowance remain explicit selection limits", { + short <- make_pre_reconciliation_case("phase", "all", history_cycles = 1L) + result <- measure_pre_selection_case(short) + expect_false(result$Meets_Expectation) + expect_equal(result$After_Error, result$Before_Error, tolerance = 1e-8) + expect_lt(result$After_Phase, 0) + + fixture <- make_pre_reconciliation_case("level", "all", shape = "flat") + for (combo in names(fixture$contexts)) { + rows <- fixture$forecasts$Combo == combo + futures <- rows & fixture$forecasts$Train_Test_ID == 1L + safe_ids <- unique(fixture$forecasts$Model_ID[futures & fixture$forecasts$Forecast < 2 * fixture$contexts[[combo]]$history$Target[1]]) + safer <- rows & fixture$forecasts$Model_ID %in% safe_ids & fixture$forecasts$Train_Test_ID != 1L + fixture$forecasts$Forecast[safer] <- fixture$forecasts$Target[safer] * 1.10 + } + selected <- select_pre_reconciliation_inputs(fixture, max_average = 1L) + expect_true(all(vapply(selected$selections, function(selection) { + selection$rankings$Violations[match(selection$selected_id, selection$rankings$Model_ID)] > 0 + }, logical(1)))) + score <- score_pre_selection_case(fixture, reconcile_pre_selection_case(fixture, selected)) + expect_gt(score[["relative_error"]], 1) +}) + +test_that("invalid base keys and values are rejected before hts", { + fixture <- make_pre_reconciliation_case("clean", "all", shape = "flat") + first_combo <- fixture$metadata$hts_combos[1] + candidates <- unique(fixture$forecasts$Model_ID) + missing <- fixture$forecasts$Combo == first_combo & fixture$forecasts$Model_ID == candidates[1] & + fixture$forecasts$Train_Test_ID == 4L + fixture$forecasts <- fixture$forecasts[!missing, ] + invalid <- fixture$forecasts$Combo == first_combo & fixture$forecasts$Model_ID == candidates[2] & + fixture$forecasts$Train_Test_ID == 1L + fixture$forecasts$Forecast[invalid] <- NA_real_ + selected <- select_pre_reconciliation_inputs(fixture) + expect_identical(selected$selections[[first_combo]]$selected_id, candidates[3]) + expect_true(all(is.finite(selected$forecasts$Forecast))) + fixture$forecasts$Forecast[fixture$forecasts$Combo == first_combo] <- Inf + expect_error(select_pre_reconciliation_inputs(fixture), class = "finnts_forecast_selection_rejected") +}) \ No newline at end of file diff --git a/tests/testthat/test-undifference.R b/tests/testthat/test-undifference.R index ce3ad4a5..ed5a2fb6 100644 --- a/tests/testthat/test-undifference.R +++ b/tests/testthat/test-undifference.R @@ -187,3 +187,64 @@ test_that("undifference_recipe handles double differencing with mid-vector NAs", expect_equal(nrow(result), 6) }) + +test_that("original actuals and cleaned forecasts use different starting values", { + for (difference_order in 1:2) { + for (recipe in c("R1", "R2")) { + actuals <- as.numeric(101:136) + actuals[2] <- 300 + cleaned <- as.numeric(101:136) + fixture <- make_selection_history_recipe(actuals, cleaned, difference_order, recipe = recipe) + expect_equal(fixture$combo_info$Target_Original_Diff_Value1, 101) + if (difference_order == 2) { + expect_equal(fixture$combo_info$Target_Original_Diff_Value2, 300) + expect_equal(fixture$combo_info$Diff_Value2, 102) + } + one_horizon <- if (recipe == "R2") fixture$data[fixture$data$Horizon == 1, ] else fixture$data + forecasts <- one_horizon[34:36, ] %>% + dplyr::transmute(Combo, Date, Train_Test_ID = 2, Forecast = Target, Target = Target_Original) + restored <- undifference_forecast(forecasts, fixture$data, fixture$combo_info) + expect_equal(restored$Target, actuals[34:36]) + expect_equal(restored$Forecast, cleaned[34:36]) + } + } +}) + +test_that("legacy second-order original data requires regeneration", { + fixture <- make_selection_history_recipe(as.numeric(101:136), difference_order = 2) + legacy <- fixture$combo_info[, c("Combo", "Diff_Value1", "Diff_Value2")] + expect_error( + undifference_recipe(fixture$data, legacy, fixture$hist_end_date), + "Regenerate prepared data from the original input" + ) + forecasts <- fixture$data[34:36, ] %>% + dplyr::transmute(Combo, Date, Train_Test_ID = 2, Forecast = Target, Target = Target_Original) + expect_error(undifference_forecast(forecasts, fixture$data, legacy), "Regenerate prepared data") + fixture$data$Target_Original <- NULL + expect_equal( + undifference_recipe(fixture$data, legacy, fixture$hist_end_date)$Target[1:36], + as.numeric(101:136) + ) +}) + +test_that("legacy first-order original data retains its common initial value", { + fixture <- make_selection_history_recipe(as.numeric(101:136), difference_order = 1) + legacy <- fixture$combo_info[, c("Combo", "Diff_Value1", "Diff_Value2")] + expect_equal( + undifference_recipe(fixture$data, legacy, fixture$hist_end_date)$Target_Original[1:36], + as.numeric(101:136) + ) +}) + +test_that("Box-Cox reconstruction preserves distinct original starting values", { + for (recipe in c("R1", "R2")) { + actuals <- as.numeric(101:136) + actuals[2] <- 300 + fixture <- make_selection_history_recipe(actuals, as.numeric(101:136), 2, TRUE, recipe) + result <- normalize_series_history( + fixture$data, fixture$hist_end_date, recipe, fixture$combo_info, + stationary = TRUE, box_cox = TRUE + ) + expect_equal(result$history, fixture$expected, tolerance = 1e-7) + } +}) diff --git a/tools/benchmark-forecast-selection.R b/tools/benchmark-forecast-selection.R new file mode 100644 index 00000000..567c8236 --- /dev/null +++ b/tools/benchmark-forecast-selection.R @@ -0,0 +1,168 @@ +Sys.setenv(NOT_CRAN = "false") +pkgload::load_all(quiet = TRUE, export_all = FALSE, helpers = FALSE) + +checkout <- normalizePath(".", winslash = "/", mustWork = TRUE) +fixtures <- new.env(parent = asNamespace("finnts")) +sys.source(file.path(checkout, "tests/testthat/helper-forecast-selection.R"), envir = fixtures) + +arguments <- commandArgs(trailingOnly = TRUE) +options <- list(mode = "selection", trials = "3", `max-average` = "3", `catalogue-limit` = "0", + sizes = "4,16,64,256,1024,4096,10000,20000", seed = "20260905", + `case-timeout` = "120", `total-timeout` = "1200") +for (argument in arguments) { + parts <- strsplit(sub("^--", "", argument), "=", fixed = TRUE)[[1]] + if (length(parts) != 2L || !parts[1] %in% names(options)) stop("Unsupported benchmark argument: ", argument) + options[[parts[1]]] <- parts[2] +} + +measure_catalogue_selection <- function(trial, catalogue, mixed = FALSE) { + setup <- system.time(fixture <- fixtures$make_catalogue_selection_fixture(trial, catalogue, mixed))[["elapsed"]] + timing <- new.env(parent = emptyenv()) + timing$starts <- 0L + timing$ends <- 0L + timing$average_seconds <- 0 + timing$evaluation_seconds <- 0 + timing$eligible <- 0L + timing$evaluations <- 0L + original_start <- getFromNamespace("par_start", "finnts") + original_end <- getFromNamespace("par_end", "finnts") + original_select <- getFromNamespace("select_series_forecasts", "finnts") + testthat::local_mocked_bindings( + par_start = function(...) { + timing$starts <- timing$starts + 1L + result <- original_start(...) + if (timing$starts == 2L) timing$average_started <- proc.time()[["elapsed"]] + result + }, + par_end = function(...) { + timing$ends <- timing$ends + 1L + if (timing$ends == 1L && !is.null(timing$average_started)) { + timing$average_seconds <- proc.time()[["elapsed"]] - timing$average_started + } + original_end(...) + }, + select_series_forecasts = function(...) { + started <- proc.time()[["elapsed"]] + result <- original_select(...) + timing$evaluation_seconds <- timing$evaluation_seconds + proc.time()[["elapsed"]] - started + timing$evaluations <- timing$evaluations + 1L + if (timing$evaluations == 1L) timing$eligible <- sum(result$rankings$Eligible) + result + }, + .package = "finnts" + ) + gc(reset = TRUE) + elapsed <- system.time(result <- finnts::final_models(fixture$run_info, + average_models = TRUE, max_model_average = 3, weekly_to_daily = FALSE, + parallel_processing = NULL, inner_parallel = FALSE, num_cores = 1)) + memory <- gc() + selection <- result$selections$Synthetic + averages <- choose(timing$eligible, 2) + choose(timing$eligible, 3) + stopifnot(timing$evaluations == 2L, timing$starts == if (timing$eligible >= 2L) 2L else 1L, + nrow(selection$rankings) == timing$eligible + averages, + !is.na(selection$selected_id), identical(length(result$rejected_combos), 0L)) + if (!mixed) stopifnot(timing$eligible == nrow(catalogue), all(selection$rankings$Eligible)) + if (averages > 0) { + saved <- finnts:::read_selection_file(fixture$run_info, "forecasts", "-average_models", "Synthetic") + stopifnot(length(unique(saved$Model_ID)) == 1L, all(is.finite(saved$Forecast))) + } + data.frame(Trial = trial, Mixed = mixed, Base_Candidates = nrow(catalogue), + Eligible = timing$eligible, Averages = averages, Ranked_Candidates = nrow(selection$rankings), + Setup_Seconds = setup, Average_Loop_Seconds = timing$average_seconds, + Evaluation_Seconds = timing$evaluation_seconds, Total_Seconds = elapsed[["elapsed"]], + User_Seconds = elapsed[["user.self"]], System_Seconds = elapsed[["sys.self"]], + Input_MiB = round(as.numeric(object.size(fixture)) / 1024^2, 1), + Result_MiB = round(as.numeric(object.size(result)) / 1024^2, 1), + Peak_Vector_MiB = round(memory["Vcells", 5] * 8 / 1024^2, 1)) +} + +run_hts_stress <- function() { + sizes <- as.integer(strsplit(options$sizes, ",", fixed = TRUE)[[1]]) + total_limit <- as.numeric(options[["total-timeout"]]) + case_limit <- as.numeric(options[["case-timeout"]]) + stopifnot(all(is.finite(sizes)), all(sizes >= 4), total_limit > 0, case_limit > 0) + core <- expand.grid(approach = c("standard_hierarchy", "grouped_hierarchy"), + placement = c("root", "aggregate", "leaf", "siblings", "all"), + pathology = c("magnitude", "trend", "level", "phase", "amplitude", "flatten"), + stringsAsFactors = FALSE) + cases <- lapply(seq_len(nrow(core)), function(index) as.list(core[index, ])) + corner_cases <- list( + list(pathology = "clean", shape = "flat"), list(pathology = "clean", shape = "noisy"), + list(pathology = "clean", shape = "zero"), list(pathology = "level", shape = "intermittent"), + list(pathology = "phase", history_cycles = 1L), list(pathology = "phase", history_cycles = 2L), + list(pathology = "trend", date_type = "day"), list(pathology = "level", date_type = "week"), + list(pathology = "amplitude", date_type = "quarter"), list(pathology = "trend", date_type = "year"), + list(pathology = "phase", horizon = 3L), list(pathology = "trend", horizon = 24L), + list(pathology = "level", shape = "signed"), list(pathology = "magnitude", recipe = "R2") + ) + cases <- c(cases, corner_cases) + started <- proc.time()[["elapsed"]] + results <- list() + execute_case <- function(specification, label) { + remaining <- total_limit - (proc.time()[["elapsed"]] - started) + if (remaining <= 0) return(list(Status = "total budget reached", Case = label)) + series_count <- specification$series_count + if (!is.null(series_count)) { + memory <- ps::ps_system_memory() + available <- if ("available" %in% names(memory)) memory[["available"]] else memory[["free"]] + estimated <- (series_count + 4 * ceiling(sqrt(series_count)) + 1) * 48 * 3 * 24 * 8 + if (available - estimated < 2 * 1024^3) return(list(Status = "memory preflight stopped", Case = label)) + } + tryCatch({ + result <- callr::r(function(checkout, specification, seed) { + Sys.setenv(NOT_CRAN = "false") + set.seed(seed) + pkgload::load_all(checkout, quiet = TRUE, helpers = FALSE) + helpers <- new.env(parent = asNamespace("finnts")) + sys.source(file.path(checkout, "tests/testthat/helper-forecast-selection.R"), envir = helpers) + fixture <- do.call(helpers$make_pre_reconciliation_case, specification) + helpers$measure_pre_selection_case(fixture) + }, args = list(checkout = checkout, specification = specification, seed = as.integer(options$seed)), + timeout = min(case_limit, remaining), show = FALSE) + c(list(Status = "completed", Case = label), as.list(result)) + }, error = function(error) list(Status = if (inherits(error, "callr_timeout_error")) "time safety stop" else "execution limit", + Case = label, Message = conditionMessage(error))) + } + for (case_index in seq_along(cases)) { + result <- execute_case(cases[[case_index]], paste0("paired-", case_index)) + results[[length(results) + 1L]] <- result + cat(jsonlite::toJSON(result, auto_unbox = TRUE, na = "null"), "\n") + if (result$Status == "total budget reached") break + } + for (approach in c("standard_hierarchy", "grouped_hierarchy")) { + for (series_count in sizes) { + result <- execute_case(list(approach = approach, series_count = series_count, + pathology = "level", placement = "leaf"), paste(approach, series_count, sep = "/")) + results[[length(results) + 1L]] <- result + cat(jsonlite::toJSON(result, auto_unbox = TRUE, na = "null"), "\n") + if (result$Status != "completed") break + } + } + cat("Stress observations are not a guarantee of improvement or a production runtime limit.\n") + invisible(results) +} + +if (options$mode == "selection") { + stopifnot(as.integer(options[["max-average"]]) == 3L, as.integer(options$trials) >= 1L) + catalogue <- fixtures$selection_benchmark_catalogue() + limit <- as.integer(options[["catalogue-limit"]]) + if (limit > 0L) catalogue <- utils::head(catalogue, limit) + stopifnot(nrow(catalogue) >= 3L) + cat("Catalogue candidates:", nrow(catalogue), "; pair/triple averages:", + choose(nrow(catalogue), 2) + choose(nrow(catalogue), 3), "\n") + results <- list() + for (trial in c("warmup", paste0("measured-", seq_len(as.integer(options$trials))), "mixed-quality")) { + cat("Starting", trial, "with fresh artifacts.\n") + measurement <- measure_catalogue_selection(trial, catalogue, mixed = trial == "mixed-quality") + print(measurement, row.names = FALSE) + results[[length(results) + 1L]] <- measurement + } + measured <- do.call(rbind, results) + measured <- measured[grepl("^measured-", measured$Trial), ] + cat("Measured full-call seconds: median", stats::median(measured$Total_Seconds), + "; maximum", max(measured$Total_Seconds), ". No elapsed-time cap was applied.\n") +} else if (options$mode == "hts-stress") { + run_hts_stress() +} else { + stop("Unsupported benchmark mode.") +} \ No newline at end of file diff --git a/tools/validate-agent-guidance.R b/tools/validate-agent-guidance.R index 6fe31c27..ab69cb60 100644 --- a/tools/validate-agent-guidance.R +++ b/tools/validate-agent-guidance.R @@ -226,6 +226,31 @@ if (length(present_forbidden_ignores) > 0) { ) } +build_ignore_patterns <- read_lines(".Rbuildignore") +build_ignore_patterns <- build_ignore_patterns[nzchar(build_ignore_patterns)] +excluded_from_build <- function(path) { + any(vapply(build_ignore_patterns, function(pattern) { + grepl(pattern, path, ignore.case = TRUE, perl = TRUE) + }, logical(1))) +} + +package_paths <- c( + "DESCRIPTION", "NAMESPACE", "R", "man", "tests", "tests/testthat", + workspace_files[grepl("^(R|man|tests)/", workspace_files)] +) +excluded_package_paths <- package_paths[vapply(package_paths, excluded_from_build, logical(1))] +if (length(excluded_package_paths) > 0) { + fail(".Rbuildignore excludes required package content: ", paste(excluded_package_paths, collapse = ", ")) +} + +development_directories <- c(".github", ".claude", ".agents", ".cursor") +included_directories <- development_directories[ + !vapply(development_directories, excluded_from_build, logical(1)) +] +if (length(included_directories) > 0) { + fail(".Rbuildignore must exclude development directories: ", paste(included_directories, collapse = ", ")) +} + adapter_environment <- new.env(parent = baseenv()) sys.source("tools/generate-agent-adapters.R", envir = adapter_environment) adapter_environment$check_agent_adapters() diff --git a/vignettes/ai-agent.Rmd b/vignettes/ai-agent.Rmd index fa718c63..b96c6ef7 100644 --- a/vignettes/ai-agent.Rmd +++ b/vignettes/ai-agent.Rmd @@ -161,7 +161,10 @@ What happens under the hood: - Chooses **seasonal period**, **missing/outlier** handling, **box-cox/differencing** strategy. - Sweeps **models** (local &/or global), backtests, **recipes** (lags/rolling/Fourier/date feats). - Optionally enables **external regressors** if they improve WMAPE. -- Stops early if MWAPE goal met; otherwise iterates (up to `max_iter`). +- Evaluates future quality when `final_models()` selects the winner within each iteration. Iteration ranking starts with the earliest minimum WMAPE and can prefer a later result within 10% relative when its average model WMAPE is lower. This preserves improvements across other models even when the current winner is unchanged, without repeating past future-quality checks. +- Stops early when a complete eligible winner meets the WMAPE goal; otherwise iterates up to `max_iter`. A soft warning does not impose another stopping veto, while hard-invalid or incomplete results cannot count as success. + +Reconciliation uses the selected forecasts and backtest residuals, not retained quality rankings. Incomplete selection retries rebuild averages and winner flags from existing predictions without retraining. All globally selected series share one winning global iteration, although their chosen models or averages can differ within it. Global updates preserve those saved subsets from that one run and check the newly produced forecasts before acceptance; they do not reintroduce every model from the original request or combine different global iterations. ### 6) Retrieve results @@ -174,7 +177,9 @@ head(fcst) ``` - `best_runs` summarizes, for each time series combo, the best run inputs when calling the Finn forecast process. -- `fcst` returns the consolidated forecast table (if hierarchical reconciliation was used, this is the reconciled output). +- `fcst` returns the consolidated forecast table. For hierarchical Agent runs, it contains only the final reconciled `Best-Model` forecast. Series can run and select different models, recipes, or averages during `iterate_forecast()`, so there is no complete per-model comparison hierarchy to publish. The best forecast is the reconciled combination of selected series forecasts, not necessarily one identical model family for every series. This best-only reconciled output also applies after `update_forecast()`; non-hierarchical candidate output is unchanged. + +For non-agentic hierarchical runs, use `get_forecast_data(run_info)` to retrieve every successfully saved per-model reconciled forecast plus `Best-Model`. Filter `Best_Model == "Yes"` when only the selected forecast is needed. --- @@ -289,11 +294,22 @@ answer <- ask_agent( What `update_forecast()` does: -- **Rebuilds global** models first (if used), then updates local series that need it. +- **Rebuilds global** models first (if used), requiring all global winners to reference one iteration, then updates local series that need it. Mixed global iteration metadata fails before refitting instead of dispatching several global updates. - **Handles new time series**: If new series appear in the data (up to 20% of existing series, floor of 10), simple forecasts are created automatically using default local model inputs—no LLM involvement needed. - **Handles failed time series**: If individual time series fail during the global or local model update (e.g., due to data issues or model errors), they are automatically re-forecast using the same default local model inputs as new series. If more than 20% of existing series (floor of 10) fail to update, the run errors out and directs you to use `iterate_forecast()` to retrain from scratch. +- **Checks reused forecasts before reconciliation**: The reuse path does not call `final_models()`. It invokes the shared evaluator after refitting and after any retuning, before a hierarchy is reconciled. Required components must pass hard eligibility and their selected combination must have no applicable future-quality concerns. An incomplete or rejected reused hierarchy is not solved; its covered current series follow the default-local path. Quality-rejected current series receive one default reforecast independently of the ordinary execution-failure limit. The default run uses `final_models()` and must pass both hard eligibility and applicable soft checks before success. Reforecasting many rejected series can increase runtime and provider cost. - Compares WMAPE to a trailing baseline of previous runs. If >40% of series are **>20% worse** than the previous run WMAPE, and `allow_iterate_forecast = TRUE`, it will **invoke the iterate loop** (bounded by `max_iter`) to recover accuracy. -- Re-runs reconciliation if hierarchy is in play. +- **Reconciles the selected mixture**: The existing `hts` solver produces bottom-level forecasts from the accepted selected source rows. Finn does not evaluate reconciled future outputs to replace the hierarchy with a uniform model family or trigger a late default-refitting loop. Solver and artifact errors remain errors; passing source quality checks is not a guarantee of future accuracy. + +Within each Agent iteration, `final_models()` selects candidates using accuracy and future-quality checks. The earliest minimum-WMAPE iteration anchors the comparison; a later eligible result within 10% relative can supply the next search context when its average model WMAPE is strictly lower. Local mean, median, and standard deviation describe the individual-model backtests, excluding simple averages; global summaries retain run WMAPE for mean and median and zero spread. ARIMA can therefore remain the best model while improved multivariate models after an xreg change preserve a promising search direction. That does not overwrite a better saved local forecast. Global promotion moves all global winners to one iteration together. Partial evaluations or interrupted writes cannot silently publish a mixed global selection. Normal goal stopping uses complete eligible results and four-decimal WMAPE, without a second soft-quality veto. Hierarchical comparisons use reconciled backtests, and recorded metrics avoid reassessing past future paths. Rejected evaluations still consume iteration budget. Newly generated update forecasts and default replacements retain the stricter acceptance checks described above. + +Within an iteration's accuracy allowance, candidates tied on risk and concern count can prefer smaller seasonal-amplitude distortion beyond historical cycle variation. That preference applies only when every tied candidate has an assessed score; missing evidence falls back to WMAPE. For hierarchical candidates, this preference applies at each source node before reconciliation; it does not rank completed Agent runs. Fidelity alone is not a quality rejection, a reason to keep iterating past the accuracy goal, or a trigger for default refitting. Repeated strong historical seasonality can support phase checks for informative horizons of at least three points even when they are shorter than a cycle. Unsupported seasonal checks remain unassessed. + +The shared evaluator can follow historically supported additive or proportional growth across long horizons. Two chronological historical comparisons must support the drift before it replaces the seasonal-naive or recent-median reference. Level uncertainty includes residual and slope variation; proportional paths use compatible log-scale trend and seasonal checks. Supported future magnitudes are screened against the larger of historical scale and the projected reference at each step, while backtest and fallback bounds remain unchanged. This uses existing prepared history, including retained imputation, and does not add an observation-provenance guarantee, a wider accuracy allowance, or another fitting loop. Complete saved winners are not retroactively rescored. + +Selection uses original actuals from exact prepared-data reads and keeps detailed rankings in memory. Native weekly and daily-expanded saved source forecasts reconstruct the same selection evidence; invalid values on later expanded days cannot disappear during weekly restoration. Only existing run bookkeeping records selected runs, evaluated/rejected status, and default-recovery acceptance for restart safety. No new quality-log files or serialized evaluation functions are created. + +See [Best Model Selection](best-model-selection.html) for the exact accuracy allowance, hard and soft checks, saved-average behavior, and the separate standard, iterative, and update workflows. Ordinary and iterative best-available soft-concern behavior is not the stricter acceptance rule used for update reuse and default replacements. --- @@ -308,7 +324,7 @@ What `update_forecast()` does: - `TRUE` detects the hierarchy and expands the input to all hierarchy levels before optimization. Those prepared levels use a single `ID` combo column, so all global and local iterations use `bottoms_up`; Finn then performs one - final reconciliation using the detected hierarchy. + final reconciliation using the detected hierarchy and publishes the bottom-level result without post-reconciliation quality selection. The detected structure can be *none*, *standard* (for example, Region → Country → SKU), or *grouped* (crossed dimensions). In either mode, hierarchical diff --git a/vignettes/best-model-selection.Rmd b/vignettes/best-model-selection.Rmd index 0b791151..887d082c 100644 --- a/vignettes/best-model-selection.Rmd +++ b/vignettes/best-model-selection.Rmd @@ -14,9 +14,141 @@ knitr::opts_chunk$set( ) ``` -The "Best-Model" you see in both the back testing and future forecast outputs are chosen based on what had the best accuracy over the back testing process. After all individual, ensemble, and average model forecast are created for both back testing and the future forecast, a weighted MAPE calculation is applied to each unique data combo and model combination. +The `Best_Model` flag identifies the selected forecast for each series. Finn first checks candidate validity, then balances backtest weighted MAPE with future-forecast plausibility. Individual models, learned ensembles, and simple averages are evaluated on the same series and expected backtest dates. -A standard MAPE calculation is produced first, then instead of a simple average to get the final MAPE a weighted MAPE is taken based on the size of the target variable value. Please see below for an example of the process. +## Future-forecast checks + +These checks apply to candidate base forecasts before reconciliation, including averages. Candidates with incomplete or non-finite predictions are ineligible. Backtests and future predictions without a supported trend are rejected when their absolute magnitude exceeds 100 times a positive robust historical scale. That scale uses the 95th percentile of absolute levels and robust level/change variation, not just the last observation. A supported trend supplies a pointwise future bound of `100 * max(robust_scale, abs(projected_reference))`, so sustained growth is not rejected merely for accumulating over a long horizon. The projection comes only from history, never from the candidate being screened. Existing finite-negative handling still follows `negative_forecast`, but missing or infinite predictions are no longer replaced with zero. + +Level and trend deviations beyond six robust reference scales create soft concerns. The reference uses the latest available `max(12, 3 * seasonal_period, 2 * forecast_horizon)` periods before the historical cutoff. Without supported drift, its path is seasonal naive when a complete seasonal cycle is available, otherwise a recent median level. The robust scale is the largest of the 95th percentile of absolute levels, level MAD, and one-step-change MAD. In that fallback, level-reference width is the larger of the relevant change MAD and 5% of that scale, multiplied by `6 * sqrt(horizon_step)` for the comparison. Supported drift instead supplies a projected center and a width reflecting residual noise and slope variation, described below. Trend checks compare median changes over matched historical and forecast spans, with a robust scale floor; proportional references perform those comparisons on log changes. + +With at least two complete finite historical cycles, a detrended seasonal profile can support additional checks. Seasonal strength must be at least 0.6 and the period at least three. For forecasts covering at least one cycle, negative profile correlation or amplitude outside one-third to three times historical amplitude creates a concern. Supported proportional trends use log-scale historical and forecast profiles, so constant proportional seasonality is not confused with growing absolute amplitude. Additive and fallback paths retain the original seasonal calculations. Unsupported checks remain unassessed. These are guardrails, not calibrated prediction intervals or guarantees of future accuracy. + +For a shorter horizon with at least three future points, Finn compares only the upcoming phases. Their historical range must exceed both three times the historical phase-residual MAD and 5% of the full historical seasonal amplitude. Finn removes the robust historical deseasonalized trend from the future path, rather than fitting a free trend through those few points. Negative correlation creates a phase concern only when future variation also exceeds that noise threshold. Full-cycle amplitude concern bounds are not applied to a partial cycle. + +One or two seasonal cycles remain usable. One cycle supplies a cautious reference, while repeated cycles support stronger comparisons. Weak seasonality, fewer than three future points, low-variation partial phases, and unavailable checks remain unassessed instead of making the series fail. Flat forecasts are not rejected simply because observations are noisy. + +| Check | Trigger | Effect | When Unassessed | +| --- | --- | --- | --- | +| Coverage | Missing, duplicate, or unexpected expected scenario/date keys in backtests or future predictions | Hard rejection | Never for a candidate being selected | +| Finite predictions | Any required `NA`, `NaN`, `Inf`, or `-Inf` prediction | Hard rejection | Never | +| Catastrophic magnitude | Absolute backtest or unsupported-trend future prediction exceeds `100 * robust_scale`; supported future step exceeds `100 * max(robust_scale, abs(projected_reference))` | Hard rejection | When historical scale is zero | +| Accuracy availability | No finite weighted MAPE from usable actuals | Hard rejection | Never | +| Level | Forecast departs from the supported trend reference, or seasonal-naive/recent-median fallback, beyond its horizon-adjusted width | Soft concern | Skipped after a hard failure | +| Zero-history level | A nonzero future forecast when the reference history is entirely zero | Soft `unsupported_level` concern | Zero forecasts pass; this is not a ratio-based hard rejection | +| Trend | Median forecast change differs from historical matched-span changes beyond six robust slope scales, using log changes for a supported proportional reference | Soft concern | Fewer than four matched periods, non-finite reference values, incompatible log-domain forecasts, or a hard failure | +| Seasonal amplitude | Future detrended amplitude is below one-third or above three times the historical profile | Soft concern | Insufficient cycles, strength below 0.6, period below three, short forecast, or zero historical profile amplitude | +| Seasonal phase | Future and historical profiles have negative correlation after the appropriate trend adjustment | Soft concern | Insufficient historical cycles or strength, period below three, undefined correlation, or insufficient points or signal for a partial horizon | +| Seasonal amplitude preference | Amplitude difference exceeds the tolerance learned from historical cycle variation | Tie-break only; no additional concern or rejection | Insufficient historical evidence, zero reference amplitude, or insufficient partial-horizon phase signal | + +For these checks the default seasonal period is daily `7`, weekly `52`, monthly `12`, quarterly `4`, and yearly `1`. If multiple seasonal periods are configured, the smallest valid integer greater than one is used. The checks do not independently validate every seasonal pattern a model can learn. The trend scale is the larger of historical matched-span slope MAD and `0.05 * working_scale / matched_span`. The working scale is the original normalized robust scale for additive or fallback paths, and the analogous robust scale of normalized log values for proportional paths. + +Each assessed soft check has a normalized excess score. Candidate risk is the maximum of the level, trend, and seasonality scores, not their average. The concern count counts the triggered reasons; seasonal phase and amplitude can contribute two reasons. Unassessed checks do not count as concerns. + +The separate in-memory `Seasonal_Fidelity` score measures amplitude distortion beyond historical variation. For the phases being assessed, let `reference_amplitude` be the reference profile range, `future_amplitude` the comparable future range, and `cycle_amplitudes` the ranges of centered historical cycle profiles. The tolerance is `max(3 * MAD(cycle_amplitudes), 0.05 * reference_amplitude)`. Fidelity is the finite nonnegative score `max(0, (abs(future_amplitude - reference_amplitude) - tolerance) / reference_amplitude)`. Insufficient evidence gives `NA`, not an artificial zero. A partial-horizon flat average can have an assessed amplitude preference even when its phase correlation is undefined. This score does not change risk or the concern count, and by itself cannot reject reuse, prevent accuracy-goal stopping, or trigger another fit. + +## Supported historical growth + +A trend reference requires at least `max(12, 3 * seasonal_period)` finite, regularly spaced prepared-history values in the existing reference window. Missing dates are not bridged, and missing values are not dropped to manufacture regular history. If explicit observation flags supplied to the evaluator identify missing or unobserved fitting values, trend support is declined. Existing prepared artifacts do not establish such provenance automatically; retained imputation is still part of their evidence. + +Finn compares at most two robust reference forms, without training any additional forecasting model: + +- Additive drift uses normalized target values. Drift is the median of same-phase changes divided by the seasonal period, or adjacent changes for nonseasonal yearly data. Phase intercepts are medians after removing that drift, rather than an extrapolation anchored to one last-point spike. +- Proportional drift applies the same method to `log(target) - log(normalization)`. It is considered only when all historical values are strictly positive and exceed `sqrt(.Machine$double.eps) * robust_scale`. Signed, zero, and relatively near-zero history is not shifted, clipped, or transformed with `log1p` to make this form fit. + +With period `p`, two chronological prefixes end at `n - 2q` and `n - q`, where `q = max(1, floor(p / 2))`. Each predicts the next `q` historical values and must contain at least `max(8, 2p)` training values. Drift must be nonzero, have the same sign in both prefixes and the full window, and exceed twice the MAD of its per-step slope estimates, with a numerical-precision floor. Each validation block must improve MAE by at least 20% over the no-drift reference on the same dates. Comparisons occur on the original target scale, normalized by a common factor for numerical stability. Proportional drift displaces an accepted additive reference only if it improves additive MAE by at least 20% in both blocks. Zero-error and negligible comparisons retain the simpler reference. These fixed support thresholds are engineering choices, not statistical confidence statements. + +For a supported reference, let `sigma_error` be the larger of its residual MAD and a noise floor, and `sigma_slope` the MAD of its per-step drift estimates. The additive floor is 5% of the existing normalized robust scale; the log-space floor is `log1p(0.05)`. At step `h`, the level-comparison width is: + +$$ +6\sqrt{h\,\sigma_{\mathrm{error}}^2+h^2\,\sigma_{\mathrm{slope}}^2}. +$$ + +Overlapping slope estimates are not treated as independent observations to shrink uncertainty. The projected center follows the supported drift and upcoming seasonal phase; it does not widen itself in response to candidate forecasts. Reference estimation is shared across candidates through the existing evaluation cache. Nonrepresentable reference projections fall back to the original checks instead of clipping forecasts or removing the magnitude bound. + +For example, a positive series with well-supported 2% monthly growth can have a reference near 126.8 after 12 months and 160.8 after 24 months when its current fitted level is 100 and it has no seasonal effect. Continuing that growth need not produce a level or absolute-slope penalty merely because the horizon is longer. A path that accelerates beyond the supported trajectory can still receive a concern or fail its pointwise magnitude bound. This reference is not substituted for the selected model's actual forecast. + +A finite zero or negative forecast under a supported proportional reference receives a `level_deviation` soft concern, while log-only slope and seasonal comparisons are unassessed. The forecast is not changed, and this does not introduce a new hard sign veto. Short, irregular, missing, or unstable histories and all-zero series retain the earlier fallback behavior. New scoring applies to newly evaluated predictions; a complete saved winner is still reused without retrospective reassessment. Unexpected regimes and mixed seasonal mechanisms can remain uncertain, and an eligible singleton with soft concerns can still win under the ordinary best-available policy. + +## Accuracy allowance + +After hard failures are excluded, let `best_wmape` be the smallest eligible weighted MAPE as a fraction. Candidates within `best_wmape + max(0.005, 0.05 * best_wmape)` form the shortlist. Selection prefers lower forecast risk, then fewer concerns. Within each risk-and-concern tie, smaller seasonal amplitude distortion precedes WMAPE only when every tied candidate has a finite assessed fidelity score. Otherwise that tie retains the existing WMAPE ordering. A stable candidate identifier breaks the final tie. Missing seasonal evidence is not rewarded as zero distortion. + +For example, with a best eligible WMAPE of 8.0%, the ceiling is 8.5%. A safer 8.3% candidate can beat a questionable 8.0% candidate, but an 8.8% candidate is outside the allowance. At 20% the ceiling is 21%; at 2% it is 2.5%. The absolute allowance is relatively generous for very accurate series and is an initial engineering default, not a calibrated statistical bound. + +For ordinary and iterative forecasts, when every shortlisted eligible candidate has soft concerns, Finn selects the best available one and reports them. When all candidates hard-fail, Finn raises an error. Update reuse and default replacements have a stricter acceptance boundary, described below. No policy can guarantee that a good forecast exists for every input. + +## Standard forecasts and saved averages + +`forecast_time_series()` finishes through `final_models()`. A manual standard workflow uses the same process when `final_models()` is called: + +1. Load prepared original-scale actuals and expected backtest/future dates. Future target values never become historical evidence. +2. Exclude candidates with missing or duplicate required keys, non-finite predictions, catastrophic magnitude, or unavailable finite WMAPE. A model with incomplete backtest coverage cannot win or enter a simple average. Learned-ensemble inputs are screened before fitting their existing ensemble specifications. +3. Form the requested simple averages from eligible existing predictions, up to `max_model_average`. A non-finite component is not concealed by averaging with `na.rm = TRUE`. +4. Evaluate the individual, learned-ensemble, and simple-average candidates on the same dates and actuals. Apply the accuracy allowance, then rank by risk, number of concerns, the supported seasonal-amplitude preference within ties, WMAPE, and stable model identifier. +5. Mark the delivered winner `Best_Model = "Yes"`. If it is an average, save that exact combination in the existing average-model artifact. Otherwise rank just the eligible averages by the same policy and save the winner of that subset with `Best_Model = "No"`. This is not necessarily the lowest-WMAPE average. If no eligible average can be formed, there is no required average artifact. +6. For hierarchical forecasts, pass the selected models at every prepared hierarchy node to the existing `hts` solver and publish its bottom-level result. Do not run another future-quality selection after reconciliation. Format intervals and any weekly-to-daily allocation using the existing output workflow. + +Individual outputs remain available with their best-model flags, but only the selected simple average is retained, not every computed combination. Standard forecasting selects among models already run; a quality failure does not fit an additional model automatically. + +On retry, Finn validates the combined saved outputs before reusing a winner. A `Best_Model` column, an average filename, or a finite completion log alone is insufficient. All individual models marked `"No"` can be correct when a complete saved average is marked `"Yes"`. Missing, incomplete, or ambiguous selection flags cause averages and selection to be rebuilt from existing predictions, without training again. Saved weekly outputs are restored to native cadence before recomputation. Complete winners are not re-evaluated for future quality, and a multi-series retry retains both previously completed and newly finalized results. A saved average whose original component outputs are unavailable requires restoration of those artifacts; it is not silently reconstructed from a different subset. + +## Reconciliation + +Quality-aware selection happens before reconciliation. Different hierarchy nodes can choose different models or averages. Finn reconciles that selected mixture with the existing `hts::combinef()` nodes/groups, residual weights, and nonnegative settings, then publishes the resulting bottom-level forecasts. + +There is no runtime plausibility scoring of reconciled future paths, no switch of the whole output to a uniform reconciled model family, and no replacement of individual bottom rows after the solve. Standard runs may still save per-model reconciled outputs for inspection, but those outputs are not automatically promoted by a post-reconciliation quality ranker. An outer Agent reconciliation solves its selected mixture directly. + +Reconciled backtests provide normal bottom-level WMAPE reporting and run comparison. The solver consumes selected forecast values, hierarchy structure, and residual-based weights, not quality rankings. A resumed run does not require every source node's prior ranking or repeat its future-quality assessment. Actual complete selected source forecasts are still required when a solve must run. Weekly source forecasts are evaluated at weekly cadence during selection, and a non-finite value on any daily-expanded forecast row remains non-finite when its weekly key is restored. + +Reconciliation can dampen, spread, or amplify a problem. Better base forecasts can improve bottom-level output, but passing the source checks is not a guarantee that every reconciled path is plausible. Solver and ordinary artifact errors remain errors. Test-only audits can measure the resulting forecasts without changing production selection. + +## Iterative Agent forecasts + +`iterate_forecast()` runs `final_models()` within each submitted forecast run. Iteration ranking starts with the earliest minimum-WMAPE result in the current Agent version. Later eligible iterations within 10% relative of that WMAPE can become the preferred search context when their `model_avg_wmape` is strictly lower; the lowest such average wins, with earlier ties retained. Missing or non-finite averages do not create an improvement. This is separate from the within-iteration 0.5-percentage-point/5% allowance: risk, concern count, and seasonal fidelity are not reassessed to rank past iterations. + +For local iterations, `model_avg_wmape`, `model_median_wmape`, and `model_std_wmape` summarize the individual model candidates' backtest WMAPEs, excluding simple-average forecasts. For example, ARIMA may remain best after adding an external regressor while the multivariate models improve. A lower average preserves that promising search direction because further iterations may make those models the winners; it is not a guarantee of future accuracy. Global summary fields retain their original meanings: overall run WMAPE for mean and median, and zero spread. Statistics use already-loaded current backtests; history comparisons reuse recorded metrics without reloading past forecasts. Unavailable local statistics are not fabricated from the selected model's score. + +Choosing an iteration's settings for further optimization is distinct from replacing a saved forecast: a better saved local forecast remains protected. Global promotion is decided once for the complete iteration, then all saved global winners move together even if one series individually worsens. All globally selected series must reference one `best_run_name`; they may still use different models or averages from that iteration. A partial global evaluation cannot promote only its successful series. Reload, finalization, and update reject mixed global iteration metadata, including inconsistent state left by interrupted writes, rather than silently using multiple global iterations. These per-series writes are not a storage transaction. Agent comparisons, saved WMAPE, and accuracy-goal decisions retain four-decimal precision. + +Normal accuracy-goal stopping and local optimization routing use completeness and WMAPE, without another soft-quality veto. Consequently, an iteration winner with soft concerns can beat an earlier winner or meet the accuracy goal; hard-invalid and incomplete results still cannot claim successful completion. Rejected runs consume iteration budget. At the limit, an eligible best-available result may be retained with concerns; if none exists, Finn fails or uses an already enabled local phase for unresolved global series. Final outer reconciliation does not initiate another quality-selection or refitting loop. Avoided evaluator calls and artifact reads are covered by tests; no fixed runtime reduction is promised. + +## Updated Agent forecasts + +`update_forecast()` follows a different fitting path but uses the same evaluator: + +1. Recover the previously selected single model or average for each series from its saved source forecasts. All globally selected series must reference one winning global iteration; mixed iteration metadata fails before any global refit. Refit only the union of required components from that run with their saved settings; do not average all models listed in the earlier request. Different series or hierarchy source nodes can retain different subsets within that one iteration. Missing or ambiguous selected identities or saved fits require restoring the original artifacts. Reused fits do not call `final_models()` to search over a new candidate pool. +2. Assemble component and reused-average forecasts without reconciling them. Check every required component for hard eligibility and the selected reused combination for applicable soft concerns. Repeat before reconciliation after any existing WMAPE-triggered retuning. Passing reuse keeps that original chosen combination; it does not silently swap to another component. +3. Deduplicate quality-rejected current series into the existing new-series/default-local forecast path. Healthy siblings are retained and removed series are excluded. Quality-only rejections do not consume the ordinary execution-failure cap of `max(10, ceiling(0.20 * existing_series))`. +4. Run `final_models()` for each default replacement, then require the replacement to pass all applicable quality checks. Short-history checks that cannot be assessed do not count as failures. Good backtest accuracy alone cannot publish a still-questionable replacement. +5. An inner reused hierarchical candidate needs its complete source-node forecast set. If a node is rejected or the hierarchy is incomplete, do not solve a partial hierarchy; send the candidate's covered current series through the existing default-local path. Accepted hierarchies reconcile only the selected rows, not both components and their average together. Existing-format source forecast files retain selected component identities for subsequent updates, not a required diagnostic ranking snapshot. +6. If outer reconciliation is required, reconcile the selected forecasts once and publish its result without a post-quality switch or late default reforecast. A default replacement rejected before reconciliation raises an explicit quality error and cannot trigger repeated fitting. Stable default run identities and an acceptance/rejection field in existing run logs preserve that boundary across restarts. + +The optional accuracy-degradation `allow_iterate_forecast` workflow remains separate. Checks after refit or retune assess newly generated predictions, not old iteration winners. A default's saved acceptance or rejection prevents repeating that acceptance decision after it has completed; an interrupted acceptance step can still assess the new output once. Quality recovery itself does not ask the LLM to waive a check. Default refitting can increase compute or configured-provider cost, and it is a bounded recovery attempt rather than a promise of a satisfactory forecast. + +## Evidence and limitations + +Developer tests compare two paths on the same fake candidate outputs: accuracy-only selection followed by real `hts`, and quality-aware selection/averaging followed by real `hts`. Held-out future truth is used only by the tests, never supplied to the selector. They measure bottom-level error and shape, including effects on uninjected siblings. Small regressions run with package tests; broader stress and full-catalogue averaging timings are separate developer experiments. + +A separate bounded, in-memory corner-test matrix checks exact prediction keys, signed/zero/missing-actual accuracy, threshold boundaries, seasonal alignment, optional-score ties, weekly group isolation, and replacement-selector contracts. Fixed-seed cases also check independent accuracy and ranking expectations, row-order invariance, and the inability of a hard-invalid candidate to displace a valid winner. These tests do not fit forecast models or run additional reconciliation, and passing them is not proof that every possible input or future regime change is handled correctly. + +Earlier experiments exposed half-amplitude averages and short-horizon phase reversals that the original concern checks did not distinguish. Focused regressions now prefer an intact available seasonal candidate within the accuracy allowance and assess informative partial horizons using repeated historical evidence. Controls retain naturally varying seasonal amplitudes within the history-adaptive tolerance. These results do not calibrate a guarantee: one-cycle histories, fewer than three future points, or low-signal partial phases can still retain reversed timing because assessment is unsupported. A plausible alternative outside the WMAPE allowance cannot win a soft-risk or fidelity comparison. Unexpected regime changes are not known in advance, and the existing nonnegative solver floor can produce small positive values for all-zero histories. None of these limits invokes a post-reconciliation replacement model. + +The number of simple averages grows as `choose(N, 2) + choose(N, 3)` when `max_model_average = 3`. The normal smoke test uses four mixed model/recipe candidates and independently checks all ten pair/triple averages. The separate developer timing workload uses every supported model/recipe output and reports averaging and evaluation separately, with fresh artifacts for every trial. Earlier timing and broad stress measurements predate the refined seasonal ranking; they are not new measurements of this revision. No new elapsed-time assertion or production timeout is added. Runtime depends on candidate count, horizon, backtests, storage, and the machine; measurements should precede any future regression limit. + +## Historical actuals + +Checks use the existing prepared data for each series, preferring R1 when prepared and otherwise normalizing R2's `Horizon == 1` rows. Differencing and Box-Cox are reversed using existing metadata. `Target_Original` is used when available so outlier cleaning does not change the actuals used for evaluation; otherwise `Target` is used. Prior missing-value imputation is retained. Recipe and metadata files are read by exact path, without directory listing, and history is reused in memory across candidates. + +Selection requires at least one candidate and at least one finite actual inside the recent reference window. An empty candidate pool or a reference window containing only missing/non-finite actuals raises a clear input error. Finite observations farther back, or future target values, cannot silently supply that window's evidence. Partly missing windows remain usable when a finite value, including zero, is present; unavailable seasonal checks remain unassessed, and missing backtest actuals continue to receive no accuracy weight. + +Original and cleaned targets have separate inverse-differencing starting values. Older second-order original-target artifacts missing those values must be regenerated from original input; already saved forecast outputs remain readable. + +Rankings and explanations are held in memory. No additional diagnostic or reference files are written. The selector has an internal replaceable function contract; a public per-run custom-evaluator API is not included in this release. + +## Backtest weighted MAPE + +A pointwise absolute percentage error is produced first, rounded to four decimal places, then weighted by the absolute actual value across expected backtest rows. The existing convention replaces zero actuals with `0.1` for this calculation. Original actuals are matched by date; missing/non-finite actuals do not contribute weight, and a candidate without a finite accuracy score is ineligible. Overlapping backtests keep their separate scenario/horizon observations. The positive-target example below illustrates the weighting. ```{r, echo = FALSE, message = TRUE} suppressMessages(library(dplyr)) @@ -30,13 +162,13 @@ back_test_tbl <- tibble( Target = c(10, 20, 30, 40, 50, 10, 20, 30, 40, 50) ) %>% dplyr::mutate( - MAPE = abs(Target - FCST) / Target, + MAPE = round(abs(Target - FCST) / abs(Target), 4), Date = as.Date(Date) ) %>% dplyr::group_by(Combo, Model) %>% dplyr::mutate( - Target_Total = sum(Target), - Percent_Total = Target / Target_Total + Target_Total = sum(abs(Target)), + Percent_Total = abs(Target) / Target_Total ) %>% dplyr::ungroup() @@ -59,4 +191,4 @@ print(best_model) During the simple back test process above, arima seems to be the better model from a pure MAPE perspective, but ETS ends up being the winner when using weighted MAPE. The benefits of weighted MAPE allow finnts to find the optimal model that performs the best on the biggest components of a forecast, which comes with the added benefit of putting more weight on more recent observations since those are more likely to have larger target values then ones further into the past. Another way of putting more weight on more recent observations is how Finn overlaps its back testing scenarios. This means the most recent observations are tested for accuracy in different forecast horizons (H=1, H=2, etc). More info on this in the back testing vignette. -User of Finn can also take the Finn outputs, create their own accuracy metrics, and choose their own best models since all model results are written to disk. +Users can evaluate the retained model outputs with their own metrics and choose another model. The internal selector is replaceable, but this release does not expose a public per-run evaluator or persist custom selection functions. diff --git a/vignettes/hierarchical-forecasting.Rmd b/vignettes/hierarchical-forecasting.Rmd index f6c7abaf..79c34a5a 100644 --- a/vignettes/hierarchical-forecasting.Rmd +++ b/vignettes/hierarchical-forecasting.Rmd @@ -37,7 +37,9 @@ hts <- tibble( print(hts) ``` -In the above example, "City" was the lowest level of the hierarchy, which feeds into "Country", which then feeds into "Continent". Finn will take this data and will forecast by City, total Country, and total Continent. After each model is ran for every level in the hierarchy, the best model is chosen at each level, then the "Best Model" and every other model is reconciled back down to the lowest level. +In the above example, "City" was the lowest level of the hierarchy, which feeds into "Country", which then feeds into "Continent". For a non-agentic run, Finn forecasts each model at the prepared hierarchy levels, selects the best forecast at each level, and reconciles both the selected combination and the individual models back down to the lowest level. `get_forecast_data(run_info)` returns every successfully saved per-model reconciled forecast plus `Best-Model`. Models that fail to produce a reconciled artifact are not fabricated in the result. Filter `Best_Model == "Yes"` to retain only the reconciled selected forecast. + +Agentic runs use a different output contract. During `iterate_forecast()`, different series can run and select different model sets, recipes, or averages. Finn therefore reconciles the selected forecasts together, and `get_agent_forecast(agent_info)` returns only that final reconciled `Best-Model` forecast, not a reconciled comparison table for every model. `Best-Model` can combine different winners across series; it does not mean that the same model family won everywhere. This distinction applies to both standard and grouped hierarchies and to Agent forecast updates. ### Grouped Hierarchy