From af519c4eda9c18ab066bccbb75b6769dccf55066 Mon Sep 17 00:00:00 2001 From: Claude Date: Tue, 29 Sep 2026 13:15:29 +0000 Subject: [PATCH] Add backtest checkpoints and backtest_combine(); require newer dependencies nowcast_backtest(checkpoint_file = ) saves each finished (engine, date) fit so an interrupted backtest resumes (#90). Only the main R session writes the file, through a temporary file and a rename, so every future plan is safe with parallel = TRUE; fits then run and are saved in waves of nbrOfWorkers(). A fingerprint of the data, seed, keep_draws, truth settings and each engine makes a mismatched call abort instead of mixing backtests; failed fits are retried. backtest_combine() joins backtests run separately -- other engines on the same dates, or the same engines on new dates -- into the object one call would have produced (#91). It aborts on a repeated (method, date) fit or on backtests that differ in strata, truth settings or quantile levels, and only_common_dates = TRUE keeps just the dates every method has. Dependencies: declare minimum versions in DESCRIPTION so that old installs fail at install time instead of in the tests: dplyr (>= 1.1.0) for `.by`, rlang (>= 1.0.0) for hash(), and tidyselect (>= 1.2.1), whose 1.2.0 gives a different error message that test-changers.R asserts on. Fix .batch_restore_date_class(): on older R (seen on R 4.3.3) setdiff() on Dates returns plain numbers and match() cannot compare them with dates, so simulate_batch() always aborted with "Every report date is closed". It now compares the numeric values. Bump the version to 1.1.1. Update NEWS.md, SKILL.md and DEVELOPMENT_SKILL.md (backtest checkpoints and combining, and testing against current R and packages), and add a backtest_combine tip to the ensemble vignette. Co-Authored-By: Claude Sonnet 5.5 Claude-Session: https://claude.ai/code/session_01DW8xQ7pmptZYEJCb8KkEox --- DESCRIPTION | 8 +- DEVELOPMENT_SKILL.md | 40 +++ NAMESPACE | 1 + NEWS.md | 29 ++ R/backtest_checkpoint.R | 329 +++++++++++++++++ R/backtest_combine.R | 311 ++++++++++++++++ R/nowcast_score.R | 68 +++- R/simulate_batch.R | 7 +- SKILL.md | 15 + _pkgdown.yml | 1 + man/backtest_combine.Rd | 99 ++++++ man/nowcast_backtest.Rd | 54 ++- tests/testthat/test-backtest-checkpoint.R | 392 +++++++++++++++++++++ tests/testthat/test-backtest-combine.R | 232 ++++++++++++ tests/testthat/test-batch_screen.R | 13 + vignettes/articles/ensemble-nowcasting.Rmd | 4 + 16 files changed, 1592 insertions(+), 11 deletions(-) create mode 100644 R/backtest_checkpoint.R create mode 100644 R/backtest_combine.R create mode 100644 man/backtest_combine.Rd create mode 100644 tests/testthat/test-backtest-checkpoint.R create mode 100644 tests/testthat/test-backtest-combine.R diff --git a/DESCRIPTION b/DESCRIPTION index 3ed347d8..a45cd3ad 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: tbl.now Type: Package Title: Tidy Data and Workflow Layer for Epidemic Nowcasting -Version: 1.1.0 +Version: 1.1.1 Authors@R: c(person("Rodrigo", "Zepeda-Tello", , "rzepeda17@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-4471-5270")), @@ -60,19 +60,19 @@ Imports: cli, generics, grid, - dplyr, + dplyr (>= 1.1.0), ggplot2, lifecycle, lubridate, methods, pillar, - rlang, + rlang (>= 1.0.0), S7, scales, stats, tibble, tidyr, - tidyselect, + tidyselect (>= 1.2.1), utils URL: https://rodrigozepeda.github.io/tbl.now/, https://github.com/RodrigoZepeda/tbl.now diff --git a/DEVELOPMENT_SKILL.md b/DEVELOPMENT_SKILL.md index 80c62425..479bde98 100644 --- a/DEVELOPMENT_SKILL.md +++ b/DEVELOPMENT_SKILL.md @@ -181,6 +181,46 @@ S7 class names can contain `::`, which S3 method names cannot represent. Use the existing `.onLoad()` registration pattern where required. Re-export `generics::tidy`; do not create a competing generic. +## Backtests, checkpoints and combining + +`nowcast_backtest()` fits every (engine, date) pair, dates outer and engines +inner. Two features are built on that order and must keep working when the +backtest changes: + +- **`backtest_combine()`** joins backtests run separately -- other engines on + the same dates, or the same engines on new dates. Combining what one call + would have produced must return that call's object: same rows in the same + order, same `methods`, `now_dates`, `timings` and `truth`, differing only in + `elapsed_seconds`. Test that equality, with strata and a grouped `tbl_now`. + A (method, `now`) fit in two backtests aborts, a success replaces a failure of + the same fit, and backtests that differ in event date, strata, `truth_axis`, + `truth_type`, `keep_draws` or quantile levels are refused. If you add a field + or table to the `nowcast_backtest` object, teach `backtest_combine()` to + combine it. +- **`checkpoint_file`** lets an interrupted backtest resume. Only the main R + session touches the file; `future` workers return their fits and never see + the path, so every plan is safe. Never write from a worker, and never write + in place: write a temporary file beside it and rename. The file stores a + fingerprint of everything a fit depends on (data, `seed`, `keep_draws`, truth + settings, each engine by label); a mismatch aborts rather than mixing + backtests. A new argument that changes what a fit computes must join the + fingerprint. Failed fits are stored but retried on resume. A resumed backtest + must equal an uninterrupted one. + +Test both under `parallel = TRUE` with a sequential plan and, where the +installed package is the code under test, real `multisession` workers. + +## Dependencies and the environment + +Test on the versions CI uses (the current R release and current CRAN +packages), not an old container. A failure that only an old R or old dependency +shows is a missing minimum: declare it with `>=` in `DESCRIPTION` (`Depends`, +`Imports` or `Suggests`) rather than working around it in the code, and say so +in the commit message. Give a minimum to every package whose newer function or +argument the code uses (`rlang::hash()` needs rlang 1.0.0, `.by` in dplyr needs +1.1.0). Compiled packages built under an older R do not load in a newer one; +reinstall them after upgrading R. + ## Summaries and diagnostics `validate_tbl_now()` and `diagnose()` share `.tbl_now_findings()`. Add structural diff --git a/NAMESPACE b/NAMESPACE index fc3f2cf9..28973a16 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -114,6 +114,7 @@ export(align_weeks) export(as_tbl_now) export(as_tibble) export(autoplot) +export(backtest_combine) export(cases_per_date) export(censor_reporting_delays) export(censor_reporting_delays_above) diff --git a/NEWS.md b/NEWS.md index dc05645f..a490c477 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,32 @@ +# tbl.now 1.1.1 + +## `simulate_batch()` works on older R versions + +`simulate_batch()` aborted with "Every report date is closed" on older R +versions (seen on R 4.3.3) whatever `closed_dates` was, because `setdiff()` +returns plain numbers there and `match()` cannot compare them with dates. The +open dates are now recovered from their numeric values, which is correct on +every R version. + +## `nowcast_backtest()` can resume, and backtests can be combined + +`nowcast_backtest()` gains `checkpoint_file` (#90). Each finished +(engine, date) fit is saved to that file; running the same call again refits +only the fits that are missing, and a fit that failed is retried. The file +records a fingerprint of the data, `seed`, `keep_draws`, the truth settings and +each engine, and a call that differs from it aborts rather than mixing fits from +two backtests; new `now_dates` and new engines are added to it. Only the main R +session writes the file (through a temporary file and a rename), so every +`future::plan()` is safe with `parallel = TRUE`, which then runs and saves the +fits in waves of `future::nbrOfWorkers()`. + +The new `backtest_combine()` joins backtests that were run separately (#91): +different models on the same dates, the same model on new dates, or both. Combining +what one call would have produced gives the same object as that call. It aborts +when a (method, date) fit appears twice or when the backtests differ in strata, +`truth_axis`, `truth_type`, `keep_draws` or quantile levels, and +`only_common_dates = TRUE` keeps only the dates every method has. + # tbl.now 1.1.0 ## Breaking: backtest methods are compared on the targets all of them scored diff --git a/R/backtest_checkpoint.R b/R/backtest_checkpoint.R new file mode 100644 index 00000000..39f41474 --- /dev/null +++ b/R/backtest_checkpoint.R @@ -0,0 +1,329 @@ +# Checkpointing for `nowcast_backtest()`. +# +# One rule keeps this safe under every `future` plan: ONLY THE MAIN R SESSION +# TOUCHES THE FILE. A worker (`multisession`, `cluster`, ...) returns its fit like +# any other value and never sees the path, so there is nothing for two processes +# to fight over and no assumption that workers share a filesystem. The main +# session reads the file once before the fits and rewrites it after each wave of +# finished fits, through a temporary file and a rename, so an interruption in the +# middle of a write leaves the previous checkpoint intact. +# +# The file is one list: +# version 1L +# fingerprint what the fits were computed from (see `.backtest_fingerprint()`) +# fits a list of `list(label, now, fit)`, where `fit` is exactly what +# `.backtest_fit()` returns (`timing` and `result`) + +#' Validate `checkpoint_file` +#' +#' @param checkpoint_file The user's `checkpoint_file`. +#' +#' @return `NULL`, invisibly. +#' +#' @keywords internal +#' @noRd +.check_checkpoint_file <- function(checkpoint_file) { + if (is.null(checkpoint_file)) { + return(invisible(NULL)) + } + if (!is.character(checkpoint_file) || length(checkpoint_file) != 1L || + is.na(checkpoint_file) || !nzchar(checkpoint_file)) { + cli::cli_abort( + "{.arg checkpoint_file} must be a single file path, or {.code NULL}." + ) + } + if (dir.exists(checkpoint_file)) { + cli::cli_abort(c( + "{.arg checkpoint_file} must be a file, not a directory.", + "x" = "{.path {checkpoint_file}} is a directory." + )) + } + invisible(NULL) +} + +#' Reduce an object to something that hashes the same in every session +#' +#' An engine argument can be a function or formula, and hashing one drags in its +#' environment -- which differs between sessions even when nothing meaningful +#' changed. Functions, formulas and calls are replaced by their source text and +#' environments by a placeholder; everything else is left alone. +#' +#' @param x Any object. +#' +#' @return An object that [rlang::hash()] can fingerprint. +#' +#' @keywords internal +#' @noRd +.stable_form <- function(x) { + if (is.function(x) || is.language(x)) { + return(paste(deparse(x), collapse = "\n")) + } + if (is.environment(x)) { + return("") + } + if (is.list(x)) { + return(lapply(x, .stable_form)) + } + x +} + +#' What a backtest's fits were computed from +#' +#' Everything that, if changed, would make a saved fit answer a different +#' question. `now_dates` is deliberately absent -- fits at other dates can be +#' added to a checkpoint -- and so is `parallel`, which does not change the fits. +#' Engines are fingerprinted one by one, by label, so an engine can be added to +#' a checkpoint without invalidating the others. +#' +#' @param x The full `tbl_now`. +#' @param engines The labelled engines from `.collect_engines()`. +#' @param seed,keep_draws,truth_axis,truth_type As in [nowcast_backtest()]. +#' +#' @return A list. +#' +#' @keywords internal +#' @noRd +.backtest_fingerprint <- function(x, engines, seed, keep_draws, truth_axis, + truth_type) { + plain <- dplyr::as_tibble(ungroup(x)) + data <- rlang::hash(list( + columns = as.list(plain), + now = get_now(x), + event_date = get_event_date(x), + report_date = get_report_date(x), + case_count = get_case_count(x), + strata = get_strata(x), + data_type = get_data_type(x) + )) + engine_hash <- vapply(engines, function(e) { + # The label is the lookup key, not part of the model. + e$label <- NULL + rlang::hash(.stable_form(unclass(e))) + }, character(1)) + + list( + data = data, + seed = if (is.null(seed)) NULL else as.numeric(seed), + keep_draws = isTRUE(keep_draws), + truth_axis = truth_axis, + truth_type = truth_type, + engines = engine_hash + ) +} + +#' Read a checkpoint +#' +#' @param file Path to the checkpoint. +#' +#' @return The saved state, or `NULL` when there is no file yet. +#' +#' @keywords internal +#' @noRd +.checkpoint_read <- function(file) { + if (!file.exists(file)) { + return(NULL) + } + state <- tryCatch(readRDS(file), error = function(e) e) + valid <- !inherits(state, "error") && is.list(state) && + identical(state$version, 1L) && + all(c("fingerprint", "fits") %in% names(state)) + if (!valid) { + cli::cli_abort(c( + "{.path {file}} is not a {.fn nowcast_backtest} checkpoint.", + "i" = "Delete it, or choose another {.arg checkpoint_file}, to start a \\ + new backtest." + )) + } + state +} + +#' Write a checkpoint without ever leaving a half-written file +#' +#' Writes to a temporary file in the same folder and renames it over the target. +#' Called only from the main R session; see the note at the top of this file. +#' +#' @param file Path to the checkpoint. +#' @param state The state to save. +#' +#' @return `NULL`, invisibly. +#' +#' @keywords internal +#' @noRd +.checkpoint_write <- function(file, state) { + folder <- dirname(file) + if (!dir.exists(folder)) { + dir.create(folder, recursive = TRUE, showWarnings = FALSE) + } + temporary <- tempfile( + pattern = paste0(".", basename(file), "-"), tmpdir = folder, + fileext = ".tmp" + ) + on.exit(unlink(temporary), add = TRUE) + + written <- tryCatch( + { + saveRDS(state, temporary) + TRUE + }, + error = function(e) FALSE, + warning = function(w) FALSE + ) + # `file.rename()` is atomic within a filesystem. Where it cannot replace an + # existing file (some Windows setups) fall back to copying over it. + moved <- written && (suppressWarnings(file.rename(temporary, file)) || + isTRUE(suppressWarnings(file.copy(temporary, file, overwrite = TRUE)))) + if (!moved) { + cli::cli_abort(c( + "Could not write the checkpoint to {.path {file}}.", + "i" = "Check that the folder exists and is writable." + )) + } + invisible(NULL) +} + +#' Check a saved checkpoint against the current call +#' +#' @param state The saved state. +#' @param current The current `.backtest_fingerprint()`. +#' @param file The checkpoint path, for the message. +#' +#' @return `state`, with the fingerprint's engines updated to include the +#' current ones. Aborts when the checkpoint came from a different backtest. +#' +#' @keywords internal +#' @noRd +.checkpoint_reconcile <- function(state, current, file) { + saved <- state$fingerprint + + described <- c( + data = "the data", seed = "{.arg seed}", + keep_draws = "{.arg keep_draws}", truth_axis = "{.arg truth_axis}", + truth_type = "{.arg truth_type}" + ) + changed <- names(described)[!vapply( + names(described), function(field) identical(saved[[field]], current[[field]]), + logical(1) + )] + shared <- intersect(names(saved$engines), names(current$engines)) + changed_engines <- shared[saved$engines[shared] != current$engines[shared]] + + if (length(changed) > 0L || length(changed_engines) > 0L) { + bullets <- c( + unname(described[changed]), + if (length(changed_engines) > 0L) { + "the engine{?s} {.val {changed_engines}}" + } + ) + names(bullets) <- rep("x", length(bullets)) + cli::cli_abort(c( + "The checkpoint {.path {file}} was made by a different backtest.", + "!" = "These differ from the checkpoint:", + bullets, + "i" = "Resuming would mix fits from two different backtests. Use a new \\ + {.arg checkpoint_file}, or delete this one, to start again." + )) + } + + state$fingerprint$engines <- c( + saved$engines[setdiff(names(saved$engines), names(current$engines))], + current$engines + ) + state +} + +#' Where a fit is in the checkpoint +#' +#' @param fits The `fits` list of a checkpoint. +#' @param label,now_date The engine label and retrospective date. +#' +#' @return The position, or `0L`. +#' +#' @keywords internal +#' @noRd +.checkpoint_position <- function(fits, label, now_date) { + hit <- which(vapply(fits, function(entry) { + identical(entry$label, label) && as.numeric(entry$now) == as.numeric(now_date) + }, logical(1))) + if (length(hit) == 0L) 0L else hit[[1]] +} + +#' Run the backtest fits, saving them as they finish +#' +#' Without a checkpoint this is the plain sequential or parallel map. With one, +#' the fits already saved are reused and the rest run in waves -- one fit at a +#' time sequentially, `future::nbrOfWorkers()` at a time in parallel -- with the +#' file updated after each wave. A fit that failed is retried, not reused. +#' +#' @param tasks The list of backtest tasks, in output order. +#' @param fit_args A list of the remaining `.backtest_fit()` arguments. +#' @param parallel Whether to run the fits with `future`. +#' @param checkpoint `NULL`, or a list with `file` and `fingerprint`. +#' @param verbose Whether to report progress. +#' +#' @return A list of `.backtest_fit()` results, one per task, in task order. +#' +#' @keywords internal +#' @noRd +.backtest_run_tasks <- function(tasks, fit_args, parallel, checkpoint = NULL, + verbose = TRUE) { + run_wave <- function(wave) { + if (parallel) { + .backtest_parallel_map(wave, fit_args) + } else { + lapply(wave, .backtest_run_task, fit_args = fit_args) + } + } + if (is.null(checkpoint)) { + return(run_wave(tasks)) + } + + file <- checkpoint$file + state <- .checkpoint_read(file) + state <- if (is.null(state)) { + list(version = 1L, fingerprint = checkpoint$fingerprint, fits = list()) + } else { + .checkpoint_reconcile(state, checkpoint$fingerprint, file) + } + + done <- vapply(tasks, function(task) { + position <- .checkpoint_position(state$fits, task$label, task$now_date) + position > 0L && !is.null(state$fits[[position]]$fit$result) + }, logical(1)) + pending <- tasks[!done] + + if (isTRUE(verbose) && length(tasks) > 0L && any(done)) { + cli::cli_alert_info( + "Resuming from {.path {file}}: {sum(done)} of {length(tasks)} fit{?s} \\ + already done." + ) + } + + if (length(pending) > 0L) { + # Written before the first fit, so an unwritable path fails now rather than + # after hours of fitting. + .checkpoint_write(file, state) + + wave_size <- if (parallel) max(1L, as.integer(future::nbrOfWorkers())) else 1L + for (start in seq(1L, length(pending), by = wave_size)) { + wave <- pending[start:min(length(pending), start + wave_size - 1L)] + fits <- run_wave(wave) + for (i in seq_along(wave)) { + entry <- list( + label = wave[[i]]$label, now = wave[[i]]$now_date, fit = fits[[i]] + ) + position <- .checkpoint_position( + state$fits, entry$label, entry$now + ) + if (position == 0L) { + position <- length(state$fits) + 1L + } + state$fits[[position]] <- entry + } + .checkpoint_write(file, state) + } + } + + lapply(tasks, function(task) { + state$fits[[.checkpoint_position(state$fits, task$label, task$now_date)]]$fit + }) +} diff --git a/R/backtest_combine.R b/R/backtest_combine.R new file mode 100644 index 00000000..118a13d7 --- /dev/null +++ b/R/backtest_combine.R @@ -0,0 +1,311 @@ +#' Combine backtests +#' +#' @description `r lifecycle::badge('experimental')` +#' +#' Joins [nowcast_backtest()] results that were run separately into one, so that +#' an expensive backtest never has to be repeated: +#' +#' * **Different models, same dates.** Backtest each engine on its own (perhaps +#' on different machines, or as it becomes available) and combine them to +#' compare their scores, derive [nowcast_weights()] or build a +#' [nowcast_ensemble()]. +#' * **Same model, different dates.** Backtest last year's dates once, and next +#' year backtest only the new dates and add them to the old result. +#' +#' Combining backtests of *the same data, dates and engines* gives the object a +#' single call would have -- the tables have the same rows in the same order: +#' +#' ```r +#' bt1 <- nowcast_backtest(x, engine_a, now_dates = my_dates) +#' bt2 <- nowcast_backtest(x, engine_b, now_dates = my_dates) +#' backtest_combine(bt1, bt2) +#' # is the same as +#' nowcast_backtest(x, engine_a, engine_b, now_dates = my_dates) +#' ``` +#' +#' (Only the `elapsed_seconds` of the `timings` differ.) +#' +#' @details +#' The backtests must agree on the event date, the strata, `truth_axis`, +#' `truth_type`, `keep_draws` and the quantile levels; otherwise they are not +#' measuring the same thing and the call aborts. +#' +#' Two backtests must not both have a successful fit of the same method at the +#' same `now` date: that would be two answers to one question, so the call +#' aborts. A fit that *failed* in one and succeeded in another is fine -- the +#' success is kept, which lets you re-run only the failures and combine. +#' +#' Scores are kept as they were computed. When the backtests were run at +#' different times the data may have been revised in between, so each was +#' scored against its own `truth`. The combined `truth` is the one from the +#' backtest with the latest `now` date, extended with any event dates only the +#' others have; the call warns when an event date it shares has a different +#' observed count in the others. Re-run the earlier backtest if you need every +#' score against the same truth. +#' +#' Methods that cover different dates are allowed (that is how you add dates to +#' one model only), and comparisons -- [nowcast_weights()], the print method -- +#' then use only the targets every method scored, and say so. Use +#' `only_common_dates = TRUE` to drop the dates that not every method has. +#' +#' @param ... Two or more [nowcast_backtest()] objects, or a single list of +#' them. The order of the methods in the result follows the order given. +#' @param only_common_dates Logical. Keep only the `now` dates at which every +#' method has a successful fit. Default `FALSE` keeps them all. +#' +#' @return A `nowcast_backtest`; see [nowcast_backtest()]. +#' +#' @seealso [nowcast_backtest()], whose `checkpoint_file` argument resumes an +#' interrupted backtest, [nowcast_weights()] and [nowcast_ensemble()]. +#' +#' @examples +#' data(denguedat) +#' recent <- subset(denguedat, onset_week >= as.Date("2010-06-01")) +#' dengue <- tbl_now(recent, +#' event_date = onset_week, report_date = report_week, verbose = FALSE +#' ) +#' dates <- as.Date(c("2010-10-04", "2010-11-15")) +#' +#' # Different models, same dates: backtest separately, then combine. +#' narrow <- nowcast_backtest(dengue, +#' example_engine(spread = 0.1, label = "narrow"), +#' now_dates = dates, verbose = FALSE +#' ) +#' wide <- nowcast_backtest(dengue, +#' example_engine(spread = 0.5, label = "wide"), +#' now_dates = dates, verbose = FALSE +#' ) +#' both <- backtest_combine(narrow, wide) +#' both$methods +#' +#' # Same model, new dates: add them to what you already have. +#' later <- nowcast_backtest(dengue, +#' example_engine(spread = 0.1, label = "narrow"), +#' now_dates = as.Date("2010-11-22"), verbose = FALSE +#' ) +#' backtest_combine(narrow, later)$now_dates +#' +#' @export +backtest_combine <- function(..., only_common_dates = FALSE) { + if (!rlang::is_bool(only_common_dates)) { + cli::cli_abort("{.arg only_common_dates} must be {.code TRUE} or {.code FALSE}.") + } + + backtests <- rlang::list2(...) + if (length(backtests) == 1L && is.list(backtests[[1]]) && + !inherits(backtests[[1]], "nowcast_backtest")) { + backtests <- backtests[[1]] + } + if (length(backtests) == 0L) { + cli::cli_abort("{.fn backtest_combine} needs at least one {.cls nowcast_backtest}.") + } + for (i in seq_along(backtests)) { + if (!inherits(backtests[[i]], "nowcast_backtest")) { + cli::cli_abort(c( + "Every argument must be a {.cls nowcast_backtest}.", + "x" = "Argument {i} is of class {.cls {class(backtests[[i]])}}." + )) + } + } + backtests <- unname(backtests) + .check_backtests_compatible(backtests) + + # The order the methods came in, which is the order a single call with all the + # engines would have used. + method_order <- unique(unlist(lapply(backtests, function(b) { + unique(c(b$timings$.method, b$methods)) + }))) + by_fit_order <- function(table) { + dplyr::arrange(table, .data$.now, match(.data$.method, method_order)) + } + + timings <- .combine_backtest_timings(backtests) |> by_fit_order() + scores <- dplyr::bind_rows(lapply(backtests, `[[`, "scores")) |> by_fit_order() + predictions <- dplyr::bind_rows(lapply(backtests, `[[`, "predictions")) |> + by_fit_order() + draw_tables <- lapply(backtests, `[[`, "draws") + draw_tables <- draw_tables[!vapply(draw_tables, is.null, logical(1))] + draws <- if (length(draw_tables) == 0L) { + NULL + } else { + dplyr::bind_rows(draw_tables) |> by_fit_order() + } + now_dates <- sort(unique(do.call(c, lapply(backtests, `[[`, "now_dates")))) + + first <- backtests[[1]] + combined <- structure( + list( + scores = scores, + predictions = predictions, + draws = draws, + timings = timings, + truth = .combine_backtest_truth(backtests), + methods = unique(scores$.method), + now_dates = now_dates, + keep_draws = first$keep_draws, + event_date = first$event_date, + strata = first$strata, + truth_axis = first$truth_axis, + truth_type = first$truth_type + ), + class = "nowcast_backtest" + ) + + if (only_common_dates) { + combined <- .restrict_backtest_to_common_dates(combined) + } + combined +} + +#' Refuse to combine backtests that answer different questions +#' +#' @param backtests A list of `nowcast_backtest` objects. +#' +#' @return `NULL`, invisibly. +#' +#' @keywords internal +#' @noRd +.check_backtests_compatible <- function(backtests) { + first <- backtests[[1]] + levels_of <- function(b) sort(unique(b$predictions$.quantile_level)) + + for (field in c("event_date", "strata", "truth_axis", "truth_type", "keep_draws")) { + same <- vapply(backtests, function(b) identical(b[[field]], first[[field]]), logical(1)) + if (!all(same)) { + cli::cli_abort(c( + "Backtests must share the same {.field {field}} to be combined.", + "x" = "Backtest{?s} {which(!same)} differ{?s/} from backtest 1.", + "i" = "Backtests of different data or scored against a different truth \\ + are not comparable." + )) + } + } + same_levels <- vapply( + backtests, function(b) isTRUE(all.equal(levels_of(b), levels_of(first))), + logical(1) + ) + if (!all(same_levels)) { + cli::cli_abort(c( + "Backtests must report the same quantile levels to be combined.", + "x" = "Backtest{?s} {which(!same_levels)} differ{?s/} from backtest 1.", + "i" = "The weighted interval score averages over the levels reported, so \\ + models summarised differently are not comparable." + )) + } + invisible(NULL) +} + +#' Combine the fit timings, refusing two successes for one fit +#' +#' The timings hold one row per attempted fit, so they are the record of which +#' (method, date) fits each backtest has -- including the failures, which have +#' no scores. +#' +#' @param backtests A list of `nowcast_backtest` objects. +#' +#' @return A tibble of timings, one row per (method, `now`). +#' +#' @keywords internal +#' @noRd +.combine_backtest_timings <- function(backtests) { + timings <- dplyr::bind_rows(lapply(backtests, `[[`, "timings")) + successes <- timings |> + dplyr::filter(.data$success) |> + dplyr::count(.data$.method, .data$.now) + clashes <- successes |> + dplyr::filter(.data$n > 1L) + if (nrow(clashes) > 0L) { + clashes$label <- paste0(clashes$.method, " at ", as.character(clashes$.now)) + cli::cli_abort(c( + "Backtests must not overlap: {nrow(clashes)} fit{?s} appear{?s/} in more \\ + than one.", + "x" = "Fitted more than once: {.val {utils::head(clashes$label, 5)}}.", + "i" = "Combine backtests of different dates or different methods, or drop \\ + the duplicates first." + )) + } + + # A failure is superseded by a success for the same fit; among failures only + # the latest is kept. + timings |> + dplyr::filter( + if (any(.data$success)) .data$success else dplyr::row_number() == dplyr::n(), + .by = c(".method", ".now") + ) +} + +#' Combine the truth tables of several backtests +#' +#' @param backtests A list of `nowcast_backtest` objects. +#' +#' @return The truth of the backtest with the latest `now` date, plus the event +#' dates only the others have. Warns when a shared cell disagrees. +#' +#' @keywords internal +#' @noRd +.combine_backtest_truth <- function(backtests) { + latest <- max(vapply(backtests, function(b) as.numeric(max(b$now_dates)), numeric(1))) + primary <- max(which(vapply( + backtests, function(b) as.numeric(max(b$now_dates)) == latest, logical(1) + ))) + truth <- backtests[[primary]]$truth + key <- c(backtests[[primary]]$event_date, backtests[[primary]]$strata) + + disagree <- 0L + extra <- list() + for (i in setdiff(seq_along(backtests), primary)) { + other <- backtests[[i]]$truth + shared <- dplyr::inner_join( + truth, other, by = key, suffix = c("", ".other") + ) + disagree <- disagree + sum(shared$.observed != shared$.observed.other, na.rm = TRUE) + extra[[length(extra) + 1L]] <- dplyr::anti_join(other, truth, by = key) + } + + if (disagree > 0L) { + cli::cli_warn(c( + "The combined backtests disagree on {disagree} observed count{?s}.", + "i" = "The counts of the backtest with the latest {.field now} are used \\ + as {.field truth}; the scores were computed against each backtest's \\ + own truth." + )) + } + extra <- dplyr::bind_rows(extra) + if (nrow(extra) > 0L) { + truth <- dplyr::bind_rows(truth, extra) |> + dplyr::arrange(dplyr::across(dplyr::all_of(key))) + } + truth +} + +#' Keep only the dates every method has a successful fit for +#' +#' @param backtest A combined `nowcast_backtest`. +#' +#' @return The restricted `nowcast_backtest`. +#' +#' @keywords internal +#' @noRd +.restrict_backtest_to_common_dates <- function(backtest) { + fitted <- backtest$scores |> + dplyr::distinct(.data$.method, .data$.now) + common <- fitted |> + dplyr::count(.data$.now) |> + dplyr::filter(.data$n == length(unique(fitted$.method))) |> + dplyr::pull(".now") + + if (length(common) == 0L) { + cli::cli_abort(c( + "No {.field now} date has a successful fit for every method.", + "i" = "Use {.code only_common_dates = FALSE} to keep them all." + )) + } + for (table in c("scores", "predictions", "draws", "timings")) { + if (!is.null(backtest[[table]])) { + backtest[[table]] <- dplyr::filter(backtest[[table]], .data$.now %in% common) + } + } + backtest$now_dates <- backtest$now_dates[backtest$now_dates %in% common] + backtest$methods <- unique(backtest$scores$.method) + backtest +} diff --git a/R/nowcast_score.R b/R/nowcast_score.R index 9f6b2c12..658e824d 100644 --- a/R/nowcast_score.R +++ b/R/nowcast_score.R @@ -565,6 +565,11 @@ score_nowcast <- function(x, truth = NULL, truth_axis = c("report", "revision"), #' `FALSE`. The workers are whatever [future::plan()] you set before the call; #' under the default `plan(sequential)` nothing runs in parallel. **May not #' play well with Stan-based engines**; see the "Parallel backtests" section. +#' @param checkpoint_file Optional path to a file where finished fits are saved +#' as the backtest runs, so that an interrupted backtest can resume. Run the +#' same call again with the same `checkpoint_file` and the (engine, date) fits +#' already in it are not refitted; only the missing ones run. See the +#' "Checkpoints and resuming" section. Default `NULL`: nothing is written. #' @inheritParams score_nowcast #' #' @return An object of class `nowcast_backtest`: a list with @@ -640,6 +645,48 @@ score_nowcast <- function(x, truth = NULL, truth_axis = c("report", "revision"), #' the backtest, and keep the number of workers small. When in doubt, leave #' `parallel = FALSE`: the sequential path is unchanged. #' +#' @section Checkpoints and resuming: +#' +#' A long backtest that is interrupted loses every fit it had finished. With +#' `checkpoint_file`, each finished (engine, date) fit is saved to that file, and +#' running the same call again continues from what is there: +#' +#' ```r +#' bt <- nowcast_backtest(x, engine_a, engine_b, now_dates = my_dates, +#' checkpoint_file = "tmp/my_backtest.rds") +#' ``` +#' +#' The file is a single R data (`.rds`) file, written exactly as given (its +#' folder is created if missing). A resumed call returns the same object as an +#' uninterrupted one; only the `elapsed_seconds` of the `timings` differ. +#' +#' * **Only fits that succeeded are skipped.** A fit that failed (with +#' `on_error = "warn"`) is recorded but retried on the next run. +#' * **The file is checked against the call.** It records a fingerprint of the +#' data, `seed`, `keep_draws`, `truth_axis`, `truth_type` and each engine (by +#' label). If any of them differ the call aborts rather than mixing results +#' from two different backtests. Adding a new engine, or new `now_dates`, is +#' fine: they are simply run and appended. Use a new file, or delete the old +#' one, to start from scratch. The engine fingerprint ignores the environment +#' of a function passed as an argument, so changing only what such a function +#' captures is not detected. +#' * **Only the main R session writes the file.** With `parallel = TRUE` the +#' `future` workers only return their fits; they never touch the file, so any +#' [future::plan()] -- `multisession`, `multicore`, `cluster` on other +#' machines -- is safe. The fits then run in waves of +#' [future::nbrOfWorkers()] and the file is updated after each wave, so an +#' interruption loses at most one wave. Without `parallel` it is updated after +#' every fit. Each update writes a temporary file next to it and renames it +#' over the old one, so an interruption during a write cannot leave a +#' truncated checkpoint. +#' * **Do not point two simultaneous runs at one file.** They would overwrite +#' each other's progress. +#' * Without a `seed`, the fits are not reproducible, so a resumed backtest +#' mixes fits that used different random numbers. Set `seed` if that matters. +#' +#' To add later dates to a backtest you already have, or to combine backtests of +#' different models, see [backtest_combine()]. +#' #' @section Every engine must report the same quantile levels: #' #' A backtest exists to compare models, and two models summarised at different @@ -660,6 +707,7 @@ score_nowcast <- function(x, truth = NULL, truth_axis = c("report", "revision"), #' [score_nowcast()] for the scores computed at each `now`; #' [nowcast_weights()] to turn the result into ensemble weights, and #' [nowcast_ensemble()] to use them; +#' [backtest_combine()] to join backtests run separately; #' [scoringutils::score()] and [scoringutils::add_relative_skill()] for an #' extensible scoring workflow. The #' [*One call, many models* article](https://rodrigozepeda.github.io/tbl.now/articles/ensemble-nowcasting.html) @@ -704,10 +752,12 @@ nowcast_backtest <- function(x, ..., now_dates = NULL, horizon = 4, seed = NULL, keep_draws = FALSE, on_error = c("warn", "abort"), verbose = TRUE, truth_axis = c("report", "revision"), - truth_type = "total", parallel = FALSE) { + truth_type = "total", parallel = FALSE, + checkpoint_file = NULL) { .assert_tbl_now(x, "nowcast_backtest") on_error <- match.arg(on_error) truth_axis <- match.arg(truth_axis) + .check_checkpoint_file(checkpoint_file) if (!rlang::is_bool(parallel)) { cli::cli_abort("{.arg parallel} must be {.code TRUE} or {.code FALSE}.") } @@ -764,11 +814,21 @@ nowcast_backtest <- function(x, ..., now_dates = NULL, horizon = 4, truth = truth, seed = seed, keep_draws = keep_draws, on_error = on_error, verbose = verbose, rng_kind = if (parallel) RNGkind() else NULL ) - fits <- if (parallel) { - .backtest_parallel_map(tasks, fit_args) + checkpoint <- if (is.null(checkpoint_file)) { + NULL } else { - lapply(tasks, .backtest_run_task, fit_args = fit_args) + list( + file = checkpoint_file, + fingerprint = .backtest_fingerprint( + x, engines, seed = seed, keep_draws = keep_draws, + truth_axis = truth_axis, truth_type = truth_type + ) + ) } + fits <- .backtest_run_tasks( + tasks, fit_args, parallel = parallel, checkpoint = checkpoint, + verbose = verbose + ) timings <- lapply(fits, `[[`, "timing") results <- lapply(fits, `[[`, "result") diff --git a/R/simulate_batch.R b/R/simulate_batch.R index 519cb3ab..d2662c19 100644 --- a/R/simulate_batch.R +++ b/R/simulate_batch.R @@ -323,9 +323,12 @@ simulate_batch <- function(x, } #' `setdiff()` strips the Date class; restore it from the grid it came from. +#' +#' Compares the underlying numbers: from R 4.3.0 `match()` converts a classed +#' `Date` to character, so `Date %in% numeric` matches nothing where `setdiff()` +#' still returns numbers (seen on R 4.3.3; R 4.6.1 keeps the class). #' @keywords internal #' @noRd .batch_restore_date_class <- function(stripped_dates, template_dates) { - restored <- template_dates[template_dates %in% stripped_dates] - restored + template_dates[as.numeric(template_dates) %in% as.numeric(stripped_dates)] } diff --git a/SKILL.md b/SKILL.md index f3d7e7ae..84d3aeba 100644 --- a/SKILL.md +++ b/SKILL.md @@ -368,6 +368,21 @@ quantiles; `type = "linear_pool"` requires draws from every member. Combine only models with the same target semantics, dates, and strata. Use `scoringutils::as_forecast_*()` for additional scoring workflows. +An interrupted backtest can resume: `nowcast_backtest(..., checkpoint_file = +"tmp/bt.rds")` saves each finished engine/date fit, and running the same call +again refits only what is missing (failed fits are retried). The file records a +fingerprint of the data, seed, truth settings and each engine, and a call that +differs aborts instead of mixing results; new dates and new engines are simply +added. Only the main R session writes the file, so any `future::plan()` is safe +with `parallel = TRUE` (fits then run and are saved in waves of one per worker). +Do not point two simultaneous runs at one file. + +`backtest_combine(bt_a, bt_b)` joins backtests run separately -- other engines +on the same dates, or the same engines on other dates -- into the object one +call would have produced. It aborts on a (method, date) fit present twice or on +backtests that differ in strata, truth settings or quantile levels; +`only_common_dates = TRUE` keeps just the dates every method has. + ## Common failure modes - Do not sum cumulative snapshots across report delays. diff --git a/_pkgdown.yml b/_pkgdown.yml index bcdff367..4117f289 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -209,6 +209,7 @@ reference: - nowcast_ensemble - nowcast_weights - nowcast_backtest + - backtest_combine - score_nowcast - title: Converters diff --git a/man/backtest_combine.Rd b/man/backtest_combine.Rd new file mode 100644 index 00000000..b11e3951 --- /dev/null +++ b/man/backtest_combine.Rd @@ -0,0 +1,99 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/backtest_combine.R +\name{backtest_combine} +\alias{backtest_combine} +\title{Combine backtests} +\usage{ +backtest_combine(..., only_common_dates = FALSE) +} +\arguments{ +\item{...}{Two or more \code{\link[=nowcast_backtest]{nowcast_backtest()}} objects, or a single list of +them. The order of the methods in the result follows the order given.} + +\item{only_common_dates}{Logical. Keep only the \code{now} dates at which every +method has a successful fit. Default \code{FALSE} keeps them all.} +} +\value{ +A \code{nowcast_backtest}; see \code{\link[=nowcast_backtest]{nowcast_backtest()}}. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Joins \code{\link[=nowcast_backtest]{nowcast_backtest()}} results that were run separately into one, so that +an expensive backtest never has to be repeated: +\itemize{ +\item \strong{Different models, same dates.} Backtest each engine on its own (perhaps +on different machines, or as it becomes available) and combine them to +compare their scores, derive \code{\link[=nowcast_weights]{nowcast_weights()}} or build a +\code{\link[=nowcast_ensemble]{nowcast_ensemble()}}. +\item \strong{Same model, different dates.} Backtest last year's dates once, and next +year backtest only the new dates and add them to the old result. +} + +Combining backtests of \emph{the same data, dates and engines} gives the object a +single call would have -- the tables have the same rows in the same order: + +\if{html}{\out{
}}\preformatted{bt1 <- nowcast_backtest(x, engine_a, now_dates = my_dates) +bt2 <- nowcast_backtest(x, engine_b, now_dates = my_dates) +backtest_combine(bt1, bt2) +# is the same as +nowcast_backtest(x, engine_a, engine_b, now_dates = my_dates) +}\if{html}{\out{
}} + +(Only the \code{elapsed_seconds} of the \code{timings} differ.) +} +\details{ +The backtests must agree on the event date, the strata, \code{truth_axis}, +\code{truth_type}, \code{keep_draws} and the quantile levels; otherwise they are not +measuring the same thing and the call aborts. + +Two backtests must not both have a successful fit of the same method at the +same \code{now} date: that would be two answers to one question, so the call +aborts. A fit that \emph{failed} in one and succeeded in another is fine -- the +success is kept, which lets you re-run only the failures and combine. + +Scores are kept as they were computed. When the backtests were run at +different times the data may have been revised in between, so each was +scored against its own \code{truth}. The combined \code{truth} is the one from the +backtest with the latest \code{now} date, extended with any event dates only the +others have; the call warns when an event date it shares has a different +observed count in the others. Re-run the earlier backtest if you need every +score against the same truth. + +Methods that cover different dates are allowed (that is how you add dates to +one model only), and comparisons -- \code{\link[=nowcast_weights]{nowcast_weights()}}, the print method -- +then use only the targets every method scored, and say so. Use +\code{only_common_dates = TRUE} to drop the dates that not every method has. +} +\examples{ +data(denguedat) +recent <- subset(denguedat, onset_week >= as.Date("2010-06-01")) +dengue <- tbl_now(recent, + event_date = onset_week, report_date = report_week, verbose = FALSE +) +dates <- as.Date(c("2010-10-04", "2010-11-15")) + +# Different models, same dates: backtest separately, then combine. +narrow <- nowcast_backtest(dengue, + example_engine(spread = 0.1, label = "narrow"), + now_dates = dates, verbose = FALSE +) +wide <- nowcast_backtest(dengue, + example_engine(spread = 0.5, label = "wide"), + now_dates = dates, verbose = FALSE +) +both <- backtest_combine(narrow, wide) +both$methods + +# Same model, new dates: add them to what you already have. +later <- nowcast_backtest(dengue, + example_engine(spread = 0.1, label = "narrow"), + now_dates = as.Date("2010-11-22"), verbose = FALSE +) +backtest_combine(narrow, later)$now_dates + +} +\seealso{ +\code{\link[=nowcast_backtest]{nowcast_backtest()}}, whose \code{checkpoint_file} argument resumes an +interrupted backtest, \code{\link[=nowcast_weights]{nowcast_weights()}} and \code{\link[=nowcast_ensemble]{nowcast_ensemble()}}. +} diff --git a/man/nowcast_backtest.Rd b/man/nowcast_backtest.Rd index d5e24ed1..8f1d297b 100644 --- a/man/nowcast_backtest.Rd +++ b/man/nowcast_backtest.Rd @@ -16,7 +16,8 @@ nowcast_backtest( verbose = TRUE, truth_axis = c("report", "revision"), truth_type = "total", - parallel = FALSE + parallel = FALSE, + checkpoint_file = NULL ) } \arguments{ @@ -83,6 +84,12 @@ the (engine, date) fits in parallel with \pkg{future}, through \code{FALSE}. The workers are whatever \code{\link[future:plan]{future::plan()}} you set before the call; under the default \code{plan(sequential)} nothing runs in parallel. \strong{May not play well with Stan-based engines}; see the "Parallel backtests" section.} + +\item{checkpoint_file}{Optional path to a file where finished fits are saved +as the backtest runs, so that an interrupted backtest can resume. Run the +same call again with the same \code{checkpoint_file} and the (engine, date) fits +already in it are not refitted; only the missing ones run. See the +"Checkpoints and resuming" section. Default \code{NULL}: nothing is written.} } \value{ An object of class \code{nowcast_backtest}: a list with @@ -172,6 +179,50 @@ the backtest, and keep the number of workers small. When in doubt, leave \code{parallel = FALSE}: the sequential path is unchanged. } +\section{Checkpoints and resuming}{ + + +A long backtest that is interrupted loses every fit it had finished. With +\code{checkpoint_file}, each finished (engine, date) fit is saved to that file, and +running the same call again continues from what is there: + +\if{html}{\out{
}}\preformatted{bt <- nowcast_backtest(x, engine_a, engine_b, now_dates = my_dates, + checkpoint_file = "tmp/my_backtest.rds") +}\if{html}{\out{
}} + +The file is a single R data (\code{.rds}) file, written exactly as given (its +folder is created if missing). A resumed call returns the same object as an +uninterrupted one; only the \code{elapsed_seconds} of the \code{timings} differ. +\itemize{ +\item \strong{Only fits that succeeded are skipped.} A fit that failed (with +\code{on_error = "warn"}) is recorded but retried on the next run. +\item \strong{The file is checked against the call.} It records a fingerprint of the +data, \code{seed}, \code{keep_draws}, \code{truth_axis}, \code{truth_type} and each engine (by +label). If any of them differ the call aborts rather than mixing results +from two different backtests. Adding a new engine, or new \code{now_dates}, is +fine: they are simply run and appended. Use a new file, or delete the old +one, to start from scratch. The engine fingerprint ignores the environment +of a function passed as an argument, so changing only what such a function +captures is not detected. +\item \strong{Only the main R session writes the file.} With \code{parallel = TRUE} the +\code{future} workers only return their fits; they never touch the file, so any +\code{\link[future:plan]{future::plan()}} -- \code{multisession}, \code{multicore}, \code{cluster} on other +machines -- is safe. The fits then run in waves of +\code{\link[future:nbrOfWorkers]{future::nbrOfWorkers()}} and the file is updated after each wave, so an +interruption loses at most one wave. Without \code{parallel} it is updated after +every fit. Each update writes a temporary file next to it and renames it +over the old one, so an interruption during a write cannot leave a +truncated checkpoint. +\item \strong{Do not point two simultaneous runs at one file.} They would overwrite +each other's progress. +\item Without a \code{seed}, the fits are not reproducible, so a resumed backtest +mixes fits that used different random numbers. Set \code{seed} if that matters. +} + +To add later dates to a backtest you already have, or to combine backtests of +different models, see \code{\link[=backtest_combine]{backtest_combine()}}. +} + \section{Every engine must report the same quantile levels}{ @@ -228,6 +279,7 @@ which matters here because \code{now} moves between fits; \code{\link[=score_nowcast]{score_nowcast()}} for the scores computed at each \code{now}; \code{\link[=nowcast_weights]{nowcast_weights()}} to turn the result into ensemble weights, and \code{\link[=nowcast_ensemble]{nowcast_ensemble()}} to use them; +\code{\link[=backtest_combine]{backtest_combine()}} to join backtests run separately; \code{\link[scoringutils:score]{scoringutils::score()}} and \code{\link[scoringutils:add_relative_skill]{scoringutils::add_relative_skill()}} for an extensible scoring workflow. The \href{https://rodrigozepeda.github.io/tbl.now/articles/ensemble-nowcasting.html}{\emph{One call, many models} article} diff --git a/tests/testthat/test-backtest-checkpoint.R b/tests/testthat/test-backtest-checkpoint.R new file mode 100644 index 00000000..6277b21b --- /dev/null +++ b/tests/testthat/test-backtest-checkpoint.R @@ -0,0 +1,392 @@ +# `nowcast_backtest(checkpoint_file = )` saves finished fits so an interrupted +# backtest resumes. Only the main R session writes the file; the futures workers +# never see it. + +checkpoint_data <- function(strata = FALSE, drop_row = FALSE) { + df <- data.frame( + onset = as.Date("2024-01-07") + rep(7 * (0:9), each = 6), + report = as.Date("2024-01-07") + rep(7 * (0:9), each = 6) + rep(c(0, 7, 14), 2), + gender = rep(c("F", "M"), each = 3) + ) + if (drop_row) df <- df[-1, ] + tbl_now(df, + event_date = onset, report_date = report, + strata = if (strata) "gender" else NULL, + data_type = "linelist", verbose = FALSE + ) +} + +checkpoint_dates <- as.Date(c("2024-02-18", "2024-03-03", "2024-03-10")) + +# An engine that records every fit it is asked to make and can be told to fail +# at one date, standing in for an interruption. State lives in an environment +# because a closure over the test frame would not survive `registerS3method()`. +flaky_state <- new.env() +flaky_state$calls <- character(0) +flaky_state$fail_at <- NULL + +local({ + fit <- function(engine, x, ..., quantile_levels = nowcast_quantile_levels(), + verbose = TRUE) { + flaky_state$calls <- c(flaky_state$calls, as.character(get_now(x))) + if (!is.null(flaky_state$fail_at) && get_now(x) == flaky_state$fail_at) { + stop("interrupted") + } + nowcast_fit.example(engine, x, spread = 0.3, quantile_levels = quantile_levels) + } + registerS3method("nowcast_fit", "flakytoy", fit, envir = asNamespace("tbl.now")) + registerS3method("nowcast_tidy", "flakytoy", nowcast_tidy.example, + envir = asNamespace("tbl.now")) +}) + +reset_flaky <- function(fail_at = NULL) { + flaky_state$calls <- character(0) + flaky_state$fail_at <- fail_at +} + +checkpoint_run <- function(x, ..., dates = checkpoint_dates, file = NULL, + seed = NULL, keep_draws = FALSE, on_error = "warn", + truth_axis = "report", truth_type = "total") { + nowcast_backtest(x, ..., now_dates = dates, verbose = FALSE, + checkpoint_file = file, seed = seed, keep_draws = keep_draws, + on_error = on_error, truth_axis = truth_axis, + truth_type = truth_type) +} + +expect_same_but_elapsed <- function(a, b) { + expect_equal(a$scores, b$scores) + expect_equal(a$predictions, b$predictions) + expect_equal(a$draws, b$draws) + expect_equal(a$truth, b$truth) + expect_equal(a$methods, b$methods) + expect_equal(a$now_dates, b$now_dates) + expect_equal( + dplyr::select(a$timings, -"elapsed_seconds"), + dplyr::select(b$timings, -"elapsed_seconds") + ) +} + +checkpoint_fits <- function(file) { + vapply(readRDS(file)$fits, function(e) { + paste(e$label, as.character(e$now)) + }, character(1)) +} + +test_that("a checkpointed backtest equals the plain one and leaves one file", { + file <- withr::local_tempfile(fileext = ".rds") + x <- checkpoint_data() + plain <- checkpoint_run(x, example_engine(spread = 0.2, label = "a"), + example_engine(spread = 0.5, label = "b")) + saved <- checkpoint_run(x, example_engine(spread = 0.2, label = "a"), + example_engine(spread = 0.5, label = "b"), file = file) + expect_same_but_elapsed(plain, saved) + + expect_true(file.exists(file)) + expect_length(checkpoint_fits(file), 6L) + # No temporary file is left next to it. + expect_equal(list.files(dirname(file), all.files = TRUE, no.. = TRUE, + pattern = "\\.tmp$"), character(0)) +}) + +test_that("a complete checkpoint refits nothing and returns the same object", { + file <- withr::local_tempfile() + x <- checkpoint_data() + reset_flaky() + first <- checkpoint_run(x, engine("flakytoy", label = "flaky"), file = file) + expect_length(flaky_state$calls, 3L) + + reset_flaky() + again <- checkpoint_run(x, engine("flakytoy", label = "flaky"), file = file) + expect_length(flaky_state$calls, 0L) + # Not even the timings change: they are the saved ones. + expect_equal(first, again) +}) + +test_that("resuming after an interruption fits only what is missing", { + file <- withr::local_tempfile() + x <- checkpoint_data() + + # The fit at the second date stops the run, as an interruption would. + reset_flaky(fail_at = checkpoint_dates[[2]]) + expect_error( + checkpoint_run(x, engine("flakytoy", label = "flaky"), file = file, + on_error = "abort"), + "interrupted|failed" + ) + expect_equal(checkpoint_fits(file), paste("flaky", checkpoint_dates[[1]])) + + reset_flaky() + resumed <- checkpoint_run(x, engine("flakytoy", label = "flaky"), file = file) + expect_equal(flaky_state$calls, as.character(checkpoint_dates[2:3])) + + reset_flaky() + plain <- checkpoint_run(x, engine("flakytoy", label = "flaky")) + expect_same_but_elapsed(plain, resumed) +}) + +test_that("a failed fit is kept in the file but retried on resume", { + file <- withr::local_tempfile() + x <- checkpoint_data() + + reset_flaky(fail_at = checkpoint_dates[[2]]) + expect_warning( + first <- checkpoint_run(x, engine("flakytoy", label = "flaky"), file = file), + "interrupted" + ) + expect_equal(first$timings$success, c(TRUE, FALSE, TRUE)) + expect_length(checkpoint_fits(file), 3L) + + reset_flaky() + second <- checkpoint_run(x, engine("flakytoy", label = "flaky"), file = file) + expect_equal(flaky_state$calls, as.character(checkpoint_dates[[2]])) + expect_equal(second$timings$success, c(TRUE, TRUE, TRUE)) + expect_equal(nrow(second$scores), nrow(first$scores) + + nrow(dplyr::filter(second$scores, .data$.now == checkpoint_dates[[2]]))) +}) + +test_that("new dates and new engines are added to an existing checkpoint", { + file <- withr::local_tempfile() + x <- checkpoint_data() + + reset_flaky() + checkpoint_run(x, engine("flakytoy", label = "flaky"), + dates = checkpoint_dates[1], file = file) + expect_equal(flaky_state$calls, as.character(checkpoint_dates[1])) + + reset_flaky() + more <- checkpoint_run(x, engine("flakytoy", label = "flaky"), + dates = checkpoint_dates, file = file) + expect_equal(flaky_state$calls, as.character(checkpoint_dates[2:3])) + expect_equal(more$now_dates, checkpoint_dates) + + reset_flaky() + wider <- checkpoint_run( + x, engine("flakytoy", label = "flaky"), example_engine(label = "extra"), + file = file + ) + expect_length(flaky_state$calls, 0L) + expect_equal(wider$methods, c("flaky", "extra")) + expect_length(checkpoint_fits(file), 6L) + + # A run over fewer dates than the file has returns just those dates. + fewer <- checkpoint_run(x, engine("flakytoy", label = "flaky"), + dates = checkpoint_dates[2], file = file) + expect_equal(fewer$now_dates, checkpoint_dates[2]) + expect_equal(unique(fewer$scores$.now), checkpoint_dates[2]) + expect_length(checkpoint_fits(file), 6L) +}) + +test_that("a checkpoint from a different backtest is refused", { + file <- withr::local_tempfile() + x <- checkpoint_data() + checkpoint_run(x, example_engine(spread = 0.2, label = "a"), file = file, + seed = 1) + before <- readRDS(file) + + expect_error( + checkpoint_run(x, example_engine(spread = 0.4, label = "a"), file = file, + seed = 1), + "different backtest.*engine" + ) + expect_error( + checkpoint_run(x, example_engine(spread = 0.2, label = "a"), file = file, + seed = 2), + "seed" + ) + expect_error( + checkpoint_run(x, example_engine(spread = 0.2, label = "a"), file = file, + seed = 1, keep_draws = TRUE), + "keep_draws" + ) + expect_error( + checkpoint_run(x, example_engine(spread = 0.2, label = "a"), file = file, + seed = 1, truth_type = "total", truth_axis = "revision"), + "truth_axis|revision" + ) + expect_error( + checkpoint_run(checkpoint_data(drop_row = TRUE), + example_engine(spread = 0.2, label = "a"), file = file, + seed = 1), + "the data" + ) + # Refusing does not touch the file. + expect_identical(readRDS(file), before) + + # The same call is accepted. + expect_no_error(checkpoint_run( + x, example_engine(spread = 0.2, label = "a"), file = file, seed = 1 + )) +}) + +test_that("the engine fingerprint ignores a function's environment", { + make_engine <- function(offset) { + f <- function(z) z + 1 + engine("flakytoy", transform = f, label = "f") + } + x <- checkpoint_data() + fingerprint <- function(e) { + .backtest_fingerprint(x, list(f = e), seed = NULL, keep_draws = FALSE, + truth_axis = "report", truth_type = "total")$engines + } + expect_equal(fingerprint(make_engine(1)), fingerprint(make_engine(2))) + other <- engine("flakytoy", transform = function(z) z + 2, label = "f") + expect_false(identical(fingerprint(make_engine(1)), fingerprint(other))) + # The label is the key, not part of the model. + relabelled <- make_engine(1) + relabelled$label <- "g" + expect_equal(unname(fingerprint(make_engine(1))), unname(fingerprint(relabelled))) +}) + +test_that("a file that is not a checkpoint is never overwritten", { + file <- withr::local_tempfile() + writeLines("not a checkpoint", file) + expect_error( + checkpoint_run(checkpoint_data(), example_engine(), file = file), + "not a .*checkpoint" + ) + expect_equal(readLines(file), "not a checkpoint") + + saveRDS(list(version = 99L), file) + expect_error( + checkpoint_run(checkpoint_data(), example_engine(), file = file), + "not a .*checkpoint" + ) +}) + +test_that("checkpoint_file is validated and its folder is created", { + x <- checkpoint_data() + for (bad in list(1, NA_character_, c("a", "b"), "", TRUE)) { + expect_error( + checkpoint_run(x, example_engine(), file = bad), "checkpoint_file" + ) + } + expect_error( + checkpoint_run(x, example_engine(), file = tempdir()), "directory" + ) + + folder <- withr::local_tempdir() + nested <- file.path(folder, "tmp", "deeper", "myfile") + checkpoint_run(x, example_engine(), file = nested) + expect_true(file.exists(nested)) +}) + +test_that("an unwritable checkpoint path fails before any fit", { + # A folder cannot be made below a file, whoever is running the test. + blocker <- withr::local_tempfile() + writeLines("a file", blocker) + reset_flaky() + expect_error( + checkpoint_run(checkpoint_data(), engine("flakytoy", label = "flaky"), + file = file.path(blocker, "cp")), + "Could not write" + ) + expect_length(flaky_state$calls, 0L) +}) + +test_that("strata and a grouped tbl_now checkpoint like the plain backtest", { + file <- withr::local_tempfile() + x <- checkpoint_data(strata = TRUE) + plain <- checkpoint_run(x, example_engine(label = "toy")) + saved <- checkpoint_run(dplyr::group_by(x, gender), example_engine(label = "toy"), + file = file) + expect_same_but_elapsed(plain, saved) + resumed <- checkpoint_run(x, example_engine(label = "toy"), file = file) + expect_equal(saved, resumed) +}) + +test_that("a checkpointed backtest combines like any other", { + file <- withr::local_tempfile() + x <- checkpoint_data() + first <- checkpoint_run(x, example_engine(label = "toy"), + dates = checkpoint_dates[1:2], file = file) + later <- checkpoint_run(x, example_engine(label = "toy"), + dates = checkpoint_dates[3]) + expect_same_but_elapsed( + checkpoint_run(x, example_engine(label = "toy")), + backtest_combine(first, later) + ) +}) + +test_that("a parallel checkpointed backtest equals the sequential one", { + skip_if_not_installed("doFuture") + skip_if_not_installed("foreach") + skip_if_not_installed("future") + future::plan(future::sequential) + file <- withr::local_tempfile() + x <- checkpoint_data() + engines <- list(example_engine(spread = 0.2, label = "a"), + example_engine(spread = 0.5, label = "b")) + + plain <- checkpoint_run(x, engines) + saved <- nowcast_backtest(x, engines, now_dates = checkpoint_dates, + verbose = FALSE, parallel = TRUE, + checkpoint_file = file) + expect_same_but_elapsed(plain, saved) + expect_length(checkpoint_fits(file), 6L) + + # Resuming in the other mode finds everything already there. + sequential <- checkpoint_run(x, engines, file = file) + expect_equal(saved, sequential) +}) + +test_that("parallel failures leave earlier waves saved", { + skip_if_not_installed("doFuture") + skip_if_not_installed("foreach") + skip_if_not_installed("future") + future::plan(future::sequential) + file <- withr::local_tempfile() + x <- checkpoint_data() + + reset_flaky(fail_at = checkpoint_dates[[3]]) + expect_error( + suppressWarnings(nowcast_backtest( + x, engine("flakytoy", label = "flaky"), now_dates = checkpoint_dates, + verbose = FALSE, parallel = TRUE, on_error = "abort", + checkpoint_file = file + )), + "failed" + ) + # A sequential plan runs one fit per wave, so two waves finished. + expect_equal(checkpoint_fits(file), paste("flaky", checkpoint_dates[1:2])) +}) + +test_that("real multisession workers never write the checkpoint", { + skip_on_cran() + skip_on_covr() + skip_if_not_installed("doFuture") + skip_if_not_installed("foreach") + skip_if_not_installed("future") + future::plan(future::multisession, workers = 2) + withr::defer(future::plan(future::sequential)) + # Workers load the INSTALLED tbl.now; skip unless it is the code under test. + installed <- tryCatch( + future::value(future::future( + deparse(body(asNamespace("tbl.now")$nowcast_backtest)) + )), + error = function(e) NULL + ) + skip_if_not(identical(installed, deparse(body(nowcast_backtest))), + "the installed tbl.now is not the version under test") + + folder <- withr::local_tempdir() + file <- file.path(folder, "cp.rds") + x <- checkpoint_data() + engines <- list(example_engine(spread = 0.2, label = "a"), + example_engine(spread = 0.5, label = "b")) + + # The main session rewrites the checkpoint after each wave; the workers only + # return fits. Nothing but the checkpoint itself may be left in the folder. + plain <- checkpoint_run(x, engines) + saved <- nowcast_backtest(x, engines, now_dates = checkpoint_dates, + verbose = FALSE, parallel = TRUE, + checkpoint_file = file) + expect_same_but_elapsed(plain, saved) + expect_length(checkpoint_fits(file), 6L) + expect_equal(list.files(folder, all.files = TRUE, no.. = TRUE), "cp.rds") + + # Resuming under the same plan refits nothing. + again <- nowcast_backtest(x, engines, now_dates = checkpoint_dates, + verbose = FALSE, parallel = TRUE, + checkpoint_file = file) + expect_equal(saved, again) +}) diff --git a/tests/testthat/test-backtest-combine.R b/tests/testthat/test-backtest-combine.R new file mode 100644 index 00000000..340d5504 --- /dev/null +++ b/tests/testthat/test-backtest-combine.R @@ -0,0 +1,232 @@ +# `backtest_combine()` joins backtests run separately. Combining what a single +# call would have produced must give that call's object -- the same rows in the +# same order -- so nothing downstream can tell the difference. + +combine_data <- function(strata = FALSE) { + df <- data.frame( + onset = as.Date("2024-01-07") + rep(7 * (0:9), each = 6), + report = as.Date("2024-01-07") + rep(7 * (0:9), each = 6) + rep(c(0, 7, 14), 2), + gender = rep(c("F", "M"), each = 3) + ) + tbl_now(df, + event_date = onset, report_date = report, + strata = if (strata) "gender" else NULL, + data_type = "linelist", verbose = FALSE + ) +} + +combine_dates <- as.Date(c("2024-02-18", "2024-03-03", "2024-03-10")) + +narrow_engine <- function() example_engine(spread = 0.2, label = "narrow") +wide_engine <- function() example_engine(spread = 0.5, label = "wide") + +combine_run <- function(x, ..., dates = combine_dates) { + nowcast_backtest(x, ..., now_dates = dates, verbose = FALSE) +} + +expect_same_but_elapsed <- function(a, b) { + expect_equal(a$scores, b$scores) + expect_equal(a$predictions, b$predictions) + expect_equal(a$draws, b$draws) + expect_equal(a$truth, b$truth) + expect_equal(a$methods, b$methods) + expect_equal(a$now_dates, b$now_dates) + expect_equal( + dplyr::select(a$timings, -"elapsed_seconds"), + dplyr::select(b$timings, -"elapsed_seconds") + ) + expect_equal( + a[setdiff(names(a), c("scores", "predictions", "draws", "timings", "truth", + "methods", "now_dates"))], + b[setdiff(names(b), c("scores", "predictions", "draws", "timings", "truth", + "methods", "now_dates"))] + ) +} + +test_that("combining models on the same dates equals one joint backtest", { + x <- combine_data() + joint <- combine_run(x, narrow_engine(), wide_engine()) + combined <- backtest_combine( + combine_run(x, narrow_engine()), combine_run(x, wide_engine()) + ) + expect_s3_class(combined, "nowcast_backtest") + expect_same_but_elapsed(joint, combined) + # Dates outer, engines inner, as in a single call. + expect_equal(combined$timings$.method, rep(c("narrow", "wide"), 3)) +}) + +test_that("combining the same model on different dates equals one backtest", { + x <- combine_data() + joint <- combine_run(x, narrow_engine()) + combined <- backtest_combine( + combine_run(x, narrow_engine(), dates = combine_dates[1:2]), + combine_run(x, narrow_engine(), dates = combine_dates[3]) + ) + expect_same_but_elapsed(joint, combined) + + # The order the backtests are given in does not change the rows. + reversed <- backtest_combine( + combine_run(x, narrow_engine(), dates = combine_dates[3]), + combine_run(x, narrow_engine(), dates = combine_dates[1:2]) + ) + expect_same_but_elapsed(joint, reversed) +}) + +test_that("models and dates can be combined at once, with a list too", { + x <- combine_data() + joint <- combine_run(x, narrow_engine(), wide_engine()) + pieces <- list( + combine_run(x, narrow_engine(), dates = combine_dates[1:2]), + combine_run(x, wide_engine(), dates = combine_dates[1:2]), + combine_run(x, narrow_engine(), wide_engine(), dates = combine_dates[3]) + ) + expect_same_but_elapsed(joint, do.call(backtest_combine, pieces)) + expect_same_but_elapsed(joint, backtest_combine(pieces)) +}) + +test_that("strata and a grouped tbl_now combine like a joint backtest", { + x <- combine_data(strata = TRUE) + joint <- combine_run(x, narrow_engine(), wide_engine()) + combined <- backtest_combine( + combine_run(dplyr::group_by(x, gender), narrow_engine()), + combine_run(x, wide_engine()) + ) + expect_same_but_elapsed(joint, combined) + expect_true("gender" %in% colnames(combined$scores)) +}) + +test_that("a single backtest is returned as it is", { + bt <- combine_run(combine_data(), narrow_engine()) + expect_same_but_elapsed(bt, backtest_combine(bt)) +}) + +test_that("the combined backtest feeds the weights and prints", { + x <- combine_data() + combined <- backtest_combine( + combine_run(x, narrow_engine()), combine_run(x, wide_engine()) + ) + joint <- combine_run(x, narrow_engine(), wide_engine()) + expect_equal(nowcast_weights(combined), nowcast_weights(joint)) + expect_equal(utils::capture.output(print(combined)), + utils::capture.output(print(joint))) +}) + +test_that("a fit present in two backtests aborts", { + x <- combine_data() + first <- combine_run(x, narrow_engine(), dates = combine_dates[1:2]) + second <- combine_run(x, narrow_engine(), dates = combine_dates[2:3]) + expect_error(backtest_combine(first, second), "overlap") + expect_error(backtest_combine(first, second), "narrow at 2024-03-03") + expect_error(backtest_combine(first, first), "overlap") + + # Different methods at the same date are not an overlap. + expect_no_error(backtest_combine( + first, combine_run(x, wide_engine(), dates = combine_dates[1:2]) + )) +}) + +test_that("a success replaces a failure of the same fit", { + x <- combine_data() + complete <- combine_run(x, narrow_engine()) + + # `failed` is `complete` as if the fit at the second date had failed. + failed <- complete + gone <- failed$scores$.now == combine_dates[[2]] + failed$scores <- failed$scores[!gone, ] + failed$predictions <- failed$predictions[failed$predictions$.now != combine_dates[[2]], ] + failed$timings$success[failed$timings$.now == combine_dates[[2]]] <- FALSE + failed$timings$error[failed$timings$.now == combine_dates[[2]]] <- "boom" + + redo <- combine_run(x, narrow_engine(), dates = combine_dates[[2]]) + combined <- backtest_combine(failed, redo) + expect_same_but_elapsed(complete, combined) + expect_true(all(combined$timings$success)) + + # Two failures of one fit keep one row. + failure <- failed$timings[failed$timings$.now == combine_dates[[2]], ] + kept <- .combine_backtest_timings(list( + list(timings = failure), list(timings = failure) + )) + expect_equal(nrow(kept), 1L) + expect_false(kept$success) +}) + +test_that("backtests answering different questions are refused", { + x <- combine_data() + base <- combine_run(x, narrow_engine(), dates = combine_dates[1]) + other <- combine_run(x, wide_engine(), dates = combine_dates[2]) + + for (field in c("event_date", "strata", "truth_axis", "truth_type", "keep_draws")) { + changed <- other + changed[[field]] <- if (field == "keep_draws") TRUE else "different" + expect_error(backtest_combine(base, changed), field, info = field) + } + + levels <- combine_run( + x, example_engine(label = "few", quantile_levels = c(0.25, 0.5, 0.75)), + dates = combine_dates[2] + ) + expect_error(backtest_combine(base, levels), "quantile levels") +}) + +test_that("arguments are validated", { + bt <- combine_run(combine_data(), narrow_engine()) + expect_error(backtest_combine(), "at least one") + expect_error(backtest_combine(bt, "nope"), "nowcast_backtest") + expect_error(backtest_combine(bt, data.frame()), "nowcast_backtest") + expect_error(backtest_combine(bt, only_common_dates = NA), "only_common_dates") + expect_error(backtest_combine(bt, only_common_dates = "yes"), "only_common_dates") +}) + +test_that("only_common_dates keeps the dates every method has", { + x <- combine_data() + narrow <- combine_run(x, narrow_engine()) + wide <- combine_run(x, wide_engine(), dates = combine_dates[2:3]) + + all_dates <- backtest_combine(narrow, wide) + expect_equal(all_dates$now_dates, combine_dates) + + common <- backtest_combine(narrow, wide, only_common_dates = TRUE) + expect_equal(common$now_dates, combine_dates[2:3]) + for (table in c("scores", "predictions", "timings")) { + expect_true(all(common[[table]]$.now %in% combine_dates[2:3]), info = table) + } + expect_equal(common$methods, c("narrow", "wide")) + expect_same_but_elapsed( + common, combine_run(x, narrow_engine(), wide_engine(), dates = combine_dates[2:3]) + ) + + # Comparing methods with different dates uses the targets both scored. + expect_warning(nowcast_weights(all_dates), "wide") + expect_no_warning(nowcast_weights(common)) + + disjoint <- backtest_combine( + combine_run(x, narrow_engine(), dates = combine_dates[1]), + combine_run(x, wide_engine(), dates = combine_dates[3]) + ) + expect_error( + backtest_combine(disjoint, only_common_dates = TRUE), + "every method" + ) +}) + +test_that("the truth of the latest backtest is used and disagreement warned", { + x <- combine_data() + early <- combine_run(x, narrow_engine(), dates = combine_dates[1]) + late <- combine_run(x, wide_engine(), dates = combine_dates[3]) + + expect_no_warning(same <- backtest_combine(early, late)) + expect_equal(same$truth, late$truth) + + # The earlier backtest was scored against a revised truth. + revised <- early + revised$truth$.observed[[1]] <- revised$truth$.observed[[1]] + 10 + expect_warning(combined <- backtest_combine(revised, late), "disagree on 1") + expect_equal(combined$truth, late$truth) + + # Event dates only the earlier backtest has are added. + shorter <- late + shorter$truth <- shorter$truth[-1, ] + combined <- backtest_combine(early, shorter) + expect_equal(combined$truth, early$truth) +}) diff --git a/tests/testthat/test-batch_screen.R b/tests/testthat/test-batch_screen.R index 16a5ae32..275eb8da 100644 --- a/tests/testthat/test-batch_screen.R +++ b/tests/testthat/test-batch_screen.R @@ -35,6 +35,19 @@ make_flat_linelist <- function(n_origins = 60L, per_origin = 12L, seed = 1L) { # -- simulate_batch() ---------------------------------------------------------- +test_that(".batch_restore_date_class() restores dates from stripped numbers", { + grid <- seq(as.Date("2021-01-01"), by = "day", length.out = 6) + # What `setdiff()` returns on older R (seen on R 4.3.3): numbers, no class. + stripped <- as.numeric(grid[c(1, 4, 5)]) + restored <- .batch_restore_date_class(stripped, grid) + expect_s3_class(restored, "Date") + expect_equal(restored, grid[c(1, 4, 5)]) + # And when `setdiff()` keeps the class (seen on R 4.6.1). + expect_equal(.batch_restore_date_class(grid[c(1, 4, 5)], grid), grid[c(1, 4, 5)]) + expect_length(.batch_restore_date_class(numeric(0), grid), 0L) +}) + + test_that("simulate_batch() conserves items and only ever moves reports later", { skip_on_cran() clean_tbl <- make_flat_linelist() diff --git a/vignettes/articles/ensemble-nowcasting.Rmd b/vignettes/articles/ensemble-nowcasting.Rmd index 63b09b1d..2301d4cb 100644 --- a/vignettes/articles/ensemble-nowcasting.Rmd +++ b/vignettes/articles/ensemble-nowcasting.Rmd @@ -244,6 +244,10 @@ One can visualize the ensemble with `autoplot()` or get its results with `tidy() autoplot(ensemble_nowcast, date_lim = c(as.Date("2010/10/01"), as.Date("2010/12/20"))) ``` +::: {.alert .alert-info} +You can combine multiple backtests for different models with `backtest_combine` +::: + ## 4. Adding your own model You can add any model built by yourself or from any other package to the fitting so that it has its own engine, its own tidy to clean and can be used in conjunction with `tidy()`, `autoplot()` as well as the backtesting and ensemble methods. You can read more about it in [the corresponding article](https://rodrigozepeda.github.io/tbl.now/articles/custom-nowcast-models.html).