diff --git a/.gitignore b/.gitignore index ceb8a035..8e228ddf 100644 --- a/.gitignore +++ b/.gitignore @@ -68,3 +68,6 @@ cheatsheet/output/ # Curated and preliminary assessment outputs are local generated artifacts. analysis/comp_assessments/results/ + +# Manually refreshed SAIO source snapshots; the selected revision is tracked. +analysis/comp_assessments/cache/saio/ diff --git a/AGENTS.md b/AGENTS.md index f3356f0a..57a4574f 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -61,6 +61,11 @@ transparent, and consistent with existing package structure. - Run targeted tests first, then the full test suite. - Run `R CMD check` for substantial changes when practical. - Do not weaken existing tests merely to make new code pass. +- Share fitted fixtures across tests; refit or render HTML only when that + operation protects behavior not already covered. Judge coverage by meaningful + contracts rather than the number of assertions. +- Retired interfaces and old saved-object migrations need no compatibility + tests. Preserve checks of current scientific conventions, including M blocks. ## RTMB / model conventions diff --git a/NAMESPACE b/NAMESPACE index 6b6f5716..a5f9fd60 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,7 +20,6 @@ export(ar1) export(as_tam_data) export(bh) export(cAIC) -export(check_obs) export(check_tam) export(check_tam_data) export(compute_hindcast_mase) @@ -74,7 +73,6 @@ export(stack_nested) export(tam_cols) export(tam_pal) export(tidy_array) -export(tidy_mat) export(tidy_obs_pred) export(tidy_par) export(tidy_pop) diff --git a/NEWS.md b/NEWS.md index c1ae37ff..57f0b752 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,14 @@ # tinyAM 0.1.1.9001 +* Organize plots by purpose and colocate population getters. Share fitted test + fixtures, remove redundant renders and unused implementations, and retire the + `check_obs()` and `tidy_mat()` aliases in favor of `check_tam_data()` and + `tidy_array()`. Old saved-fit migrations are no longer maintained. + +* Open dashboards on Model structure, with Diagram and Function calls tabs. + Use responsive, palette-colored boxes with normal dashboard typography and + SVG connections, without adding a diagramming dependency. + * Restore catch-only preparation, projections, simulation and tidy outputs, retaining empty survey tables without unused catchability or survey-SD parameters. Render reporting references with missing yield, observations or @@ -10,10 +19,11 @@ Compare stored specifications with an independent model selector; link components to maintained equations without calculating or changing fits. -* Add Auto / Standardized / OSA controls to public residual plots and dashboards. - Auto selects retained OSAs separately for each model and panel, preserving - partial gaps and models without OSA calculations. Labels identify the method; - changing plot controls never calculates residuals. +* Offer Standardized / OSA residual controls without bubble outlines. Start with + retained OSAs when available; overlays use a common residual type and model + frames choose separately. Preserve partial gaps and identify the OSA method; + plotting never calculates residuals. Explicit row-wise hover values stay + aligned through model frames and missing residuals. * Select any supported OSA algorithm through `method` and retain diagnostics with `add_osa_residuals()`, without refitting. Explicit computation requests @@ -32,10 +42,10 @@ rotations, while rejecting changes to predictor grids or Gaussian penalties. This fixes platform-dependent retrospective warm-start checks. -* Read assessment examples from SAIO's latest committed main by default, recording - the exact source revision and separating caches by database version. Explicit - revisions remain available for reproducing historical results. Keep curated - and preliminary translation membership and outputs separate. +* Run comparative assessments from an explicitly refreshed local SAIO snapshot, + recording its commit in a tracked manifest. Separate fitting, dashboard + rendering and overview figures; honor the caller's future plan. Keep curated + and preliminary membership and revision-specific result caches separate. * Group fishery diagnostics under Fisheries: one complete page per fleet, followed by Aggregate fishery. Unlabeled catches remain stock-wide; aggregate diff --git a/R/check.R b/R/check.R index 5ef30a66..66587ea8 100644 --- a/R/check.R +++ b/R/check.R @@ -59,7 +59,7 @@ #' @param model_list Optional named list of fitted `tam_fit` objects. Supply #' this or individual models, not both. #' @param grad_tol Positive gradient tolerance. `NULL` uses the tolerance stored -#' in the fit, or `1e-2` if none is stored. +#' in the fit. #' @param detailed Examine covariance eigenvalues and weak parameter directions? #' @return For one individual model, a `tam_check` list with `is_converged`, `numerical`, `structural`, #' `structural_status`, `advisories`, `residuals`, `data`, and `curvature`. @@ -99,7 +99,7 @@ check_tam <- function(fit, ..., grad_tol = NULL, detailed = FALSE, model_list = .check_tam_fit <- function(fit, grad_tol = NULL, detailed = FALSE) { fit <- .require_tam_fit(fit, arg = "fit") - if (is.null(grad_tol)) grad_tol <- if (is.null(fit$grad_tol)) 1e-2 else fit$grad_tol + if (is.null(grad_tol)) grad_tol <- fit$grad_tol if (!is.numeric(grad_tol) || length(grad_tol) != 1L || !is.finite(grad_tol) || grad_tol <= 0) { cli::cli_abort("{.arg grad_tol} must be one positive finite number.") diff --git a/R/data.R b/R/data.R index bf35051f..16268207 100644 --- a/R/data.R +++ b/R/data.R @@ -526,15 +526,3 @@ check_tam_data <- function(data, quiet = FALSE) { invisible(NULL) } -#' Check the structure of a TAM obs list -#' -#' A convenience wrapper for [check_tam_data()]. -#' @param obs A named list of tinyAM input tables. -#' @inheritParams check_tam_data -#' @inherit check_tam_data details -#' @return `TRUE` (invisibly) if validation passes; otherwise aborts. -#' @examples -#' check_tam_data(cod_obs) -#' @export -check_obs <- function(obs, quiet = FALSE) check_tam_data(obs, quiet = quiet) - diff --git a/R/fit.R b/R/fit.R index 13c43dc9..f4189c9c 100644 --- a/R/fit.R +++ b/R/fit.R @@ -73,13 +73,10 @@ .start_parameters <- function(start, dat) { if (inherits(start, "tam_fit")) { source <- start - if (!is.null(source$parameter_values) && !is.null(source$obj)) { - start <- source$obj$env$parList(par = source$parameter_values) - } else if (!is.null(source$sdrep)) { - start <- as.list(source$sdrep, "Estimate") - } else { + if (is.null(source$parameter_values) || is.null(source$obj)) { cli::cli_abort("Starting fit has no stored parameter estimates.") } + start <- source$obj$env$parList(par = source$parameter_values) if (identical(source$dat$rec$type, "off") && !is.null(source$rep$recruitment)) { years <- source$dat$rec$eligible start$log_r <- setNames(log(source$rep$recruitment[years]), source$dat$years[years]) @@ -98,7 +95,6 @@ start$log_f <- start$log_f[, keep, drop = FALSE] } else { old <- source$dat$F_settings$age_blocks - if (is.null(old)) old <- stats::setNames(as.character(source$dat$ages), source$dat$ages) new <- dat$F_settings$age_blocks groups <- intersect(colnames(start$log_f), levels(new)) keep <- vapply(groups, function(g) identical(names(old)[as.character(old) == g], names(new)[as.character(new) == g]), logical(1)) @@ -165,35 +161,18 @@ #' optimizes the remaining fixed effects. [mono()] increments `dq` and `dmu_f` have a zero #' lower bound, as do initial-abundance decrements `d_n0`. Their SEs remain on the increment scale, but symmetric Wald #' intervals are only local approximations at a boundary. -#' Set `index_settings$q_link = "logit"` to restrict the full catchability -#' prediction to between zero and one; the default `"log"` allows q above one. -#' Formula coefficients are then named `logit_q`, and [mono()] increments -#' act on logit-q. Starting q coefficients must use the selected link scale: -#' old `log_q` starts are not reused as `logit_q`. See [prepare_tam()] and [tidy_par()]. -#' -#' Random-effect blocks are chosen automatically from the model settings: -#' -#' - Includes `log_f` when the F process is active, and eligible `log_r` states when recruitment is stochastic. Early recruitment -#' anchors are fixed; see [recruitment_formulas]. -#' - Includes `log_n0` only if `N_settings$init == "latent"`. -#' - Includes `log_n` if `N_settings$process != "off"`. -#' - Includes `log_m` if `M_settings$process != "off"`. -#' - Includes the unique `eta_q_*` states of Gaussian catchability formula terms. -#' - Includes Gaussian F/M mean and catch/index log-SD formula states. -#' Logistic midpoint/slope and process SD/correlation are fixed effects. +#' Random-effect blocks are chosen from the active processes and Gaussian +#' formula effects. Initial abundance and recruitment boundaries are integrated +#' only when their respective `init` setting is `"latent"`; see [tinyAM-model] +#' and [recruitment_formulas]. [make_par()] describes the parameter layout. #' #' A warning is issued if the number of random effects exceeds 1.5 times the #' number of observed data points (rough identifiability check). #' -#' For F random walks, [prepare_tam()] removes time-invariant mean columns -#' because they cancel from all increments. For M random walks, mean coefficients -#' with no effect on either increments or mortality outside the fitted process -#' states are held at their starting values. -#' An RW SD is also held fixed if the process has only one row (no increments). -#' These parameters cannot be estimated from the likelihood; no constraint is -#' imposed on the latent states themselves. -#' For AR1, the correlation for an axis containing a single row or column is -#' fixed at zero; otherwise it would be confounded with the SD. +#' Parameters without likelihood support are removed or fixed: examples include +#' constant mean directions canceled by RW increments, RW SDs with no increments, +#' and AR1 correlations on singleton axes. The latent states themselves retain +#' the conventions in [tinyAM-model]. #' #' `is_converged` summarizes optimizer, gradient and uncertainty checks. Also inspect #' `opt$convergence` and `opt$message`; a passing numerical check does not @@ -223,6 +202,8 @@ #' structure returned by [make_par()]. Useful for warm starts or retrospective #' runs where parameter estimates from a previous fit are reused to improve #' convergence and speed. Non-matching or missing entries are ignored. +#' Fitted-object starts require the current stored parameter modes; regenerate +#' older saved fits. Catchability coefficients are omitted if `q_link` changes. #' @param grad_tol Numeric tolerance passed to [check_tam()] when #' evaluating the fitted object's gradients. Defaults to `1e-2`. #' diff --git a/R/getters.R b/R/getters.R index 5e32a3a9..1a09492e 100644 --- a/R/getters.R +++ b/R/getters.R @@ -102,3 +102,63 @@ get_m <- function(..., model_list = NULL, interval = 0.95) { .unit_label(tab, "") tab } + +# Population-only collection shared by tidy_tam() and the quantity getters. +# Keep comparison conversions here so lightweight consumers use the same units +# and reported-versus-log SE conventions as dashboards. +.population_tables <- function(model_list, interval) { + pop_list <- lapply(model_list, function(fit) { + if (inherits(fit, "tam_ref")) return(fit$pop) + stored <- attr(fit$pop, "interval", exact = TRUE) + if (!is.null(fit$pop) && !is.null(stored) && + isTRUE(all.equal(stored, interval))) { + fit$pop + } else { + tidy_pop(fit, interval = interval) + } + }) + references <- Filter(function(fit) inherits(fit, "tam_ref"), model_list) + comparison_scales <- lapply(references, `[[`, "comparison_scales") + comparison_scales <- Filter(function(x) length(x) > 0L, comparison_scales) + if (length(comparison_scales)) { + comparison_scales <- lapply(comparison_scales, function(x) { + if (is.list(x)) x <- unlist(x, use.names = TRUE) + if (!is.numeric(x) || is.null(names(x)) || any(!nzchar(names(x))) || + anyDuplicated(names(x)) || any(!is.finite(x)) || any(x <= 0)) { + cli::cli_abort("A {.cls tam_ref} {.field comparison_scales} value must be a named vector of positive finite numbers.") + } + x + }) + if (length(comparison_scales) > 1L && + !all(vapply(comparison_scales[-1L], identical, logical(1), comparison_scales[[1L]]))) { + cli::cli_abort("Assessment references use different {.field comparison_scales}; the fitted outputs cannot be shown on one scale.") + } + comparison_scales <- comparison_scales[[1L]] + reference_pop <- references[[1L]]$pop + for (i in seq_along(model_list)) { + if (inherits(model_list[[i]], "tam_ref")) next + for (metric in intersect(names(comparison_scales), names(pop_list[[i]]))) { + tab <- pop_list[[i]][[metric]] + scale <- comparison_scales[[metric]] + reference <- reference_pop[[metric]] + from <- unique(tab$unit[!is.na(tab$unit)]) + to <- unique(reference$unit[!is.na(reference$unit)]) + if (length(from) == 1L && length(to) == 1L) .check_unit_conversion(from, to, scale) + for (field in intersect(c("est", "lwr", "upr"), names(tab))) { + tab[[field]] <- tab[[field]] * scale + } + if ("se" %in% names(tab)) { + natural <- if ("se_scale" %in% names(tab)) tab$se_scale == "reported" else rep(TRUE, nrow(tab)) + tab$se[which(natural)] <- tab$se[which(natural)] * scale + } + if (is.data.frame(reference) && "unit" %in% names(reference)) { + units <- unique(as.character(reference$unit[!is.na(reference$unit) & + nzchar(as.character(reference$unit))])) + if (length(units) == 1L) tab$unit <- units[[1L]] + } + pop_list[[i]][[metric]] <- tab + } + } + } + pop_list +} diff --git a/R/model-diagram.R b/R/model-diagram.R index 039e876b..406b3b25 100644 --- a/R/model-diagram.R +++ b/R/model-diagram.R @@ -26,7 +26,7 @@ #' objective, sampling uncertainty, calculating residuals or changing the fit. #' No additional diagramming package is required. #' -#' @return A browsable HTML container with a responsive SVG diagram and model +#' @return A browsable HTML container with responsive HTML nodes, SVG connectors and model #' settings. Display it directly, or save it with [htmltools::save_html()]. #' @examples #' \dontrun{ @@ -53,25 +53,42 @@ plot_model <- function(..., model_list = NULL) { }) selector <- if (length(fits) > 1L) htmltools::tags$label( "Model ", htmltools::tags$select(`aria-label` = "Model structure model", - onchange = paste0("var c=this.closest('.tam-model-structure');", - "var v=this.value;c.querySelectorAll('[data-model-pane]').forEach(", - "function(p){p.style.display=p.getAttribute('data-model-pane')===v?'':'none';});"), + `data-model-selector` = "", lapply(seq_along(fits), function(i) htmltools::tags$option( value = as.character(i), selected = if (i == first) "selected" else NULL, names(fits)[i])))) htmltools::browsable(htmltools::tags$div(class = "tam-model-structure", htmltools::tags$style(htmltools::HTML(paste0( - ".tam-model-structure{font-family:Arial,sans-serif;color:#1f2933;background:#fff;padding:8px;overflow:auto}", + ".tam-model-structure{font:inherit;color:#1f2933;background:#fff;padding:8px;overflow:auto}", ".tam-model-structure select{margin:0 0 12px 8px;padding:5px;max-width:80%}", - ".tam-model-structure svg{width:100%;height:auto;min-width:630px;display:block}", + ".tam-model-graph{position:relative;display:grid;grid-template-columns:repeat(4,minmax(0,1fr));", + "grid-template-areas:'initial . . survey' 'recruitment . population .' 'fishing natural ssb catch';", + "gap:2.5em 2em;padding:1.5em;isolation:isolate}", + ".tam-model-connectors{position:absolute;inset:0;width:100%;height:100%;pointer-events:none;z-index:-1}", + ".tam-model-node-wrap{min-width:0;align-self:center}", + ".tam-model-node{font:inherit;background:#f1f3f5;border:1px solid #c5ced3;border-radius:8px;padding:.75em}", + ".tam-model-node[data-process='stochastic']{background:#d9e2e6;border-color:#8caab6}", + ".tam-model-node[data-process='deterministic']{background:#fde7df;border-color:#e3ad98}", + ".tam-model-node h4{font:inherit;font-weight:bold;margin:0 0 .4em}", + ".tam-model-node p{font:inherit;font-size:.875em;margin:.35em 0;overflow-wrap:anywhere}", + ".tam-model-node code{font-size:.85em;white-space:normal;overflow-wrap:anywhere;color:inherit;background:transparent;padding:0}", + ".tam-model-input{font-size:.8em;overflow-wrap:anywhere;background:#fff8df;border:1px dashed #af8a27;", + "border-radius:4px;padding:.35em .5em;margin-bottom:max(1em,16px)}", + ".tam-model-connections{position:absolute;width:1px;height:1px;padding:0;margin:-1px;overflow:hidden;clip:rect(0,0,0,0)}", + ".tam-model-graph[data-layout='compact']{grid-template-columns:repeat(2,minmax(0,1fr));", + "grid-template-areas:'initial recruitment' 'fishing natural' 'population population' 'survey catch' 'ssb ssb'}", + ".tam-model-graph[data-layout='stacked']{grid-template-columns:minmax(0,1fr);", + "grid-template-areas:'initial' 'recruitment' 'fishing' 'natural' 'population' 'survey' 'catch' 'ssb'}", ".tam-model-cards{display:grid;grid-template-columns:repeat(auto-fit,minmax(235px,1fr));gap:12px}", ".tam-model-card{border:1px solid #d6dce0;border-top:3px solid #007187;padding:10px}", - ".tam-model-card h4{font-size:16px;color:#003e56;margin:0 0 6px}", - ".tam-model-card p{font-size:13px;margin:4px 0;overflow-wrap:anywhere}", - ".tam-model-card code{font-size:12px;white-space:pre-wrap}", - ".tam-model-legend,.tam-model-note{font-size:13px;margin:8px 0 12px}", + ".tam-model-card h4{font:inherit;font-weight:bold;color:#003e56;margin:0 0 6px}", + ".tam-model-card p{font-size:.875em;margin:4px 0;overflow-wrap:anywhere}", + ".tam-model-card code{font-size:.85em;white-space:pre-wrap}", + ".tam-model-legend,.tam-model-note{font-size:.875em;margin:8px 0 12px}", ".tam-model-unavailable{padding:25px;border:1px solid #d6dce0}"))), - selector, panes)) + selector, panes, + htmltools::tags$script(htmltools::HTML(paste(readLines( + system.file("js", "model-structure.js", package = "tinyAM"), warn = FALSE), collapse = "\n"))))) } .model_structure_spec <- function(dat) { @@ -190,12 +207,8 @@ plot_model <- function(..., model_list = NULL) { .model_structure_view <- function(dat, label) { spec <- .model_structure_spec(dat) - escape <- function(x) as.character(htmltools::htmlEscape(x)) - shorten <- function(x, width = 34L) if (nchar(x) > width) + shorten <- function(x, width = 65L) if (nchar(x) > width) paste0(substr(x, 1L, width - 3L), "...") else x - positions <- list(initial = c(30, 35), recruitment = c(30, 200), - fishing = c(30, 370), natural = c(310, 370), population = c(590, 200), - catch = c(920, 370), survey = c(920, 35), ssb = c(590, 425)) subtitles <- c(initial = "Boundary parameters", recruitment = "New youngest-age fish", fishing = "Total F = sum of fleet F", natural = "Shared population M", population = "Survivors + recruitment", catch = "Fleet catch predictions", @@ -204,79 +217,44 @@ plot_model <- function(..., model_list = NULL) { fishing = "Fishing mortality", natural = "Natural mortality", population = "Population abundance", catch = "Catch observations", survey = "Survey observations", ssb = "Spawning biomass") - arrow <- function(points) { - n <- nrow(points) - direction <- points[n, ] - points[n - 1L, ] - direction <- direction / sqrt(sum(direction^2)) - tip <- points[n, ]; base <- tip - 9 * direction - normal <- c(-direction[2L], direction[1L]) * 4 - paste0('', - '') - } - edges <- list(rbind(c(270, 90), c(550, 90), c(550, 215), c(590, 215)), - rbind(c(270, 255), c(590, 255)), - rbind(c(270, 425), c(295, 425), c(295, 335), c(640, 335), c(640, 310)), - rbind(c(550, 425), c(570, 425), c(570, 290), c(590, 290)), - rbind(c(830, 230), c(875, 230), c(875, 90), c(920, 90)), - rbind(c(830, 280), c(875, 280), c(875, 425), c(920, 425)), - rbind(c(150, 480), c(150, 548), c(1040, 548), c(1040, 480)), - rbind(c(710, 310), c(710, 425))) - if (spec$feedback) edges[[length(edges) + 1L]] <- - rbind(c(590, 480), c(285, 480), c(285, 275), c(270, 275)) - nodes <- vapply(names(positions), function(id) { - p <- positions[[id]] + nodes <- lapply(names(titles), function(id) { status <- spec$statuses[id] stochastic <- length(status) && !is.na(status) && status != "off" - fill <- if (stochastic) "#d9efed" else "#f0f3f5" + state <- if (is.na(status)) "neutral" else if (stochastic) "stochastic" else "deterministic" annotation <- if (is.na(status)) "" else if (stochastic) paste("Stochastic", toupper(status)) else "Deterministic: process off" - title <- paste(spec$cards[[id]]$lines, collapse = "\n") - paste0('', escape(title), '', - '', - '', escape(titles[id]), '', - '', escape(subtitles[id]), '', - '', escape(annotation), '', - '', escape(shorten(spec$formula_labels[id])), '') - }, character(1)) - input_arrows <- vapply(names(spec$inputs)[nzchar(spec$inputs)], function(id) { - p <- positions[[id]] - paste0('', escape(spec$inputs[id]), '', - '', - '', - escape(shorten(spec$inputs[id], 36L)), '', - '', - '') - }, character(1)) - svg <- paste0('', - 'Model structure: ', escape(label), '', - paste(vapply(edges, arrow, character(1)), collapse = ""), paste(nodes, collapse = ""), - paste(input_arrows, collapse = ""), - if (spec$feedback) paste0('', - escape(spec$feedback_label), '') else "", '') + input <- spec$inputs[id] + htmltools::tags$div(class = "tam-model-node-wrap", style = paste0("grid-area:", id), + if (length(input) && !is.na(input) && nzchar(input)) htmltools::tags$div( + class = "tam-model-input", `data-input-component` = id, title = input, input), + htmltools::tags$section(class = "tam-model-node", `data-component` = id, + `data-process` = state, title = paste(spec$cards[[id]]$lines, collapse = "\n"), + htmltools::tags$h4(titles[id]), htmltools::tags$p(subtitles[id]), + if (nzchar(annotation)) htmltools::tags$p(annotation), + htmltools::tags$code(`data-formula` = id, spec$formula_labels[id] |> shorten()), + if (id == "ssb" && spec$feedback) htmltools::tags$p(spec$feedback_label))) + }) + edges <- list(c("initial", "population"), c("recruitment", "population"), + c("fishing", "population"), c("natural", "population"), + c("population", "survey"), c("population", "catch"), + c("fishing", "catch"), c("population", "ssb")) + if (spec$feedback) edges[[length(edges) + 1L]] <- c("ssb", "recruitment") + graph <- htmltools::tags$div(class = "tam-model-graph", role = "group", + `aria-label` = paste("Model structure:", label), `data-feedback` = tolower(spec$feedback), + htmltools::HTML(''), + nodes, + htmltools::tags$ul(class = "tam-model-connections", lapply(edges, function(edge) + htmltools::tags$li(paste(titles[edge], collapse = " to "))))) cards <- lapply(spec$cards, function(card) htmltools::tags$section(class = "tam-model-card", htmltools::tags$h4(card$title), lapply(card$lines, htmltools::tags$p), htmltools::tags$a(href = paste0("https://paulregular.github.io/tinyAM/reference/", card$help, ".html"), "Equations and settings"))) - htmltools::tagList(htmltools::tags$p(class = "tam-model-note", - "Stored specification for ", htmltools::tags$strong(label), - ". Arrows show biological and observation relationships, not a computation order."), - htmltools::HTML(svg), htmltools::tags$p(class = "tam-model-legend", - "Teal: annual stochastic process. Gray: no annual process deviations. ", + htmltools::tagList(graph, htmltools::tags$p(class = "tam-model-legend", + "Navy: annual stochastic process. Orange: no annual process deviations. ", "Dashed arrows: active input-table predictors. Process off retains the biological component. ", "Initial parameters and observations are separate."), + htmltools::tags$p(class = "tam-model-note", + "Arrows show biological and observation relationships, not a computation order."), htmltools::tags$details(htmltools::tags$summary("Formulas and settings"), htmltools::tags$div(class = "tam-model-cards", cards))) } diff --git a/R/model.R b/R/model.R index 24ce2f4d..a50a869e 100644 --- a/R/model.R +++ b/R/model.R @@ -11,7 +11,7 @@ #' independent departures, `"ar1"` allows departures to be similar in adjacent #' years and ages, and `"rw"` allows departures to accumulate over time without #' returning to a mean. These choices make different assumptions, even when -#' they produce similar fitted curves. N and M can also have their process +#' they produce similar fitted curves. N, F and M can also have their process #' switched `"off"`. Recruitment defaults to a temporal random walk; #' `rec_settings$mu_form` can describe stock-recruit relationships and covariates. #' @@ -61,10 +61,6 @@ #' is a deviation from an expected log state, never an additional absolute state. #' All matrices have years in rows. Vectorization stacks columns, as in R. #' -#' Numbers and weights must use consistent units. There is no automatic unit -#' conversion. For [cod_obs], numbers in thousands and weights in kg give -#' biomass in tonnes. Survey catchability absorbs differences in survey units. -#' #' ## Recruitment and initial abundance #' #' Recruitment is \eqn{R_t=N_{t,1}}. The first log recruitment `log_r0` is an @@ -93,6 +89,9 @@ #' \eqn{\log N_{1,a}=\log r_0-\sum_{j=2}^a d_j}; for `"capped"`, #' \eqn{\log N_{1,a}=\log r_0-d_a}, with \eqn{d_j\ge0}. #' These fixed constraints include the terminal plus group and allow ties. +#' A pooled plus group can exceed a single age's abundance, so imposing these +#' constraints on it is a deliberate biological assumption. Wald intervals +#' at a constraint boundary are only local approximations. #' The baseline always uses the realized preceding initial-age state. #' No equilibrium plus-group correction is applied in this first year. #' This is an initial-state assumption, not a reconstruction of past cohorts. @@ -399,9 +398,9 @@ #' observation draws then use each row's SD. Initial RW #' states are retained: F/M walks start from the supplied first latent row; #' the N walk retains its first `log_n` row and computes that row's residual -#' against the newly generated cohort prediction. Random N0 is redrawn; free -#' N0, first recruitment and additional early boundary recruitment states -#' remain supplied fixed states. +#' against the newly generated cohort prediction. Initial older-age abundance, +#' first recruitment and additional early recruitment boundaries retain their +#' supplied values, including when integrated with `init = "latent"`. #' #' [sim_tam()] can hold parameters fixed, draw fixed effects with their estimated #' covariance while retaining fitted random states, or draw all parameters with diff --git a/R/mortality-blocks.R b/R/mortality-blocks.R index 6c59059e..5066f725 100644 --- a/R/mortality-blocks.R +++ b/R/mortality-blocks.R @@ -37,7 +37,6 @@ return(x[, rows, drop = FALSE]) } starts <- dat$F_settings$age_block_start - if (is.null(starts)) return(x) # Saved fits prepared before block support. x[, match(starts, dat$ages), drop = FALSE] } @@ -108,5 +107,5 @@ .f_state_rows <- function(dat) { if (dat$has_fleet) return(paste(dat$F_data$fleet, dat$F_data$age) %in% paste(dat$F_states$fleet, dat$F_states$age)) starts <- dat$F_settings$age_block_start - dat$F_data$age %in% if (is.null(starts)) dat$ages else starts + dat$F_data$age %in% starts } diff --git a/R/nll.R b/R/nll.R index 49328345..ec06a129 100644 --- a/R/nll.R +++ b/R/nll.R @@ -75,24 +75,6 @@ #' @importFrom stats rnorm #' @seealso [tinyAM-model], [prepare_tam()], [make_par()], [fit_tam()], [sim_tam()] #' @export -nll_fun <- function(f, d) function(p) f(p, d) -#' obj <- RTMB::MakeADFun(make_nll_fun(nll_fun, dat), par, -#' random = c("log_n", "log_f","log_r"), silent = TRUE -#' ) -#' opt <- nlminb(obj$par, obj$fn, obj$gr) -#' rep <- obj$report() -#' sdrep <- RTMB::sdreport(obj) -#' -#' # Simulate from fitted parameters -#' p_hat <- as.list(sdrep, "Estimate") -#' sims <- nll_fun(p_hat, dat, simulate = TRUE) -#' -#' @importFrom stats rnorm -#' -#' @seealso -#' [prepare_tam()], [make_par()], [fit_tam()], [sim_tam()], -#' [dprocess_ar1()], [rprocess_ar1()] -#' @export nll_fun <- function(par, dat, simulate = FALSE) { "[<-" <- ADoverload("[<-") diff --git a/R/plot-matrix.R b/R/plot-matrix.R new file mode 100644 index 00000000..95f9a6b1 --- /dev/null +++ b/R/plot-matrix.R @@ -0,0 +1,193 @@ +#' @name plot_tam +#' @rdname plot_tam +#' @export +plot_heatmap <- function( + data, + zlab = "Estimate", + title = "", + ... +) { + unit_label <- .unit_label(data, "Estimate") + if (missing(zlab)) zlab <- unit_label + args <- list(...) + if ("frame" %in% names(args) && !is.null(args$frame)) { + cli::cli_abort( + "Argument {.arg frame} is not supported for heatmaps. + Supply a single frame at a time, or split/filter your data by the grouping + variable and call {.fn plot_heatmap} per group." + ) + } + + plot_ly(data, + x = ~year, y = ~age, z = ~est, + colorbar = list(title = zlab), ... + ) |> + add_heatmap() |> + layout( + title = title, + xaxis = list(title = "Year"), + yaxis = list(title = "Age") + ) +} + + +#' Explore age-year patterns +#' +#' Display a complete or sparse age-year table as a heatmap, surface or contour. +#' Buttons change the metric, display type and value scale; an optional model +#' selector compares models using the same ranges within each metric. +#' +#' @param data A data frame with numeric `year`, `age` and `est` columns. +#' Optional `unit`, `definition`, `notes` and `is_proj` columns enrich hover text. +#' @param metric Optional one-sided formula selecting a metric column. +#' @param frame Optional one-sided formula selecting a model column. Factor +#' levels determine the initial model and selector order. +#' @param type Initial display: `"heatmap"`, `"surface"` or `"contour"`. +#' @param signed Use symmetric orange-white-navy ranges centred on zero and +#' disable the log control? Default `FALSE` preserves ordinary matrix plots. +#' @param y One-sided formula selecting the vertical coordinate, default `~age`. +#' Character/factor coordinates use ordered positions with each model's own +#' labels, suitable for unique M state blocks. +#' @param ylab Vertical-axis label, default `"Age"`. A named character vector +#' can supply a different label for each metric. +#' @param y_labels Optional one-sided formula selecting display labels for the +#' vertical coordinates, useful for model-specific state blocks. +#' @details Linear shows original estimates, including zero. Log displays +#' log10 estimates; nonpositive values are gaps. Hover text always shows +#' original values and units. Ranges are shared across models separately for +#' each metric. All models of a metric must use the same units. +#' Colours use the built-in [tam_cols()] ramp from low to high values. +#' Colour-ramp titles place units on a second line; axis labels remain on one line. +#' Missing cells remain missing. Surface and contour rendering interpolates +#' only for display and does not create additional source estimates. +#' @return A Plotly object with independent controls for each widget. +#' @examples +#' d <- expand.grid(year = 2000:2005, age = 1:5) +#' d$est <- exp(.1 * (d$year - 2000) - .3 * d$age) +#' plot_matrix(d) +#' @seealso [plot_heatmap()], [vis_tam()] +#' @export +plot_matrix <- function(data, metric = NULL, frame = NULL, + type = c("heatmap", "surface", "contour"), + signed = FALSE, y = ~age, ylab = "Age", y_labels = NULL) { + type <- match.arg(type) + if (!is.logical(signed) || length(signed) != 1L || is.na(signed)) cli::cli_abort("signed must be TRUE or FALSE.") + if (!inherits(y, "formula") || length(all.vars(y)) != 1L || !all.vars(y) %in% names(data)) { + cli::cli_abort("y must select one existing vertical-axis column.") + } + vertical <- data[[all.vars(y)]] + categorical <- !is.numeric(vertical) + if (anyNA(vertical)) cli::cli_abort("Vertical coordinates cannot be missing.") + data$.vertical_label <- as.character(vertical) + if (!is.null(y_labels)) { + if (!inherits(y_labels, "formula") || length(all.vars(y_labels)) != 1L || + !all.vars(y_labels) %in% names(data)) cli::cli_abort("y_labels must select one existing label column.") + data$.vertical_label <- as.character(data[[all.vars(y_labels)]]) + } + data$age <- if (categorical) match(vertical, unique(vertical)) else vertical + if (!is.data.frame(data) || !all(c("year", "age", "est") %in% names(data)) || + !nrow(data)) cli::cli_abort("{.arg data} must contain year, age and est rows.") + if (!all(vapply(data[c("year", "age", "est")], is.numeric, logical(1))) || + any(!is.finite(data$year)) || any(!is.finite(data$age))) { + cli::cli_abort("year, age and est must be numeric; year and age must be finite.") + } + column <- function(form, default) { + if (is.null(form)) return(rep(default, nrow(data))) + if (!inherits(form, "formula") || length(form) != 2L || + length(all.vars(form)) != 1L || !is.symbol(form[[2L]]) || + !all.vars(form) %in% names(data)) { + cli::cli_abort("metric and frame must each select one existing column.") + } + data[[all.vars(form)]] + } + metrics <- column(metric, "Estimate") + models <- column(frame, "Model") + if (anyNA(metrics) || anyNA(models)) cli::cli_abort("Metric and model labels cannot be missing.") + labels <- function(x) if (is.factor(x)) levels(droplevels(x)) else unique(as.character(x)) + metric_names <- labels(metrics) + model_names <- labels(models) + keys <- data.frame(year = data$year, age = data$age, metric = metrics, model = models) + if (anyDuplicated(keys)) cli::cli_abort("Duplicate year-age cells within a metric and model.") + rows <- function(x) unname(lapply(seq_len(nrow(x)), function(i) unname(x[i, ]))) + span <- function(x) { + x <- x[is.finite(x)] + if (!length(x)) return(c(0, 1)) + r <- range(x) + if (diff(r) == 0) r <- r + c(-1, 1) * max(abs(r[1]) * .01, .01) + unname(r) + } + spec <- lapply(metric_names, function(name) { + d <- data[as.character(metrics) == name, , drop = FALSE] + axis_label <- if (length(ylab) == 1L) unname(ylab) else unname(ylab[name]) + if (length(axis_label) != 1L || is.na(axis_label)) cli::cli_abort("ylab must supply a label for each metric.") + units <- if ("unit" %in% names(d)) unique(as.character(d$unit[is.finite(d$est) & + !is.na(d$unit) & nzchar(d$unit)])) else character() + if (length(units) > 1L) cli::cli_abort("Metric {.val {name}} has different units; convert them before plotting.") + unit <- if (length(units)) units[1L] else "" + years <- sort(unique(d$year)) + ages <- sort(unique(d$age)) + grid <- expand.grid(age = ages, year = years) + cells <- lapply(model_names, function(model) { + z <- d[as.character(models[as.character(metrics) == name]) == model, , drop = FALSE] + cell_ages <- ages + ticktext <- as.character(ages) + if (categorical) { + ticks <- unique(z$.vertical_label) + # Retain each model's own ordered state blocks rather than a union of ages. + z$age <- match(z$.vertical_label, ticks) + cell_ages <- seq_along(ticks) + ticktext <- ticks + if (!length(cell_ages)) { cell_ages <- 1; ticktext <- "Unavailable" } + } else if (!is.null(y_labels)) { + cell_ages <- sort(unique(z$age)) + ticktext <- z$.vertical_label[match(cell_ages, z$age)] + if (!length(cell_ages)) { cell_ages <- 1; ticktext <- "" } + } + grid <- expand.grid(age = cell_ages, year = years) + index <- match(paste(grid$year, grid$age), paste(z$year, z$age)) + values <- z$est[index] + values[!is.finite(values)] <- NA_real_ + text <- paste0("Model: ", model, "
", name, ": ", format(values, trim = TRUE), + if (nzchar(unit)) paste0(" ", unit) else "", "
Year: ", grid$year, + if ("is_proj" %in% names(z)) ifelse(!is.na(z$is_proj[index]) & z$is_proj[index], " (projection)", "") else "", + "
", axis_label, ": ", + if (categorical || !is.null(y_labels)) ticktext[match(grid$age, cell_ages)] else grid$age, + .forecast_hover(z)[index]) + for (field in intersect(c("definition", "notes"), names(z))) { + value <- as.character(z[[field]][index]) + text <- paste0(text, ifelse(is.na(value) | !nzchar(value), "", paste0("
", value))) + } + natural <- matrix(values, nrow = length(cell_ages)) + logged <- natural + logged[logged <= 0] <- NA_real_ + logged <- log10(logged) + list(linear = rows(natural), log = rows(logged), + ages = cell_ages, ticktext = ticktext, + text = rows(matrix(text, nrow = length(cell_ages)))) + }) + list(name = name, unit = unit, years = years, ages = ages, cells = cells, ylab = axis_label, + linear = if (signed) c(-1, 1) * max(c(abs(d$est[is.finite(d$est)]), .01)) else span(d$est), + log = span(log10(d$est[is.finite(d$est) & d$est > 0]))) + }) + colours <- tam_cols() + colorscale <- unname(Map(list, seq(0, 1, length.out = length(colours)), colours)) + if (signed) colorscale <- list(list(0, tail(tam_cols(), 1L)), list(.5, "#FFFFFF"), list(1, tam_cols()[1L])) + config <- list(metrics = spec, models = model_names, type = type, colorscale = colorscale, + signed = signed, ylab = ylab, categorical = categorical || !is.null(y_labels)) + script <- paste(readLines(system.file("js", "matrix.js", package = "tinyAM"), + warn = FALSE), collapse = "\n") + initial_metric <- if (signed) which(vapply(spec, function(metric) any(vapply(metric$cells, + function(cell) any(is.finite(unlist(cell$linear))), logical(1))), logical(1)))[1L] else 1L + if (is.na(initial_metric)) initial_metric <- 1L + config$initial_metric <- initial_metric - 1L + first <- spec[[initial_metric]] + initial <- if (signed) which(vapply(first$cells, function(cell) any(is.finite(unlist(cell$linear))), logical(1)))[1L] else 1L + if (is.na(initial)) initial <- 1L + cell <- first$cells[[initial]] + p <- plotly::plotly_build(plotly::plot_ly(x = first$years, y = cell$ages, + z = matrix(0, nrow = length(cell$ages), ncol = length(first$years)), + type = type)) + p$x$data[[1L]]$z <- cell$linear + p$x$data[[1L]]$colorscale <- colorscale + htmlwidgets::onRender(p, script, data = config) +} diff --git a/R/plot-parameters.R b/R/plot-parameters.R new file mode 100644 index 00000000..0a73c656 --- /dev/null +++ b/R/plot-parameters.R @@ -0,0 +1,86 @@ +#' @name plot_tam +#' @rdname plot_tam +#' @export +plot_par <- function(data, ...) { + data$coef <- factor(ifelse(is.na(data$coef), data$par, paste0(data$par, ": ", data$coef))) + + args <- list(...) + if (is.null(args$color)) { + args$color <- I("#377EB8") + } + p <- do.call(plot_ly, c(list(data = data, x = ~est, y = ~coef), args)) + + if (any(is.finite(data$lwr) & is.finite(data$upr))) { + p <- p |> + add_segments( + x = ~lwr, xend = ~upr, + y = ~coef, yend = ~coef, + showlegend = FALSE + ) + } + p |> + add_markers(showlegend = TRUE) |> + layout( + xaxis = list( + title = "Estimate" + ), + yaxis = list( + title = "" + ) + ) +} + +# Signed formula effects use a linear axis and a zero reference. Keep the +# existing trend/ribbon implementation for temporal effects. +.plot_formula_effect <- function(data, points = FALSE, frame = NULL, ...) { + if (!nrow(data)) { + return(plotly::plot_ly()) + } + limits <- range(c(0, data$est, data$lwr, data$upr), finite = TRUE) + pad <- max(diff(limits) * .05, .01) + if (points) { + p <- plotly::plot_ly(data, + x = ~coordinate, y = ~est, frame = frame, + error_y = list( + type = "data", array = ~ upr - est, + arrayminus = ~ est - lwr, symmetric = FALSE + ), ... + ) |> + plotly::add_markers() + } else { + p <- plot_trend(data, + x = ~coordinate, xlab = unique(data$variable)[1L], + frame = frame, add_buttons = FALSE, ... + ) + } + shapes <- list(list( + type = "line", x0 = 0, x1 = 1, xref = "paper", y0 = 0, y1 = 0, + line = list(color = "grey", width = 1) + )) + if (any(data$is_proj)) { + boundary <- max(data$coordinate[!data$is_proj]) + shapes <- c(shapes, list(list( + type = "line", x0 = boundary, x1 = boundary, + y0 = 0, y1 = 1, yref = "paper", line = list(color = "black", dash = "dot", width = 1) + ))) + } + plotly::layout(p, + xaxis = list( + title = unique(data$variable)[1L], + tickvals = unique(data$coordinate), ticktext = unique(data$level) + ), + yaxis = list( + title = if ("component" %in% names(data) && unique(data$component) != "q") { + if (startsWith(unique(data$component), "sd_")) { + "Effect on log SD" + } else { + paste("Effect on log", unique(data$component)) + } + } else { + "Effect on catchability's link scale" + }, type = "linear", + range = limits + c(-pad, pad) + ), shapes = shapes + ) +} + diff --git a/R/plot-process.R b/R/plot-process.R index 7225e1dc..64308de6 100644 --- a/R/plot-process.R +++ b/R/plot-process.R @@ -174,6 +174,7 @@ plot_process_residuals <- function(out, component = c("NFM", "Recruitment")) { trace$marker$sizeref <- 2 * limit / 30^2 trace$marker$sizemode <- "area" trace$marker$sizemin <- 0 + trace$marker$line <- list(width = 0) trace$frame <- NULL trace }) diff --git a/R/residual-selection.R b/R/plot-resid.R similarity index 70% rename from R/residual-selection.R rename to R/plot-resid.R index 01556407..7810518c 100644 --- a/R/residual-selection.R +++ b/R/plot-resid.R @@ -1,3 +1,79 @@ +#' @name plot_tam +#' @rdname plot_tam +#' @export +plot_bubbles <- function(data, res = NULL, y = ~age, ylab = "Age", title = NULL, + residual_type = c("auto", "standardized", "osa"), ...) { + if (is.null(res)) { + return(.plot_observation_residuals(data, match.arg(residual_type), "bubbles", + list(...), y = y, ylab = ylab, title = title)) + } + if (!is.null(res)) { + if (!inherits(res, "formula") || length(res) != 2L) cli::cli_abort("res must be a one-sided formula selecting a numeric column.") + values <- stats::model.frame(res, data, na.action = stats::na.pass) + if (ncol(values) != 1L) cli::cli_abort("res must select one signed numeric column.") + data$res <- values[[1L]] + if (!is.numeric(data$res)) cli::cli_abort("res must select a signed numeric column.") + if (is.null(title)) title <- "Process deviations" + } + data$sign <- ifelse(data$res > 0, "+", "-") + # Break size ties deterministically without advancing the caller's RNG. + data$abs_res <- abs(data$res) + seq_len(nrow(data)) * .Machine$double.eps + data <- data[!is.na(data$res), ] + # Unused factor levels create empty Plotly animation frames and can leave + # the initial bubble chart blank when some models lack this process. + data <- droplevels(data) + data$.bubble_text <- if ("kind" %in% names(data)) paste0(data$kind, ": ", round(data$res, 2)) else as.character(round(data$res, 2)) + + args <- list(...) + if (is.null(args$colors)) { + args$colors <- c(utils::head(tam_cols(), 1), tail(tam_cols(), 1)) + } + if (is.null(args$text)) args$text <- ~.bubble_text + + p <- do.call( + plotly::plot_ly, + c( + list( + data = data, + x = ~year, + y = y, + marker = list( + line = list(width = 0), + size = ~abs_res, + sizemin = 1, + sizeref = 0.01, + sizemode = "area" + ), + color = ~sign + ), + args + ) + ) + + p |> + plotly::add_markers() |> + plotly::layout( + title = title, + xaxis = list(title = "Year"), + yaxis = list(title = ylab) + ) +} + + +#' @name plot_tam +#' @rdname plot_tam +#' @export +plot_resid <- function( + data, + x = ~year, + xlab = "Year", + residual_type = c("auto", "standardized", "osa"), + ... +) { + .plot_observation_residuals(data, match.arg(residual_type), "scatter", + list(...), x = x, xlab = xlab) +} + # Observation plots consume retained residuals; selecting a view never invokes # residuals() or oneStepPredict(). Missing OSA values stay missing within a model. .observation_residual_data <- function(data, type, selection = NULL) { @@ -70,7 +146,7 @@ "Standardized residuals" } else if (type == "osa") "OSA residuals" else if (type == "standardized") { "Standardized residuals" - } else "Residuals (Auto)" + } else "Residuals" } .residual_plot_annotations <- function(status, type) { @@ -84,7 +160,6 @@ labels[!available] <- if (type == "osa") "OSA unavailable" else "Unavailable" if (nrow(status) > 1L) labels <- paste0(status$model, ": ", labels) text <- paste(labels, collapse = "; ") - if (type == "auto") text <- paste0("Auto: ", text) list(list(text = as.character(htmltools::htmlEscape(text)), x = 0, y = 1, xref = "paper", yref = "paper", xanchor = "left", yanchor = "bottom", yshift = 8, showarrow = FALSE, font = list(size = 10))) @@ -128,10 +203,35 @@ x = ~year, xlab = "Year", y = ~age, ylab = "Age", title = NULL) { if (!is.data.frame(data)) cli::cli_abort("Residual plots require a data frame.") + # Keep explicit Plotly row attributes aligned when frames or OSA gaps subset + # the data. Formulas and scalar style arguments already have the right scope. + for (field in c("text", "hovertext", "customdata", "ids", "key", "hovertemplate", + "color", "symbol", "size", "opacity")) { + value <- args[[field]] + rowwise <- !inherits(value, "formula") && + ((is.matrix(value) && nrow(value) == nrow(data)) || + ((is.atomic(value) || is.list(value)) && is.null(dim(value)) && + length(value) > 1L && length(value) == nrow(data))) + if (rowwise) { + column <- paste0(".tam_residual_", field) + data[[column]] <- value + args[[field]] <- stats::reformulate(column) + } + } frame <- .residual_frame_values(data, args$frame) animated <- !is.null(args$frame) && length(frame$levels) > 1L + model_frame <- identical(args$frame, "model") || + (inherits(args$frame, "formula") && identical(all.vars(args$frame), "model")) args$frame <- NULL - types <- c("auto", "standardized", "osa") + types <- c("standardized", "osa") + available <- .observation_residual_data(data, "auto")$status + # Resolve once for the complete panel, never from a partially observed frame. + default_type <- if (all(available$residual_type == "osa")) "osa" else "standardized" + defaults <- if (model_frame) { + available$residual_type[match(frame$levels, available$model)] + } else rep(default_type, length(frame$levels)) + defaults[is.na(defaults)] <- "standardized" + default_views <- match(defaults, types) - 1L models <- if (is.factor(data$model)) levels(data$model) else unique(as.character(data$model)) model_colors <- NULL if (kind == "scatter" && inherits(args$color, "formula") && identical(all.vars(args$color), "model")) { @@ -156,6 +256,7 @@ if (!is.null(yrange)) cell$layout$yaxis <- utils::modifyList(cell$layout$yaxis, list(range = yrange, autorange = FALSE)) for (j in seq_along(cell$data)) { trace <- cell$data[[j]] + if (kind == "bubbles") trace$marker$line <- list(width = 0) if (kind == "bubbles" && length(trace$name) == 1L && trace$name %in% c("+", "-") && is.character(sign_colors)) { trace$marker$color <- sign_colors[match(trace$name, c("+", "-"))] @@ -189,17 +290,22 @@ }) views[[i]]$cells[[j]] <- cell } + initial_views <- if (type == "auto") default_views else + rep(match(type, types) - 1L, length(frame$levels)) config <- list(views = views, frames = frame$levels, animated = animated, - prefix = frame$prefix, view = match(type, types) - 1L, frame = 0L) - initial <- views[[match(type, types)]]$cells[[1L]] + prefix = frame$prefix, view = initial_views[1L], frame = 0L, + automatic = type == "auto", defaultViews = default_views, + showSelector = any(available$residual_type == "osa")) + initial <- views[[initial_views[1L] + 1L]]$cells[[1L]] p <- plotly::plotly_build(plotly::plot_ly(type = "scatter", mode = "markers", x = numeric(), y = numeric())) p$x$data <- initial$data p$x$layout <- utils::modifyList(p$x$layout, initial$layout) if (animated) { - cells <- views[[match(type, types)]]$cells - p$x$frames <- lapply(seq_along(frame$levels), function(i) list( - name = frame$levels[i], data = cells[[i]]$data, layout = cells[[i]]$layout, - traces = seq_along(cells[[i]]$data) - 1L)) + p$x$frames <- lapply(seq_along(frame$levels), function(i) { + cell <- views[[initial_views[i] + 1L]]$cells[[i]] + list(name = frame$levels[i], data = cell$data, layout = cell$layout, + traces = seq_along(cell$data) - 1L) + }) } script <- paste(readLines(system.file("js", "residual-selection.js", package = "tinyAM"), warn = FALSE), collapse = "\n") htmlwidgets::onRender(p, script, data = config) diff --git a/R/plot.R b/R/plot-trends.R similarity index 51% rename from R/plot.R rename to R/plot-trends.R index fd08da2d..4abcfb2e 100644 --- a/R/plot.R +++ b/R/plot-trends.R @@ -1,39 +1,3 @@ -.log_linear_buttons <- list( - list( - type = "buttons", - y = 1, x = 0, pad = list(r = 60), xanchor = "right", yanchor = "top", - buttons = list( - list(method = "relayout", args = list("yaxis.type", "linear"), label = "Linear"), - list(method = "relayout", args = list("yaxis.type", "log"), label = "Log") - ) - ) -) - -.forecast_hover <- function(data) { - if (!all(c("fold", "year") %in% names(data))) return(rep("", nrow(data))) - horizon <- if ("horizon" %in% names(data)) data$horizon else pmax(0, data$year - data$fold) - paste0("
Origin: ", data$fold, "
", - ifelse(horizon > 0, paste0("Forecast; horizon: ", horizon), "Historical")) -} - -.projection_boundary <- function(data) { - if (!"is_proj" %in% names(data) || !any(data$is_proj, na.rm = TRUE)) return(NA_real_) - if ("fold" %in% names(data)) { - origins <- unique(data$fold[!is.na(data$fold)]) - if (length(origins) != 1L) return(NA_real_) - return(as.numeric(origins)) - } - suppressWarnings(max(data$year[!data$is_proj], na.rm = TRUE)) -} - -.forecast_plot_args <- function(data, args) { - if ("fold" %in% names(data) && is.null(args$text) && is.null(args$hovertemplate)) { - args$text <- ~paste0("Origin: ", fold, "
", - ifelse(year > fold, paste0("Forecast; horizon: ", year - fold), "Historical")) - } - args -} - #' Plot utilities for `tidy_tam()` outputs #' #' These functions provide minimal, Plotly-based visualizations for outputs @@ -80,9 +44,10 @@ #' `~est` for process deviations. Omitted values use OSA or standardized #' observation residuals. Use `y = ~age_block` for shared M state blocks. #' @param residual_type Initial observation residual view: `"auto"` (default), -#' `"standardized"` or `"osa"`. Auto uses available cached OSA residuals -#' separately for each model in the supplied panel, otherwise standardized -#' residuals. Partial OSA gaps remain missing. A dropdown switches views; +#' `"standardized"` or `"osa"`. The default uses retained OSA residuals +#' when available, otherwise standardized residuals. Model frames choose +#' separately; overlays use OSA only when all models have them. A dropdown +#' offers OSA and Standardized when OSAs are available. Partial gaps stay missing; #' unavailable OSA values are identified without computing them. A supplied #' `res` formula in `plot_bubbles()` bypasses these observation controls. #' @param ylab Label for the y-axis. @@ -256,89 +221,7 @@ plot_trend <- function( p } -#' @rdname plot_tam -#' @export -add_plot_buttons <- function(p) { - pb <- plotly::plotly_build(p) - data_traces <- pb$x$data - if (is.null(data_traces)) { - data_traces <- list() - } - - # find ribbon traces (CI) - rib_idx <- which(vapply( - data_traces, - function(tr) identical(tr$type, "scatter") && - ((!is.null(tr$fill) && nzchar(tr$fill)) || (is.list(tr$meta) && isTRUE(tr$meta$tam_ci))), - logical(1) - )) - - menus <- .log_linear_buttons - - if (length(rib_idx)) { - idx0 <- as.integer(rib_idx - 1L) - ci_menu <- list( - type = "buttons", - y = 1, x = 0, pad = list(r = 60, t = 75), xanchor = "right", yanchor = "top", - buttons = list( - list( - label = "Show CI", - method = "restyle", - args = list(list(visible = rep(TRUE, length(idx0))), idx0) - ), - list( - label = "Hide CI", - method = "restyle", - args = list(list(visible = rep(FALSE, length(idx0))), idx0) - ) - ) - ) - menus <- c(menus, list(ci_menu)) - } - - if (is.null(p$x$layout)) { - p$x$layout <- list() - } - p$x$layout$updatemenus <- menus - if (!is.null(pb$x$frames)) { - p$x$frames <- pb$x$frames - } - p -} - - -#' @rdname plot_tam -#' @export -plot_heatmap <- function( - data, - zlab = "Estimate", - title = "", - ... -) { - unit_label <- .unit_label(data, "Estimate") - if (missing(zlab)) zlab <- unit_label - args <- list(...) - if ("frame" %in% names(args) && !is.null(args$frame)) { - cli::cli_abort( - "Argument {.arg frame} is not supported for heatmaps. - Supply a single frame at a time, or split/filter your data by the grouping - variable and call {.fn plot_heatmap} per group." - ) - } - - plot_ly(data, - x = ~year, y = ~age, z = ~est, - colorbar = list(title = zlab), ... - ) |> - add_heatmap() |> - layout( - title = title, - xaxis = list(title = "Year"), - yaxis = list(title = "Age") - ) -} - - +#' @name plot_tam #' @rdname plot_tam #' @export plot_obs_pred <- function( @@ -415,164 +298,6 @@ plot_obs_pred <- function( } -#' @rdname plot_tam -#' @export -plot_bubbles <- function(data, res = NULL, y = ~age, ylab = "Age", title = NULL, - residual_type = c("auto", "standardized", "osa"), ...) { - if (is.null(res)) { - return(.plot_observation_residuals(data, match.arg(residual_type), "bubbles", - list(...), y = y, ylab = ylab, title = title)) - } - if (!is.null(res)) { - if (!inherits(res, "formula") || length(res) != 2L) cli::cli_abort("res must be a one-sided formula selecting a numeric column.") - values <- stats::model.frame(res, data, na.action = stats::na.pass) - if (ncol(values) != 1L) cli::cli_abort("res must select one signed numeric column.") - data$res <- values[[1L]] - if (!is.numeric(data$res)) cli::cli_abort("res must select a signed numeric column.") - if (is.null(title)) title <- "Process deviations" - } - data$sign <- ifelse(data$res > 0, "+", "-") - # Break size ties deterministically without advancing the caller's RNG. - data$abs_res <- abs(data$res) + seq_len(nrow(data)) * .Machine$double.eps - data <- data[!is.na(data$res), ] - # Unused factor levels create empty Plotly animation frames and can leave - # the initial bubble chart blank when some models lack this process. - data <- droplevels(data) - data$.bubble_text <- if ("kind" %in% names(data)) paste0(data$kind, ": ", round(data$res, 2)) else as.character(round(data$res, 2)) - - args <- list(...) - if (is.null(args$colors)) { - args$colors <- c(utils::head(tam_cols(), 1), tail(tam_cols(), 1)) - } - if (is.null(args$text)) args$text <- ~.bubble_text - - p <- do.call( - plotly::plot_ly, - c( - list( - data = data, - x = ~year, - y = y, - marker = list( - size = ~abs_res, - sizemin = 1, - sizeref = 0.01, - sizemode = "area" - ), - color = ~sign - ), - args - ) - ) - - p |> - plotly::add_markers() |> - plotly::layout( - title = title, - xaxis = list(title = "Year"), - yaxis = list(title = ylab) - ) -} - - -#' @rdname plot_tam -#' @export -plot_resid <- function( - data, - x = ~year, - xlab = "Year", - residual_type = c("auto", "standardized", "osa"), - ... -) { - .plot_observation_residuals(data, match.arg(residual_type), "scatter", - list(...), x = x, xlab = xlab) -} - -#' @rdname plot_tam -#' @export -plot_par <- function(data, ...) { - data$coef <- factor(ifelse(is.na(data$coef), data$par, paste0(data$par, ": ", data$coef))) - - args <- list(...) - if (is.null(args$color)) { - args$color <- I("#377EB8") - } - p <- do.call(plot_ly, c(list(data = data, x = ~est, y = ~coef), args)) - - if (any(is.finite(data$lwr) & is.finite(data$upr))) { - p <- p |> - add_segments( - x = ~lwr, xend = ~upr, - y = ~coef, yend = ~coef, - showlegend = FALSE - ) - } - p |> - add_markers(showlegend = TRUE) |> - layout( - xaxis = list( - title = "Estimate" - ), - yaxis = list( - title = "" - ) - ) -} - -# Signed formula effects use a linear axis and a zero reference. Keep the -# existing trend/ribbon implementation for temporal effects. -.plot_formula_effect <- function(data, points = FALSE, frame = NULL, ...) { - if (!nrow(data)) { - return(plotly::plot_ly()) - } - limits <- range(c(0, data$est, data$lwr, data$upr), finite = TRUE) - pad <- max(diff(limits) * .05, .01) - if (points) { - p <- plotly::plot_ly(data, - x = ~coordinate, y = ~est, frame = frame, - error_y = list( - type = "data", array = ~ upr - est, - arrayminus = ~ est - lwr, symmetric = FALSE - ), ... - ) |> - plotly::add_markers() - } else { - p <- plot_trend(data, - x = ~coordinate, xlab = unique(data$variable)[1L], - frame = frame, add_buttons = FALSE, ... - ) - } - shapes <- list(list( - type = "line", x0 = 0, x1 = 1, xref = "paper", y0 = 0, y1 = 0, - line = list(color = "grey", width = 1) - )) - if (any(data$is_proj)) { - boundary <- max(data$coordinate[!data$is_proj]) - shapes <- c(shapes, list(list( - type = "line", x0 = boundary, x1 = boundary, - y0 = 0, y1 = 1, yref = "paper", line = list(color = "black", dash = "dot", width = 1) - ))) - } - plotly::layout(p, - xaxis = list( - title = unique(data$variable)[1L], - tickvals = unique(data$coordinate), ticktext = unique(data$level) - ), - yaxis = list( - title = if ("component" %in% names(data) && unique(data$component) != "q") { - if (startsWith(unique(data$component), "sd_")) { - "Effect on log SD" - } else { - paste("Effect on log", unique(data$component)) - } - } else { - "Effect on catchability's link scale" - }, type = "linear", - range = limits + c(-pad, pad) - ), shapes = shapes - ) -} - #' Switch between annual trends and age profiles #' #' @description @@ -702,163 +427,3 @@ plot_age_year <- function(data, plot = plot_trend, x = ~year, xlab = "Year", p } -#' Explore age-year patterns -#' -#' Display a complete or sparse age-year table as a heatmap, surface or contour. -#' Buttons change the metric, display type and value scale; an optional model -#' selector compares models using the same ranges within each metric. -#' -#' @param data A data frame with numeric `year`, `age` and `est` columns. -#' Optional `unit`, `definition`, `notes` and `is_proj` columns enrich hover text. -#' @param metric Optional one-sided formula selecting a metric column. -#' @param frame Optional one-sided formula selecting a model column. Factor -#' levels determine the initial model and selector order. -#' @param type Initial display: `"heatmap"`, `"surface"` or `"contour"`. -#' @param signed Use symmetric orange-white-navy ranges centred on zero and -#' disable the log control? Default `FALSE` preserves ordinary matrix plots. -#' @param y One-sided formula selecting the vertical coordinate, default `~age`. -#' Character/factor coordinates use ordered positions with each model's own -#' labels, suitable for unique M state blocks. -#' @param ylab Vertical-axis label, default `"Age"`. A named character vector -#' can supply a different label for each metric. -#' @param y_labels Optional one-sided formula selecting display labels for the -#' vertical coordinates, useful for model-specific state blocks. -#' @details Linear shows original estimates, including zero. Log displays -#' log10 estimates; nonpositive values are gaps. Hover text always shows -#' original values and units. Ranges are shared across models separately for -#' each metric. All models of a metric must use the same units. -#' Colours use the built-in [tam_cols()] ramp from low to high values. -#' Colour-ramp titles place units on a second line; axis labels remain on one line. -#' Missing cells remain missing. Surface and contour rendering interpolates -#' only for display and does not create additional source estimates. -#' @return A Plotly object with independent controls for each widget. -#' @examples -#' d <- expand.grid(year = 2000:2005, age = 1:5) -#' d$est <- exp(.1 * (d$year - 2000) - .3 * d$age) -#' plot_matrix(d) -#' @seealso [plot_heatmap()], [vis_tam()] -#' @export -plot_matrix <- function(data, metric = NULL, frame = NULL, - type = c("heatmap", "surface", "contour"), - signed = FALSE, y = ~age, ylab = "Age", y_labels = NULL) { - type <- match.arg(type) - if (!is.logical(signed) || length(signed) != 1L || is.na(signed)) cli::cli_abort("signed must be TRUE or FALSE.") - if (!inherits(y, "formula") || length(all.vars(y)) != 1L || !all.vars(y) %in% names(data)) { - cli::cli_abort("y must select one existing vertical-axis column.") - } - vertical <- data[[all.vars(y)]] - categorical <- !is.numeric(vertical) - if (anyNA(vertical)) cli::cli_abort("Vertical coordinates cannot be missing.") - data$.vertical_label <- as.character(vertical) - if (!is.null(y_labels)) { - if (!inherits(y_labels, "formula") || length(all.vars(y_labels)) != 1L || - !all.vars(y_labels) %in% names(data)) cli::cli_abort("y_labels must select one existing label column.") - data$.vertical_label <- as.character(data[[all.vars(y_labels)]]) - } - data$age <- if (categorical) match(vertical, unique(vertical)) else vertical - if (!is.data.frame(data) || !all(c("year", "age", "est") %in% names(data)) || - !nrow(data)) cli::cli_abort("{.arg data} must contain year, age and est rows.") - if (!all(vapply(data[c("year", "age", "est")], is.numeric, logical(1))) || - any(!is.finite(data$year)) || any(!is.finite(data$age))) { - cli::cli_abort("year, age and est must be numeric; year and age must be finite.") - } - column <- function(form, default) { - if (is.null(form)) return(rep(default, nrow(data))) - if (!inherits(form, "formula") || length(form) != 2L || - length(all.vars(form)) != 1L || !is.symbol(form[[2L]]) || - !all.vars(form) %in% names(data)) { - cli::cli_abort("metric and frame must each select one existing column.") - } - data[[all.vars(form)]] - } - metrics <- column(metric, "Estimate") - models <- column(frame, "Model") - if (anyNA(metrics) || anyNA(models)) cli::cli_abort("Metric and model labels cannot be missing.") - labels <- function(x) if (is.factor(x)) levels(droplevels(x)) else unique(as.character(x)) - metric_names <- labels(metrics) - model_names <- labels(models) - keys <- data.frame(year = data$year, age = data$age, metric = metrics, model = models) - if (anyDuplicated(keys)) cli::cli_abort("Duplicate year-age cells within a metric and model.") - rows <- function(x) unname(lapply(seq_len(nrow(x)), function(i) unname(x[i, ]))) - span <- function(x) { - x <- x[is.finite(x)] - if (!length(x)) return(c(0, 1)) - r <- range(x) - if (diff(r) == 0) r <- r + c(-1, 1) * max(abs(r[1]) * .01, .01) - unname(r) - } - spec <- lapply(metric_names, function(name) { - d <- data[as.character(metrics) == name, , drop = FALSE] - axis_label <- if (length(ylab) == 1L) unname(ylab) else unname(ylab[name]) - if (length(axis_label) != 1L || is.na(axis_label)) cli::cli_abort("ylab must supply a label for each metric.") - units <- if ("unit" %in% names(d)) unique(as.character(d$unit[is.finite(d$est) & - !is.na(d$unit) & nzchar(d$unit)])) else character() - if (length(units) > 1L) cli::cli_abort("Metric {.val {name}} has different units; convert them before plotting.") - unit <- if (length(units)) units[1L] else "" - years <- sort(unique(d$year)) - ages <- sort(unique(d$age)) - grid <- expand.grid(age = ages, year = years) - cells <- lapply(model_names, function(model) { - z <- d[as.character(models[as.character(metrics) == name]) == model, , drop = FALSE] - cell_ages <- ages - ticktext <- as.character(ages) - if (categorical) { - ticks <- unique(z$.vertical_label) - # Retain each model's own ordered state blocks rather than a union of ages. - z$age <- match(z$.vertical_label, ticks) - cell_ages <- seq_along(ticks) - ticktext <- ticks - if (!length(cell_ages)) { cell_ages <- 1; ticktext <- "Unavailable" } - } else if (!is.null(y_labels)) { - cell_ages <- sort(unique(z$age)) - ticktext <- z$.vertical_label[match(cell_ages, z$age)] - if (!length(cell_ages)) { cell_ages <- 1; ticktext <- "" } - } - grid <- expand.grid(age = cell_ages, year = years) - index <- match(paste(grid$year, grid$age), paste(z$year, z$age)) - values <- z$est[index] - values[!is.finite(values)] <- NA_real_ - text <- paste0("Model: ", model, "
", name, ": ", format(values, trim = TRUE), - if (nzchar(unit)) paste0(" ", unit) else "", "
Year: ", grid$year, - if ("is_proj" %in% names(z)) ifelse(!is.na(z$is_proj[index]) & z$is_proj[index], " (projection)", "") else "", - "
", axis_label, ": ", - if (categorical || !is.null(y_labels)) ticktext[match(grid$age, cell_ages)] else grid$age, - .forecast_hover(z)[index]) - for (field in intersect(c("definition", "notes"), names(z))) { - value <- as.character(z[[field]][index]) - text <- paste0(text, ifelse(is.na(value) | !nzchar(value), "", paste0("
", value))) - } - natural <- matrix(values, nrow = length(cell_ages)) - logged <- natural - logged[logged <= 0] <- NA_real_ - logged <- log10(logged) - list(linear = rows(natural), log = rows(logged), - ages = cell_ages, ticktext = ticktext, - text = rows(matrix(text, nrow = length(cell_ages)))) - }) - list(name = name, unit = unit, years = years, ages = ages, cells = cells, ylab = axis_label, - linear = if (signed) c(-1, 1) * max(c(abs(d$est[is.finite(d$est)]), .01)) else span(d$est), - log = span(log10(d$est[is.finite(d$est) & d$est > 0]))) - }) - colours <- tam_cols() - colorscale <- unname(Map(list, seq(0, 1, length.out = length(colours)), colours)) - if (signed) colorscale <- list(list(0, tail(tam_cols(), 1L)), list(.5, "#FFFFFF"), list(1, tam_cols()[1L])) - config <- list(metrics = spec, models = model_names, type = type, colorscale = colorscale, - signed = signed, ylab = ylab, categorical = categorical || !is.null(y_labels)) - script <- paste(readLines(system.file("js", "matrix.js", package = "tinyAM"), - warn = FALSE), collapse = "\n") - initial_metric <- if (signed) which(vapply(spec, function(metric) any(vapply(metric$cells, - function(cell) any(is.finite(unlist(cell$linear))), logical(1))), logical(1)))[1L] else 1L - if (is.na(initial_metric)) initial_metric <- 1L - config$initial_metric <- initial_metric - 1L - first <- spec[[initial_metric]] - initial <- if (signed) which(vapply(first$cells, function(cell) any(is.finite(unlist(cell$linear))), logical(1)))[1L] else 1L - if (is.na(initial)) initial <- 1L - cell <- first$cells[[initial]] - p <- plotly::plotly_build(plotly::plot_ly(x = first$years, y = cell$ages, - z = matrix(0, nrow = length(cell$ages), ncol = length(first$years)), - type = type)) - p$x$data[[1L]]$z <- cell$linear - p$x$data[[1L]]$colorscale <- colorscale - htmlwidgets::onRender(p, script, data = config) -} diff --git a/R/plot-utils.R b/R/plot-utils.R new file mode 100644 index 00000000..0b856817 --- /dev/null +++ b/R/plot-utils.R @@ -0,0 +1,88 @@ +.log_linear_buttons <- list( + list( + type = "buttons", + y = 1, x = 0, pad = list(r = 60), xanchor = "right", yanchor = "top", + buttons = list( + list(method = "relayout", args = list("yaxis.type", "linear"), label = "Linear"), + list(method = "relayout", args = list("yaxis.type", "log"), label = "Log") + ) + ) +) + +.forecast_hover <- function(data) { + if (!all(c("fold", "year") %in% names(data))) return(rep("", nrow(data))) + horizon <- if ("horizon" %in% names(data)) data$horizon else pmax(0, data$year - data$fold) + paste0("
Origin: ", data$fold, "
", + ifelse(horizon > 0, paste0("Forecast; horizon: ", horizon), "Historical")) +} + +.projection_boundary <- function(data) { + if (!"is_proj" %in% names(data) || !any(data$is_proj, na.rm = TRUE)) return(NA_real_) + if ("fold" %in% names(data)) { + origins <- unique(data$fold[!is.na(data$fold)]) + if (length(origins) != 1L) return(NA_real_) + return(as.numeric(origins)) + } + suppressWarnings(max(data$year[!data$is_proj], na.rm = TRUE)) +} + +.forecast_plot_args <- function(data, args) { + if ("fold" %in% names(data) && is.null(args$text) && is.null(args$hovertemplate)) { + args$text <- ~paste0("Origin: ", fold, "
", + ifelse(year > fold, paste0("Forecast; horizon: ", year - fold), "Historical")) + } + args +} + +#' @name plot_tam +#' @rdname plot_tam +#' @export +add_plot_buttons <- function(p) { + pb <- plotly::plotly_build(p) + data_traces <- pb$x$data + if (is.null(data_traces)) { + data_traces <- list() + } + + # find ribbon traces (CI) + rib_idx <- which(vapply( + data_traces, + function(tr) identical(tr$type, "scatter") && + ((!is.null(tr$fill) && nzchar(tr$fill)) || (is.list(tr$meta) && isTRUE(tr$meta$tam_ci))), + logical(1) + )) + + menus <- .log_linear_buttons + + if (length(rib_idx)) { + idx0 <- as.integer(rib_idx - 1L) + ci_menu <- list( + type = "buttons", + y = 1, x = 0, pad = list(r = 60, t = 75), xanchor = "right", yanchor = "top", + buttons = list( + list( + label = "Show CI", + method = "restyle", + args = list(list(visible = rep(TRUE, length(idx0))), idx0) + ), + list( + label = "Hide CI", + method = "restyle", + args = list(list(visible = rep(FALSE, length(idx0))), idx0) + ) + ) + ) + menus <- c(menus, list(ci_menu)) + } + + if (is.null(p$x$layout)) { + p$x$layout <- list() + } + p$x$layout$updatemenus <- menus + if (!is.null(pb$x$frames)) { + p$x$frames <- pb$x$frames + } + p +} + + diff --git a/R/population-tables.R b/R/population-tables.R deleted file mode 100644 index 7c3ea870..00000000 --- a/R/population-tables.R +++ /dev/null @@ -1,59 +0,0 @@ -# Population-only collection shared by tidy_tam() and the quantity getters. -# Keep comparison conversions here so lightweight consumers use the same units -# and reported-versus-log SE conventions as dashboards. -.population_tables <- function(model_list, interval) { - pop_list <- lapply(model_list, function(fit) { - if (inherits(fit, "tam_ref")) return(fit$pop) - stored <- attr(fit$pop, "interval", exact = TRUE) - if (!is.null(fit$pop) && !is.null(stored) && - isTRUE(all.equal(stored, interval))) { - fit$pop - } else { - tidy_pop(fit, interval = interval) - } - }) - references <- Filter(function(fit) inherits(fit, "tam_ref"), model_list) - comparison_scales <- lapply(references, `[[`, "comparison_scales") - comparison_scales <- Filter(function(x) length(x) > 0L, comparison_scales) - if (length(comparison_scales)) { - comparison_scales <- lapply(comparison_scales, function(x) { - if (is.list(x)) x <- unlist(x, use.names = TRUE) - if (!is.numeric(x) || is.null(names(x)) || any(!nzchar(names(x))) || - anyDuplicated(names(x)) || any(!is.finite(x)) || any(x <= 0)) { - cli::cli_abort("A {.cls tam_ref} {.field comparison_scales} value must be a named vector of positive finite numbers.") - } - x - }) - if (length(comparison_scales) > 1L && - !all(vapply(comparison_scales[-1L], identical, logical(1), comparison_scales[[1L]]))) { - cli::cli_abort("Assessment references use different {.field comparison_scales}; the fitted outputs cannot be shown on one scale.") - } - comparison_scales <- comparison_scales[[1L]] - reference_pop <- references[[1L]]$pop - for (i in seq_along(model_list)) { - if (inherits(model_list[[i]], "tam_ref")) next - for (metric in intersect(names(comparison_scales), names(pop_list[[i]]))) { - tab <- pop_list[[i]][[metric]] - scale <- comparison_scales[[metric]] - reference <- reference_pop[[metric]] - from <- unique(tab$unit[!is.na(tab$unit)]) - to <- unique(reference$unit[!is.na(reference$unit)]) - if (length(from) == 1L && length(to) == 1L) .check_unit_conversion(from, to, scale) - for (field in intersect(c("est", "lwr", "upr"), names(tab))) { - tab[[field]] <- tab[[field]] * scale - } - if ("se" %in% names(tab)) { - natural <- if ("se_scale" %in% names(tab)) tab$se_scale == "reported" else rep(TRUE, nrow(tab)) - tab$se[which(natural)] <- tab$se[which(natural)] * scale - } - if (is.data.frame(reference) && "unit" %in% names(reference)) { - units <- unique(as.character(reference$unit[!is.na(reference$unit) & - nzchar(as.character(reference$unit))])) - if (length(units) == 1L) tab$unit <- units[[1L]] - } - pop_list[[i]][[metric]] <- tab - } - } - } - pop_list -} diff --git a/R/prep.R b/R/prep.R index ad524596..3567d2e3 100644 --- a/R/prep.R +++ b/R/prep.R @@ -265,121 +265,40 @@ cut_years <- function(years, breaks) cut_int(years, breaks, ordered = FALSE) #' #' Supply only the entries to change from the defaults shown in Usage. Formulas #' and vectors replace an entire entry. Optional `NULL` entries clear a formula, -#' offset or age selection; recruitment defaults to an anchored RW and a latent -#' `sd_form = NULL` restores `~ 1`. Required entries cannot be `NULL`. +#' offset or age selection; `sd_form = NULL` restores `~ 1`. +#' Required entries cannot be `NULL`. #' [update()] retains unspecified entries from the original fit instead. #' -#' **Spawning time** -#' -#' An optional `data$maturity$spawn_time` column supplies spawning timing as a -#' fraction of the year for each year and age. If absent, timing is zero -#' (start-of-year SSB). If present, every value must be finite and between zero -#' and one, including immature and retained older biological ages. Projections -#' carry forward the terminal historical value at each biological age. -#' SSB includes survival through this fraction of annual F and M. The same -#' definition supplies recruitment parents and uncertainty. Age-specific timing -#' sums each age's contribution at its own spawning time; it is not a snapshot -#' on one common date. Hidden plus-age contributions are calculated separately -#' before summing. Weight and maturity remain supplied quantities; seasonal -#' growth and maturation are not modeled. -#' -#' **Observation handling** -#' -#' - Inputs are expected as a list with components `catch`, `index`, `weight`, -#' and `maturity`. Each must include columns `year`, `age`, and a value column -#' named `obs`. Rename any differently named input columns before calling. See -#' [cod_obs] for an example of the required structure. The optional -#' `pop_covariates` table supplies population formula inputs; see [as_tam_data()]. -#' - Catch and maturity must already contain exactly one row per -#' year-age combination across the input range. Survey tables may be sparse. -#' Weight needs the same complete grid for every supplied `type`; see -#' [as_tam_data()] for stock and catch weights and fallback rules. -#' - A combined observation table is created for catch and index; `log(0)` is -#' excluded from the observation likelihood. -#' - When biological inputs extend above the modeled plus age, the underlying -#' stock/catch weight and maturity values are retained in `W_plus_input`, -#' `W_catch_plus_input` and `P_plus_input`, -#' indexed by `years` and `plus_ages`. Their projection rows use the same -#' recent-year averages by biological age as other weight/maturity inputs. -#' `dat$W`, `dat$W_catch`, `dat$P`, and `dat$obs` retain input values at modeled ages; -#' their terminal biological values are placeholders. [nll_fun()] replaces -#' terminal W by an abundance-weighted mean and terminal P by a biomass-weighted -#' proportion using its reconstructed hidden age composition. See [tinyAM-model]. -#' Formula covariates continue to use the input rows at modeled ages, not these -#' effective biological values; this avoids circular mortality calculations. -#' -#' **Design matrices** -#' -#' - `catch_settings$sd_form` is evaluated on the catch table to produce -#' `sd_catch_modmat` and associated **log-scale** parameters `log_sd_catch` -#' (intercept removed when `sd_supplied` is provided so supplied SDs act as -#' offsets). -#' - `index_settings$sd_form` is evaluated on the index table to produce -#' `sd_index_modmat` and **log-scale** parameters `log_sd_index`. -#' Both SD formulas support additive [iid()], [rw()], [ar1()] and random -#' intercepts; their compact unique states are stored in `sd_catch_terms` -#' and `sd_index_terms`. They modify log observation SD, with supplied SDs -#' acting as offsets. See [formula_effects] for interpretation and support checks. -#' - `index_settings$q_form` is evaluated on the index table to produce -#' `q_modmat` and parameters `log_q` (log link) or `logit_q` (logit link). -#' Additive [mono()] terms instead contribute cumulative indicators -#' in `q_mono_modmat`, with directly fitted non-negative increments `dq` -#' on the selected link scale. -#' `q_mono_steps` records each transition and its optional group. -#' Structured [iid()], [rw()], [ar1()], random-intercept and [logistic()] -#' terms are recorded separately in `q_terms`. Their unique states and process -#' parameters are added by [make_par()], rather than treated as ordinary columns. -#' - If `M_settings$mu_form` is provided, `M_modmat <- model.matrix(mu_form, -#' data = data$pop_covariates)` and the resulting coefficients are parameters `mu_m`. -#' These coefficients are applied on the log scale to build \eqn{M}, but -#' retain the `mu_` prefix to emphasize they can be positive or negative. -#' If `mu_supplied` is also provided, the intercept in `mu_form` is dropped -#' and a warning is issued. -#' - If neither `M_settings$mu_form` nor `M_settings$mu_supplied` is supplied, -#' the function stops, because \eqn{M} must be identified by either a supplied -#' surface or a mean structure. -#' -#' **Process options and guards** -#' -#' - Initial abundance is controlled by `N_settings$init`, independently of -#' the subsequent N process. First-year recruitment is the state -#' `log_r0`, controlled separately by `rec_settings$init`. The default uses survivorship from recruitment under first-year -#' total mortality Z, with no equilibrium plus-group correction. -#' - `"exp"` is the default: a parsimonious, comparatively stable nuisance-state -#' initialization. More flexible choices are available when first-year data -#' support them. `"free"` estimates unpenalized fixed `log_n0` states. -#' `"latent"` integrates those states without an initial density, including -#' when the subsequent N process is off. It resembles SAM's unpenalized -#' older-age boundary; use `rec_settings$init = "latent"` to integrate first-year recruitment too. -#' - `"mono"` estimates non-increasing initial abundance from r0, including -#' the plus group: `log N0[a] = log r0 - cumsum(d_n0)[a-1]`. `"capped"` -#' only requires each older abundance to be no greater than r0: -#' `log N0[a] = log r0 - d_n0[a-1]`. Both use nonnegative log-decrements, -#' allow exact ties, and require no N process or separate initial SD. -#' The pooled plus group can naturally exceed a single age; constraining it -#' is a deliberate biological assumption. Boundary Wald intervals need care. -#' - Recruitment initialization is independent of these choices. Simulations condition on initial states; -#' joint uncertainty draws can vary fitted latent initial states. No -#' mortality-history distribution is imposed on initial abundances. -#' - `M_settings$age_breaks` (vector of break points on ages) -#' defines `M_settings$age_blocks` via [cut_ages()], used -#' to share absolute latent \eqn{M} states across ages. All mean components -#' must be constant across ages within each fitted block. -#' - The AR(1) correlation parameters are only initialized for -#' processes whose `process == "ar1"`. Correlations are assumed to be 0 -#' when `process == "iid"`. A temporal random walk (`"rw"`) has independent -#' year-to-year increments within each age or age block, with no age -#' correlation or AR parameter. Its first process row is unpenalized. -#' For N the walk acts on cohort residuals; for F/M it acts on deviations -#' from their existing log mean surfaces. Initial abundance, the M process -#' start year, and terminal-F projections retain their usual meanings. -#' -#' **Projections (optional)** -#' -#' - If `proj_settings` is supplied, the function adds: -#' - `proj_years`: the set of projection years; -#' - `is_proj`: logical vector identifying the projection years; -#' - `obs$...$is_proj` rows to each `obs` table identifying the projection years. +#' **Inputs and preparation** +#' +#' See [as_tam_data()] for table keys, units, fleet-specific catch weights and +#' covariate routing, and [cod_obs] for example data. Catch and survey zeros and +#' missing values are excluded from the lognormal observation likelihood; +#' complete predictions are still calculated. +#' +#' Biological ages above the modeled plus age are retained in `W_plus_input`, +#' `W_catch_plus_input` and `P_plus_input`. The population calculation derives +#' effective plus-group weights and maturity from their hidden abundances; +#' prepared terminal biological values are placeholders. Formula covariates +#' use the supplied modeled-age rows, avoiding circular mortality calculations. +#' The equations and spawning-time definition are in [tinyAM-model]. +#' +#' **Formula designs** +#' +#' Ordinary formula terms create design matrices. Structured [formula_effects], +#' [mono()] curves and [smooth_formulas] also store unique effect states and +#' their grouping metadata. [make_par()] constructs the associated parameters. +#' Supplied M and observation SDs act as offsets; their mean/SD formulas omit +#' an intercept to avoid estimating another baseline. The settings below define +#' available terms, restrictions and data sources. +#' +#' **Projections** +#' +#' `proj_settings` appends future years and marks them with `is_proj` in the +#' prepared grid and tables. Stock/catch weights and maturity use recent-year +#' averages by biological age; covariates and spawning timing retain terminal +#' historical values. See [tinyAM-model] for forecasting and initial-state +#' equations, and [fit_hindcast()] for held-out-data evaluation. #' #' @param data A list of tidy observation data.frames: `catch`, `index`, #' `weight`, and `maturity`. See **Details**. @@ -410,8 +329,9 @@ cut_years <- function(years, breaks) cut_int(years, breaks, ordered = FALSE) #' directions cancel and are rejected. See [tinyAM-model]. #' - `sd_form`: ordinary formula for log SD of older-age survival residuals, #' default `~ 1`. Use `~ factor(age)` or a supplied age-sharing column in -#' `data$pop_covariates`. Its design must be constant across years. Recruitment and -#' initial-abundance SDs remain separate. Random-effect SD terms are not enabled. +#' `data$pop_covariates`. Its design must be constant across years. Recruitment +#' SD is controlled separately by `rec_settings`; initial abundance has no +#' separate SD. Random-effect SD terms are not enabled. #' @param rec_settings A list controlling recruitment separately from cohort survival: #' - `process`: `"off"` for recruitment exactly following its mean formula, #' or `"rw"` (default), `"iid"`, or `"ar1"` for annual log-recruitment diff --git a/R/recruitment.R b/R/recruitment.R index afb01228..1eef45b8 100644 --- a/R/recruitment.R +++ b/R/recruitment.R @@ -315,25 +315,6 @@ ricker <- function(ssb, lag = NULL) { nll } -.simulate_rec <- function(par, dat) { - mean <- .rec_mean(par, dat) - if (!is.null(dat$rec$curve)) cli::cli_abort("Recruitment curves must be simulated through the chronological population constructor.") - if (dat$rec$type == "off") return(mean[-1L]) - scale <- .rec_scale(par, dat) - u <- numeric(length(dat$years)) - u[1L] <- par$log_r0 - mean[1L] - for (i in dat$rec$eligible) { - expected <- switch(dat$rec$type, - rw = u[i - 1L], - iid = 0, - ar1 = if (i == dat$rec$eligible[1L]) 0 else scale$phi * u[i - 1L] - ) - sd <- if (dat$rec$type == "ar1" && i == dat$rec$eligible[1L]) scale$sd / sqrt(1 - scale$phi^2) else scale$sd - u[i] <- stats::rnorm(1L, expected, sd) - } - (mean + u)[-1L] -} - # One chronological population construction for estimation and simulation. .population_states <- function(par, dat, Z, simulate = FALSE, initialize = FALSE, F = NULL, M = NULL, F_by_fleet = NULL, log_F_by_fleet = NULL) { "[<-" <- RTMB::ADoverload("[<-") diff --git a/R/retro.R b/R/retro.R index bcaa78ac..a0f1e7ef 100644 --- a/R/retro.R +++ b/R/retro.R @@ -110,7 +110,7 @@ tick <- progressr::progressor(steps = nrow(jobs)) furrr::future_map(seq_len(nrow(jobs)), function(i) { fit <- models[[jobs$model_index[i]]] - tolerance <- if (!is.null(grad_tol)) grad_tol else if (!is.null(fit$grad_tol)) fit$grad_tol else .01 + tolerance <- if (!is.null(grad_tol)) grad_tol else fit$grad_tol result <- .retro_fold(fit, jobs$fold[i], jobs$final[i], settings, start_from_fit, tolerance) tick(); result }, .options = furrr::furrr_options(seed = 1, packages = "tinyAM", globals = globals)) @@ -253,6 +253,12 @@ #' Missing baselines or zero persistence error make MASE unavailable. Failed #' numerical fits remain in `fits`, but not in stacked results or scores. #' Supplied fits and fitted objectives are unchanged. +#' +#' @section Parallel execution: +#' Set the execution plan before calling either function, for example +#' `future::plan(future::multisession, workers = 4)`. Without a parallel plan, +#' folds run sequentially. Neither function changes your plan or worker count. +#' Use `future::plan(future::sequential)` afterwards to shut down the workers. #' @return A `tam_retro` list with `fits` nested by model and terminal year; #' stacked `pop` and `obs_pred` with model, fold and horizon (zero historically); #' `mohns_rho`; detailed `scores`; matched `forecast_pairs`; `fold_diagnostics`; @@ -260,6 +266,7 @@ #' All-failed runs still return diagnostics. #' @examples #' \dontrun{ +#' future::plan(future::multisession, workers = 4) #' retro <- fit_retro(fit, alternative = other_fit, folds = 5) #' hind <- fit_hindcast(fit, folds = 10, #' proj_settings = list(n_proj = 3, n_mean = 3, catch = "observed")) @@ -267,6 +274,7 @@ #' hind$scores #' vis_tam(hind) #' vis_tam(retro, model = names(retro$fits)[1]) +#' future::plan(future::sequential) #' } #' @seealso [fit_tam()], [compute_mohns_rho()], [compute_hindcast_mase()], [compute_hindcast_rmse()] #' @importFrom future plan multisession diff --git a/R/settings.R b/R/settings.R index a4e04281..284d8bc6 100644 --- a/R/settings.R +++ b/R/settings.R @@ -24,12 +24,6 @@ if (is.null(keys) || anyNA(keys) || any(!nzchar(keys)) || anyDuplicated(keys)) { cli::cli_abort("Entries in {.arg {name}} must have unique, nonempty names.") } - if (name == "N_settings" && "init_N0" %in% keys) { - cli::cli_abort("N_settings$init_N0 has been retired. Use N_settings$init instead.") - } - if (name == "N_settings" && "rec_form" %in% keys) { - cli::cli_abort("N_settings$rec_form has moved. Use rec_settings with separate process and mu_form entries.") - } unknown <- setdiff(keys, allowed) if (length(unknown)) cli::cli_abort("Unknown {.arg {name}} setting(s): {paste(unknown, collapse = ', ')}.") if (is.null(base)) base <- .settings_defaults(name) diff --git a/R/smooths.R b/R/smooths.R index 98b733a5..3f8c757a 100644 --- a/R/smooths.R +++ b/R/smooths.R @@ -212,10 +212,6 @@ NULL list(fixed = fixed, random = random) } -.smooth_basis_compatible <- function(old, new) { - !is.null(.smooth_basis_transform(old, new)) -} - .smooth_warm_starts <- function(start, old, new) { designs <- list(F = old$F_modmat, q = old$q_modmat) for (component in c("q", "F")) { diff --git a/R/tidy.R b/R/tidy.R index 3e17aa80..53c998e8 100644 --- a/R/tidy.R +++ b/R/tidy.R @@ -33,8 +33,7 @@ #' dimnames(m) <- NULL #' tidy_array(m, require_dimnames = FALSE) #' -#' @aliases tidy_mat -#' @export tidy_array tidy_mat +#' @export tidy_array <- function(x, value_name = "x", require_dimnames = TRUE) { if (!is.matrix(x) && !is.array(x)) { cli::cli_abort("{.arg x} must be a matrix or array.") @@ -60,10 +59,6 @@ tidy_array <- function(x, value_name = "x", require_dimnames = TRUE) { df } -#' @rdname tidy_array -#' @export -tidy_mat <- tidy_array - #' Tidy observed, predicted, and residual diagnostics #' @@ -203,7 +198,7 @@ tidy_obs_pred <- function(fit, add_osa_res = FALSE, interval = .95, #' names(trends) #' head(trends$N) #' -#' @seealso [tidy_obs_pred()], [tidy_sdrep()], [tidy_pop()], [tidy_mat()] +#' @seealso [tidy_obs_pred()], [tidy_sdrep()], [tidy_pop()], [tidy_array()] #' @export tidy_rep <- function(fit) { @@ -240,7 +235,7 @@ tidy_rep <- function(fit) { trends <- lapply(rep_items, function(x) { if (length(dim(x)) >= 2L) { - d <- tidy_mat(x, value_name = "est") + d <- tidy_array(x, value_name = "est") d$is_proj <- d$year %in% dat$years[dat$is_proj] return(d) } @@ -357,7 +352,7 @@ tidy_sdrep <- function(fit, interval = 0.95) { df <- lapply(seq_along(vals), function(i) { if (length(dim(vals[[i]])) >= 2L) { dimnames(vals[[i]]) <- dimnames(fit$rep[[sub("^log_", "", names(vals)[i])]]) - d <- tidy_mat(vals[[i]], value_name = "est") + d <- tidy_array(vals[[i]], value_name = "est") d$se <- as.vector(ses[[i]]) d$lwr <- d$est - qnorm(1 - ((1 - interval) / 2)) * d$se d$upr <- d$est + qnorm(1 - ((1 - interval) / 2)) * d$se @@ -520,7 +515,7 @@ tidy_pop <- function(fit, interval = 0.95) { #' - For matrices (e.g., `log_f`, `log_n`), `year` and/or `age` columns are added #' from their dimensions; shared F/M states use `age_block` rather than #' duplicating the parameter at each biological age. -#' via [tidy_mat()]. +#' via [tidy_array()]. #' #' @param fit A fitted TAM object (from [fit_tam()]) containing an `sdrep` #' (an [RTMB::sdreport()] object) and `obj$env$.random` (names of random effects). @@ -542,7 +537,7 @@ tidy_pop <- function(fit, interval = 0.95) { #' names(par_tab$random) # e.g., "log_f", "log_r", ... #' head(par_tab$random$log_f) #' -#' @seealso [tidy_mat()], [fit_tam()] +#' @seealso [tidy_array()], [fit_tam()] #' @export tidy_par <- function(fit, interval = 0.95) { fit <- .require_tam_fit(fit, arg = "fit") @@ -565,7 +560,7 @@ tidy_par <- function(fit, interval = 0.95) { df <- data.frame(coef = NA_character_, year = fit$dat$years[1L], age = fit$dat$ages[1L], est = e, se = s, is_proj = FALSE) } else if (is.matrix(e)) { - df <- tidy_mat(e, value_name = "est") + df <- tidy_array(e, value_name = "est") if (nm == "log_f" && fit$dat$has_fleet) { i <- match(df$age_block, fit$dat$F_states$key) df$fleet <- fit$dat$F_states$fleet[i] diff --git a/R/vis.R b/R/vis.R index e1c45e5b..12a47dff 100644 --- a/R/vis.R +++ b/R/vis.R @@ -27,6 +27,7 @@ #' Precomputed assessment references may be mixed with tinyAM fits; they are #' not refittable TAM objects. Supply `background` to add a page #' describing assessment assumptions and translation choices. +#' Model structure opens first, with Diagram and Function calls tabs. #' Fisheries is a dropdown with one page per declared catch fleet, #' followed by Aggregate fishery. Fleet pages show yield, catch and F #' at age, and observation residuals. Unlabeled catch models appear @@ -34,9 +35,10 @@ #' Without fleets, Aggregate fishery retains all single-fishery #' diagnostics. With fleets, it shows total yield; residuals are #' assessed separately within each fleet. -#' Observation residuals default to Auto: each model uses retained OSA +#' Observation residuals initially use retained OSA #' residuals when available in that panel, otherwise standardized -#' residuals. The dropdown also selects either type explicitly. Partial +#' residuals. The dropdown offers OSA and Standardized when OSAs are +#' available. Model frames choose their initial type separately. Partial #' OSA gaps remain missing, and labels identify the method. Retain OSA #' calculations with [add_osa_residuals()]; rendering never computes them. #' The Parameters menu separates Fixed and Random pages. Fixed plots diff --git a/README.md b/README.md index fb47fc10..352282d0 100644 --- a/README.md +++ b/README.md @@ -215,15 +215,15 @@ statistical advisories. Convergence alone does not establish that the data identify every component. Inspect each check before interpreting or ranking an alternative. -Use `plot_model(base, N_iid, M_ar1)` or the dashboard's **Model structure** page -to inspect process switches and formulas. The +Use `plot_model(base, N_iid, M_ar1)` or the dashboard's opening **Model structure** +page to inspect process switches and formulas. Its second tab shows function calls. The [structure guide](https://paulregular.github.io/tinyAM/articles/model-structure.html) links contrasting diagrams to the model equations. In the dashboard, start with **Fisheries** and **Surveys** to inspect fits and -residuals. **Auto** uses retained OSA residuals where available for each model; -otherwise it uses standardized residuals. Select either type explicitly with -the residual dropdown. Fisheries lists each fleet, then **Aggregate fishery**; +residuals. Plots start with retained OSA residuals when available, otherwise +standardized residuals; the dropdown selects either type explicitly. Fisheries +lists each fleet, then **Aggregate fishery**; without fleets, the aggregate page contains the single-fishery diagnostics. Review **Tables → Diagnostics** and **Parameters** for checks, uncertainty and process deviations before interpreting **Trends** for diff --git a/_pkgdown.yml b/_pkgdown.yml index 9b741c35..294bf03f 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -35,7 +35,6 @@ reference: - make_tam_data - as_tam_data - check_tam_data - - check_obs - cut_int - prepare_tam - make_par diff --git a/analysis/comp_assessments/CAPABILITY_GAPS.md b/analysis/comp_assessments/CAPABILITY_GAPS.md index dde6a146..4bfe434c 100644 --- a/analysis/comp_assessments/CAPABILITY_GAPS.md +++ b/analysis/comp_assessments/CAPABILITY_GAPS.md @@ -2,7 +2,25 @@ # Assessment capabilities and remaining gaps -## Current construction check: 2026-11-04 +## Workflow validation update: 2026-11-04 + +The manual local snapshot at SAIO `c8b4a967b6654a7d8a63536825702c72afdc7384` +was checked after the workflow cleanup. **135 of 137 comparative-assessment test +scripts passed.** Two failures remain without rescue tuning: +`test_age_subsets.R` has false convergence and a non-positive-definite covariance +for its direct reduced-age fit using the original full-age observations; +`test_ices_haddock_rockall_translation.R` rejects duplicate year–age stock weights. +The explicitly reduced-input fit and its dashboard pass the age-subset check. + +All **80 preliminary recipes** were also checked with fitting disabled: +**65 prepare**, **14 stop at their declared source blocks**, and **one fails on +the Rockall weight duplicates**. Seven `do.call()` wrappers were evaluated from +their existing settings/arguments directly rather than counted as helper errors. +F-covariate routing was corrected without changing formulas, factor definitions +or fitting controls. Preparation is not evidence of convergence, fit quality or +scientific equivalence. No aggregate assessment exports were regenerated. + +## Previous construction check: 2026-11-04 Using committed SAIO main `757b59c11453c2e5d9333c5fcf0f23323b9c828f`, **30 of 35 curated recipes** and **54 of 80 preliminary recipes** construct diff --git a/analysis/comp_assessments/DATABASE_STRUCTURE.md b/analysis/comp_assessments/DATABASE_STRUCTURE.md index ea279965..246a691d 100644 --- a/analysis/comp_assessments/DATABASE_STRUCTURE.md +++ b/analysis/comp_assessments/DATABASE_STRUCTURE.md @@ -1,3 +1,3 @@ -# SAIO database structure +# Database structure -The maintained document is DATABASE_STRUCTURE.md in the independent SAIO checkout. Read it before changing source records. Locate that checkout with SAIO_PATH or options(tinyAM.saio_path = '/path/to/saio'). See README.md here for the translation workflow. +The maintained document is [DATABASE_STRUCTURE.md](https://github.com/PaulRegular/saio/blob/main/DATABASE_STRUCTURE.md) in SAIO. Source changes and validation belong there. tinyAM reads a manually refreshed local snapshot; see [README.md](README.md). diff --git a/analysis/comp_assessments/PROTOCOL.md b/analysis/comp_assessments/PROTOCOL.md index 98494533..0779693a 100644 --- a/analysis/comp_assessments/PROTOCOL.md +++ b/analysis/comp_assessments/PROTOCOL.md @@ -1,3 +1,3 @@ -# SAIO curation protocol +# Source protocol -The maintained document is PROTOCOL.md in the independent SAIO checkout. Read it before changing source records. Locate that checkout with SAIO_PATH or options(tinyAM.saio_path = '/path/to/saio'). See README.md here for the translation workflow. +The maintained document is [PROTOCOL.md](https://github.com/PaulRegular/saio/blob/main/PROTOCOL.md) in SAIO. Source changes and validation belong there. tinyAM reads a manually refreshed local snapshot; see [README.md](README.md). diff --git a/analysis/comp_assessments/R/plot_stock_order.R b/analysis/comp_assessments/R/plot_stock_order.R index fdd8bf2a..a5dcc02c 100644 --- a/analysis/comp_assessments/R/plot_stock_order.R +++ b/analysis/comp_assessments/R/plot_stock_order.R @@ -1,4 +1,8 @@ # Higher groups follow Betancur-R. et al. (2017), doi:10.1186/s12862-017-0958-3. +# Additional genera/families checked against Eschmeyer's Catalog of Fishes (2026): +# https://researcharchive.calacademy.org/research/ichthyology/catalog/SpeciesByFamily.asp +# Species records: Molva (Lotidae), Argentina (Argentinidae), Anarhichas +# (Anarhichadidae), Anoplopoma (Anoplopomatidae); flatfishes remain Pleuronectidae. # Scientific names break ties within groups; stocks of a species stay together. assessment_plot_stocks <- function(assessments, stocks, assessment_ids) { groups <- list( @@ -11,13 +15,18 @@ assessment_plot_stocks <- function(assessments, stocks, assessment_ids) { Carangidae = "Trachurus", Cyclopsettidae = "Paralichthys", Scophthalmidae = "Scophthalmus", - Pleuronectidae = c("Atheresthes", "Eopsetta", "Glyptocephalus", "Hippoglossoides", "Lepidopsetta", "Limanda", "Pleuronectes", "Pseudopleuronectes"), + Pleuronectidae = c("Atheresthes", "Eopsetta", "Glyptocephalus", "Hippoglossoides", "Lepidopsetta", "Limanda", "Pleuronectes", "Pseudopleuronectes", + "Reinhardtius", "Myzopsetta", "Microstomus"), Soleidae = "Solea", Sparidae = "Stenotomus", Uranoscopiformes = "Ammodytes", Moronidae = c("Morone", "Dicentrarchus"), Sebastidae = "Sebastes", - Hexagrammidae = "Pleurogrammus" + Hexagrammidae = "Pleurogrammus", + Argentinidae = "Argentina", + Lotidae = "Molva", + Anarhichadidae = "Anarhichas", + Anoplopomatidae = "Anoplopoma" ) group_rank <- setNames(rep(seq_along(groups), lengths(groups)), unlist(groups, use.names = FALSE)) diff --git a/analysis/comp_assessments/R/read_database.R b/analysis/comp_assessments/R/read_database.R index 6d5ce2ac..cb27db5b 100644 --- a/analysis/comp_assessments/R/read_database.R +++ b/analysis/comp_assessments/R/read_database.R @@ -1,150 +1,30 @@ -.assessment_database_files <- c( - "stocks.csv", "assessments.csv", "assumptions.csv", "inputs.csv", "outputs.csv" -) - -.assessment_database <- function(read_table, source, commit = NA_character_, - reference = NA_character_, selection = source, - key = commit) { - tables <- lapply(.assessment_database_files, read_table) - names(tables) <- c("stocks", "assessments", "assumptions", "inputs", "outputs") - tables$database_source <- source - tables$commit <- commit - tables$database_ref <- reference - tables$database_selection <- selection - tables$database_key <- key - tables -} - -.database_git <- function(repo, args, stdout = TRUE) { - system2("git", c("-C", shQuote(normalizePath(repo, winslash = "/", mustWork = TRUE)), - shQuote(args)), stdout = stdout, stderr = TRUE) -} - -.database_head <- function(repo = ".", revision = "HEAD") { - value <- suppressWarnings(tryCatch(.database_git(repo, - c("rev-parse", "--verify", paste0(revision, "^{commit}"))), +.database_head <- function(repo = ".") { + value <- suppressWarnings(tryCatch(system2("git", c("-C", shQuote(repo), + "rev-parse", "--verify", "HEAD"), stdout = TRUE, stderr = FALSE), error = function(e) character())) if (length(value) != 1L || !grepl("^[[:xdigit:]]{40}$", value)) return(NA_character_) value[[1]] } -saio_path <- function() { - configured <- getOption("tinyAM.saio_path", Sys.getenv("SAIO_PATH", "")) - common <- suppressWarnings(tryCatch(system2("git", - c("rev-parse", "--path-format=absolute", "--git-common-dir"), - stdout = TRUE, stderr = FALSE), error = function(e) character())) - candidates <- if (nzchar(configured)) configured else c( - if (length(common) == 1L) file.path(dirname(dirname(common)), "saio"), - file.path("..", "saio") - ) - found <- candidates[dir.exists(file.path(candidates, "database"))] - if (!length(found)) cli::cli_abort(c( - "Cannot find the independent SAIO checkout.", - "i" = "Set SAIO_PATH or {.code options(tinyAM.saio_path = '/path/to/saio')}." - )) - normalizePath(found[[1]], winslash = "/", mustWork = TRUE) -} - -.saio_snapshot_revision <- function(tier = "curated") { - tier <- match.arg(tier, c("curated", "preliminary")) - pins <- read.csv(file.path("analysis", "comp_assessments", "saio_revisions.csv"), - stringsAsFactors = FALSE) - revision <- pins$revision[pins$tier == tier] - if (length(revision) != 1L || is.na(revision) || !grepl("^[[:xdigit:]]{40}$", revision)) { - cli::cli_abort("saio_revisions.csv must contain one complete SAIO commit ID per tier.") - } - revision -} - -.saio_revision <- function(tier = "curated", repo = saio_path()) { - match.arg(tier, c("curated", "preliminary")) - main <- .database_head(repo, "refs/heads/main") - if (is.na(main)) cli::cli_abort(c( - "The local SAIO main branch is unavailable.", - "i" = "Create or update main in the SAIO checkout before reading current data, or supply an explicit revision." - )) - remote <- .database_head(repo, "refs/remotes/origin/main") - if (!is.na(remote)) { - ancestor <- suppressWarnings(.database_git(repo, - c("merge-base", "--is-ancestor", remote, main))) - code <- attr(ancestor, "status") - if (!is.null(code) && code != 0L) cli::cli_abort(c( - "SAIO main is behind or diverged from the fetched origin/main.", - "i" = "Update the SAIO checkout with git pull --ff-only, resolving any divergence explicitly, before reading current data." - )) - } - main -} - -.saio_metadata <- function(revision = NULL, repo = saio_path(), tier = "curated") { - match.arg(tier, c("curated", "preliminary")) - latest <- is.null(revision) - if (latest) revision <- .saio_revision(tier, repo) - if (!is.character(revision) || length(revision) != 1L || is.na(revision) || !nzchar(revision)) { - cli::cli_abort("SAIO revision must identify one committed revision.") - } - commit <- .database_head(repo, revision) - if (is.na(commit)) cli::cli_abort("Cannot resolve SAIO revision {.val {revision}}.") - list(database_source = "saio_committed", commit = commit, - database_ref = if (latest) "refs/heads/main" else revision, - database_selection = if (latest) "latest_main" else "explicit_revision", - database_key = commit) -} - -.saio_read_table <- function(name, repo = saio_path(), revision = .saio_revision(tier, repo), - tier = "curated") { - pointer <- tempfile("saio_table_", fileext = ".csv") - on.exit(unlink(pointer), add = TRUE) - status <- .database_git(repo, c("show", paste0(revision, ":database/", name)), - stdout = pointer) - code <- if (is.numeric(status)) status else attr(status, "status") - if ((!is.null(code) && code != 0L) || !file.exists(pointer)) { - cli::cli_abort("Cannot read {.file {name}} at SAIO revision {.val {revision}}.") - } - first <- readLines(pointer, n = 1L, warn = FALSE) - table_path <- pointer - if (identical(first, "version https://git-lfs.github.com/spec/v1")) { - oid <- sub("^oid sha256:", "", readLines(pointer, warn = FALSE)[[2]]) - if (!grepl("^[[:xdigit:]]{64}$", oid)) cli::cli_abort("Invalid SAIO LFS pointer.") - common <- .database_git(repo, - c("rev-parse", "--path-format=absolute", "--git-common-dir")) - table_path <- file.path(common[[1]], "lfs", "objects", substr(oid, 1L, 2L), - substr(oid, 3L, 4L), oid) - if (!file.exists(table_path)) cli::cli_abort(c( - "The committed SAIO data object for {.file {name}} is unavailable locally.", - "i" = "Fetch this revision's Git LFS objects in the SAIO checkout before reading it." - )) - } - read.csv(table_path, stringsAsFactors = FALSE, - na.strings = c("", "NA"), check.names = FALSE) -} - -read_database <- function(database_dir = NULL, tier = "curated", revision = NULL, - repo = saio_path()) { - if (is.null(database_dir)) return(read_committed_database(revision, repo, tier)) - if (!is.null(revision)) cli::cli_abort("Supply a committed revision or a working database directory, not both.") - if (!dir.exists(database_dir)) cli::cli_abort("Database directory does not exist: {.file {database_dir}}.") - files <- file.path(database_dir, .assessment_database_files) - if (any(!file.exists(files))) cli::cli_abort("The working database requires all five source tables.") - hashes <- tools::md5sum(files) - if (anyNA(hashes)) cli::cli_abort("The working database requires all five source tables.") - fingerprint <- tempfile("saio_working_") - on.exit(unlink(fingerprint), add = TRUE) - writeLines(paste(.assessment_database_files, unname(hashes)), fingerprint) - key <- paste0("working-", unname(tools::md5sum(fingerprint))) - .assessment_database(function(name) read.csv(file.path(database_dir, name), - stringsAsFactors = FALSE, na.strings = c("", "NA"), check.names = FALSE), - source = "working_tree", commit = .database_head(database_dir), - reference = "working_tree", key = key) +.assessment_snapshot <- function(manifest = file.path("analysis", "comp_assessments", + "saio_revisions.csv")) { + read.csv(manifest, stringsAsFactors = FALSE)$revision[[1]] } -read_committed_database <- function(revision = NULL, repo = saio_path(), - tier = "curated") { - metadata <- .saio_metadata(revision, repo, tier) - .assessment_database(function(name) .saio_read_table(name, repo, metadata$commit), - source = metadata$database_source, commit = metadata$commit, - reference = metadata$database_ref, selection = metadata$database_selection, - key = metadata$database_key) +# Read the manually refreshed snapshot. This function needs neither SAIO nor Git. +read_database <- function(cache_dir = file.path("analysis", "comp_assessments", "cache", "saio"), + manifest = file.path("analysis", "comp_assessments", "saio_revisions.csv")) { + if (!file.exists(manifest)) cli::cli_abort("Run analysis/comp_assessments/scripts/update_database_cache.R before fitting: the SAIO snapshot manifest is missing.") + revision <- .assessment_snapshot(manifest) + folder <- file.path(cache_dir, revision) + cached <- file.path(folder, "database.rds") + if (!file.exists(cached)) cli::cli_abort( + "The local SAIO snapshot is unavailable or incomplete. Run analysis/comp_assessments/scripts/update_database_cache.R before fitting.") + tables <- readRDS(cached) + tables$database_source <- "saio_snapshot" + tables$commit <- tables$database_ref <- tables$database_key <- revision + tables$database_selection <- "cached_snapshot" + tables } read_assessment <- function(assessment_id, database = NULL) { @@ -183,8 +63,3 @@ read_assessment <- function(assessment_id, database = NULL) { tables$assessment <- assessment tables } - -read_committed_assessment <- function(assessment_id, database = NULL) { - if (is.null(database)) database <- read_committed_database() - read_assessment(assessment_id, database) -} diff --git a/analysis/comp_assessments/R/run_assessment.R b/analysis/comp_assessments/R/run_assessment.R index abefea06..73f6f17d 100644 --- a/analysis/comp_assessments/R/run_assessment.R +++ b/analysis/comp_assessments/R/run_assessment.R @@ -325,12 +325,64 @@ view_assessment <- function(fit, assessment, output_file = NULL, open_file = TRU "unrecorded; supplied fit provenance has not been verified", ".") tinyAM::vis_tam( model_list = list(Official = result$ref, tinyAM = result$fit), - background = c(assessment$background, "", provenance), output_file = result$dashboard_file, + background = c(if (!isTRUE(result$diagnostics$is_converged)) c( + "### Troubleshooting fit", "Numerical checks did not pass. Inspect Diagnostics before interpreting estimates or uncertainty.", ""), + assessment$background, "", provenance), output_file = result$dashboard_file, open_file = open_file ) invisible(result) } +# Rendering is deliberately separate from fitting and numerical eligibility. +render_assessment_dashboards <- function(runs, open_file = FALSE) { + if (!is.list(runs) || any(!vapply(runs, is.list, logical(1)))) { + cli::cli_abort("Supply the results returned by run_assessments().") + } + if (!is.logical(open_file) || length(open_file) != 1L || is.na(open_file)) { + cli::cli_abort("open_file must be TRUE or FALSE.") + } + if (!length(runs)) return(data.frame(assessment_id = character(), status = character(), + file = character(), error = character())) + tiers <- unique(vapply(runs, function(x) x$translation_tier, character(1))) + keys <- unique(vapply(runs, .assessment_result_key, character(1))) + if (length(tiers) != 1L || length(keys) != 1L) { + cli::cli_abort("Render one translation tier and SAIO snapshot at a time.") + } + tier <- tiers[[1]] + database <- list(database_key = keys[[1]]) + manifest <- lapply(names(runs), function(id) { + result <- runs[[id]] + row <- data.frame(assessment_id = id, status = "skipped_no_fit", file = NA_character_, + error = "No usable fitted model was returned.", stringsAsFactors = FALSE) + if (!inherits(result$fit, "tam_fit")) { + reason <- result$diagnostics$reason + if (length(reason) && !is.na(reason[[1]]) && nzchar(reason[[1]])) row$error <- reason[[1]] + return(row) + } + row$file <- file.path(.assessment_cache(id, tier, database), "dashboard.html") + dir.create(dirname(row$file), recursive = TRUE, showWarnings = FALSE) + troubleshooting <- !isTRUE(result$fit$is_converged) + cli::cli_inform("Rendering {id}{if (troubleshooting) ' (troubleshooting: numerical checks did not pass)' else ''}.") + error <- tryCatch({ + view_assessment(result$fit, result, output_file = row$file, open_file = FALSE) + NULL + }, error = conditionMessage) + row$status <- if (!is.null(error)) "render_failed" else if (troubleshooting) "troubleshooting" else "rendered" + row$error <- if (is.null(error)) NA_character_ else error + if (identical(row$status, "troubleshooting")) cli::cli_inform("Troubleshooting dashboard: {.file {row$file}}") + row + }) + manifest <- do.call(rbind, manifest) + folder <- .assessment_cache_root(tier, database) + dir.create(folder, recursive = TRUE, showWarnings = FALSE) + write.csv(manifest, file.path(folder, "dashboard_manifest.csv"), row.names = FALSE, na = "") + index <- .index_assessment_dashboards(tier, database) + cli::cli_inform(c("Dashboards: {sum(manifest$status == 'rendered')} rendered; {sum(manifest$status == 'troubleshooting')} for troubleshooting; {sum(manifest$status == 'render_failed')} failed; {sum(manifest$status == 'skipped_no_fit')} skipped.", + "i" = "Fits and numerical comparison eligibility are unchanged. Inspect dashboard_manifest.csv and fit_diagnostics.csv before interpreting results.")) + if (open_file) utils::browseURL(index) + manifest +} + .assessment_log <- function(path, text) { if (!is.null(path)) cat(format(Sys.time(), "%Y-%m-%d %H:%M:%S"), text, "\n", file = path, append = TRUE) @@ -347,16 +399,15 @@ view_assessment <- function(fit, assessment, output_file = NULL, open_file = TRU } run_assessment <- function(assessment_id, database = NULL, fit = TRUE, - dashboard = FALSE, cache = FALSE, silent = TRUE, + cache = FALSE, silent = TRUE, log_file = NULL, tier = NULL) { entry <- .assessment_translation(assessment_id, tier, required = FALSE) tier <- if (is.null(entry)) "curated" else entry$tier[[1]] - if (is.null(database)) database <- read_database(tier = tier) + if (is.null(database)) database <- read_database() database$translation_tier <- tier if (length(fit) != 1L || is.na(fit) || !is.logical(fit) || - length(dashboard) != 1L || is.na(dashboard) || !is.logical(dashboard) || length(cache) != 1L || is.na(cache) || !is.logical(cache)) { - stop("fit, dashboard, and cache must each be one TRUE/FALSE value.", call. = FALSE) + stop("fit and cache must each be one TRUE/FALSE value.", call. = FALSE) } source <- read_assessment(assessment_id, database) @@ -449,25 +500,13 @@ run_assessment <- function(assessment_id, database = NULL, fit = TRUE, } result[c("ref", "differences", "summary")] <- comparison[c("ref", "differences", "summary")] - if (dashboard) { - result$dashboard_file <- if (cache) { - file.path(cache_dir, "dashboard.html") - } else { - tempfile(pattern = paste0(assessment_id, "_"), fileext = ".html") - } - tinyAM::vis_tam( - model_list = list(Official = result$ref, tinyAM = fitted), - background = result$background, - output_file = result$dashboard_file, - open_file = interactive() - ) - } result } .failed_assessment_run <- function(assessment_id, database, error) { result <- list( assessment_id = assessment_id, + translation_tier = database$translation_tier, source = NULL, obs = NULL, fit = NULL, @@ -485,77 +524,79 @@ run_assessment <- function(assessment_id, database = NULL, fit = TRUE, result } -.parallel_assessment_worker <- function(assessment_id, database, repo_root, fit, - cache = FALSE, timeout = Inf, log_file = NULL, tier = NULL) { +.assessment_worker <- function(database, repo_root, fit, cache = FALSE, + timeout = Inf, tier = NULL, isolated = TRUE, tick = NULL) { + id <- database$assessment$assessment_id[[1]] + if (!is.null(tick)) tick(amount = 0, message = paste(id, "started")) + log_file <- NULL + if (cache) { + cache_dir <- .assessment_cache(id, tier, database) + dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) + log_file <- file.path(cache_dir, "run.log") + writeLines(character(), log_file) + } + .assessment_log(log_file, paste(id, "started; timeout", timeout, "seconds.")) original_wd <- getwd() on.exit(setwd(original_wd), add = TRUE) begun <- Sys.time() - # A subprocess deadline also covers native optimizer code that may not check - # R's elapsed-time interrupt. Only this assessment's process is terminated. - if (is.finite(timeout)) { - return(tryCatch( - callr::r(function(assessment_id, database, repo_root, fit, cache, log_file, tier) { + result <- tryCatch({ + # A subprocess deadline can also interrupt native optimizer code. + if (is.finite(timeout)) { + callr::r(function(id, database, repo_root, fit, cache, log_file, tier) { pkgload::load_all(repo_root, quiet = TRUE) - runner_env <- new.env(parent = globalenv()) + runner <- new.env(parent = globalenv()) sys.source(file.path(repo_root, "analysis", "comp_assessments", "R", - "run_assessment.R"), envir = runner_env) - runner_env$run_assessment(assessment_id, database = database, fit = fit, - dashboard = FALSE, cache = cache, log_file = log_file, tier = tier) - }, args = list(assessment_id, database, repo_root, fit, cache, log_file, tier), + "run_assessment.R"), envir = runner) + runner$run_assessment(id, database = database, fit = fit, + cache = cache, log_file = log_file, tier = tier) + }, args = list(id, database, repo_root, fit, cache, log_file, tier), wd = repo_root, libpath = .libPaths(), timeout = timeout, stdout = if (is.null(log_file)) NULL else paste0(log_file, ".output"), - stderr = "2>&1"), - error = function(e) { - result <- .failed_assessment_run(assessment_id, database, e) - result$diagnostics$elapsed_seconds <- as.numeric(difftime(Sys.time(), begun, units = "secs")) - if (inherits(e, "callr_timeout_error")) { - result$diagnostics$status <- "timed_out" - result$diagnostics$reason <- paste("Time limit of", timeout, - "seconds exceeded; model settings were not changed.") - } - result - } - )) - } - tryCatch( - { + stderr = "2>&1") + } else if (isolated) { setwd(repo_root) pkgload::load_all(repo_root, quiet = TRUE) - runner_env <- new.env(parent = globalenv()) - sys.source(file.path( - repo_root, "analysis", "comp_assessments", "R", - "run_assessment.R" - ), envir = runner_env) - runner_env$run_assessment( - assessment_id, - database = database, fit = fit, - dashboard = FALSE, cache = cache, log_file = log_file, tier = tier - ) - }, - error = function(e) .failed_assessment_run(assessment_id, database, e) - ) + runner <- new.env(parent = globalenv()) + sys.source(file.path(repo_root, "analysis", "comp_assessments", "R", + "run_assessment.R"), envir = runner) + runner$run_assessment(id, database = database, fit = fit, + cache = cache, log_file = log_file, tier = tier) + } else { + run_assessment(id, database = database, fit = fit, + cache = cache, log_file = log_file, tier = tier) + } + }, error = function(e) { + result <- .failed_assessment_run(id, database, e) + result$diagnostics$elapsed_seconds <- as.numeric(difftime(Sys.time(), begun, units = "secs")) + if (inherits(e, "callr_timeout_error")) { + result$diagnostics$status <- "timed_out" + result$diagnostics$reason <- paste("Time limit of", timeout, + "seconds exceeded; model settings were not changed.") + } + result + }) + if (cache) { + .assessment_log(log_file, "Saving completed assessment checkpoint.") + .assessment_save_rds(result, file.path(cache_dir, "result.rds")) + } + .assessment_log(log_file, paste(id, "finished:", result$diagnostics$status)) + if (!is.null(tick)) tick(message = paste(id, result$diagnostics$status)) + result } run_assessments <- function(assessment_ids = NULL, database = NULL, - parallel = FALSE, workers = 4L, fit = TRUE, - dashboard = FALSE, cache = FALSE, + fit = TRUE, cache = FALSE, save_results = FALSE, timeout = Inf, progress = TRUE, tier = "curated") { tier <- match.arg(tier, c("curated", "preliminary")) - if (is.null(database)) database <- read_database(tier = tier) - if (!is.logical(parallel) || length(parallel) != 1L || is.na(parallel) || - !is.logical(fit) || length(fit) != 1L || is.na(fit) || - !is.logical(dashboard) || length(dashboard) != 1L || is.na(dashboard) || + if (is.null(database)) database <- read_database() + if (!is.logical(fit) || length(fit) != 1L || is.na(fit) || !is.logical(cache) || length(cache) != 1L || is.na(cache) || !is.logical(save_results) || length(save_results) != 1L || is.na(save_results)) { - stop("parallel, fit, dashboard, cache, and save_results must each be one TRUE/FALSE value.", + stop("fit, cache, and save_results must each be one TRUE/FALSE value.", call. = FALSE ) } - if (length(workers) != 1L || is.na(workers) || !is.numeric(workers) || - !is.finite(workers) || workers < 1 || workers != as.integer(workers)) { - stop("workers must be one positive integer.", call. = FALSE) - } if (!is.numeric(timeout) || length(timeout) != 1L || is.na(timeout) || timeout <= 0) { cli::cli_abort("{.arg timeout} must be positive seconds or Inf.") } @@ -588,52 +629,14 @@ run_assessments <- function(assessment_ids = NULL, database = NULL, if (!length(assessment_ids)) return(.assessment_result_tables(list(), save_results, tier)) repo_root <- normalizePath(getwd(), winslash = "/", mustWork = TRUE) - if (parallel) { - if (!requireNamespace("pkgload", quietly = TRUE)) { - stop("Install pkgload to run parallel workers from the current tinyAM checkout.", - call. = FALSE - ) - } - old_plan <- future::plan() - on.exit(future::plan(old_plan), add = TRUE) - future::plan(future::multisession, workers = as.integer(workers)) - } + if (!requireNamespace("pkgload", quietly = TRUE)) cli::cli_abort("Install pkgload to load the current tinyAM checkout in assessment workers.") + use_worker <- is.finite(timeout) || !inherits(future::plan(), "sequential") + jobs <- lapply(assessment_ids, read_assessment, database = database) runs <- progressr::with_progress({ tick <- progressr::progressor(steps = length(assessment_ids)) - safe_run <- function(id) { - tick(amount = 0, message = paste(id, "started")) - # Workers need only this stock's tables, not the entire source database. - stock_database <- read_assessment(id, database) - log_file <- NULL - if (cache) { - cache_dir <- .assessment_cache(id, tier, database) - dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) - log_file <- file.path(cache_dir, "run.log") - writeLines(character(), log_file) - } - .assessment_log(log_file, paste(id, "started; timeout", timeout, "seconds.")) - result <- if (parallel || is.finite(timeout)) { - .parallel_assessment_worker(id, stock_database, repo_root, fit, - cache = cache, timeout = timeout, log_file = log_file, tier = tier) - } else { - tryCatch(run_assessment(id, database = stock_database, fit = fit, - dashboard = FALSE, cache = cache, log_file = log_file, tier = tier), - error = function(e) .failed_assessment_run(id, stock_database, e)) - } - if (cache) { - .assessment_log(log_file, "Saving completed assessment checkpoint.") - .assessment_save_rds(result, file.path(cache_dir, "result.rds")) - } - .assessment_log(log_file, paste(id, "finished:", result$diagnostics$status)) - tick(message = paste(id, result$diagnostics$status)) - result - } - if (parallel) { - furrr::future_map(assessment_ids, safe_run, - .options = furrr::furrr_options(seed = TRUE, scheduling = Inf)) - } else { - lapply(assessment_ids, safe_run) - } + furrr::future_map(jobs, .assessment_worker, repo_root = repo_root, fit = fit, + cache = cache, timeout = timeout, tier = tier, isolated = use_worker, tick = tick, + .options = furrr::furrr_options(seed = TRUE, scheduling = Inf)) }, enable = progress, handlers = progressr::make_progression_handler( "assessment", interval = 0, enable = progress, reporter = list(update = function(config, state, progression, ...) { @@ -642,25 +645,6 @@ run_assessments <- function(assessment_ids = NULL, database = NULL, )) names(runs) <- assessment_ids - for (id in assessment_ids) { - result <- runs[[id]] - if (dashboard && !is.null(result$fit) && isTRUE(result$fit$is_converged) && - !is.null(result$ref)) { - result$dashboard_file <- if (cache) { - file.path(.assessment_cache(id, tier, database), "dashboard.html") - } else { - tempfile(pattern = paste0(id, "_"), fileext = ".html") - } - tinyAM::vis_tam( - model_list = list(Official = result$ref, tinyAM = result$fit), - background = result$background, - output_file = result$dashboard_file, - open_file = FALSE - ) - runs[[id]] <- result - } - } - .assessment_result_tables(runs, save_results, tier) } diff --git a/analysis/comp_assessments/R/translation_registry.R b/analysis/comp_assessments/R/translation_registry.R index 32f296a2..5c1840f5 100644 --- a/analysis/comp_assessments/R/translation_registry.R +++ b/analysis/comp_assessments/R/translation_registry.R @@ -11,7 +11,7 @@ assessment_translations <- function(tier = NULL) { registry <- registry[registry$tier == tier, , drop = FALSE] } registry$script <- file.path("analysis", "comp_assessments", "scripts", - "translation", registry$tier, paste0(registry$assessment_id, ".R")) + registry$tier, paste0(registry$assessment_id, ".R")) registry } @@ -39,7 +39,7 @@ assessment_translations <- function(tier = NULL) { } .assessment_cache_key <- function(database = NULL) { - if (is.null(database)) return(.saio_revision()) + if (is.null(database)) return(.assessment_snapshot()) key <- database$database_key if (is.null(key) && !identical(database$database_source, "working_tree")) key <- database$commit if (!is.character(key) || length(key) != 1L || is.na(key) || @@ -96,7 +96,7 @@ assessment_translations <- function(tier = NULL) { invisible(TRUE) } -index_assessment_dashboards <- function(tier = "curated", database = NULL) { +.index_assessment_dashboards <- function(tier = "curated", database = NULL) { selected <- .assessment_cache_key(database) folder <- .assessment_results(tier) dir.create(folder, recursive = TRUE, showWarnings = FALSE) diff --git a/analysis/comp_assessments/R/update_database_cache.R b/analysis/comp_assessments/R/update_database_cache.R new file mode 100644 index 00000000..063939dc --- /dev/null +++ b/analysis/comp_assessments/R/update_database_cache.R @@ -0,0 +1,40 @@ +# Manual step: commit SAIO tables and resolve Git LFS files before running. +update_database_cache <- function(saio_repo, + cache_dir = file.path("analysis", "comp_assessments", "cache", "saio"), + manifest = file.path("analysis", "comp_assessments", "saio_revisions.csv")) { + files <- c("stocks.csv", "assessments.csv", "assumptions.csv", "inputs.csv", "outputs.csv") + revision <- system2("git", c("-C", shQuote(saio_repo), "rev-parse", "HEAD"), + stdout = TRUE) + if (length(revision) != 1L || !is.null(attr(revision, "status"))) { + cli::cli_abort("Cannot read SAIO HEAD. Set saio_repo to the local committed SAIO checkout.") + } + target <- file.path(cache_dir, revision) + if (!dir.exists(target)) { + dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) + staging <- tempfile(".snapshot-", tmpdir = cache_dir) + dir.create(staging) + on.exit(unlink(staging, recursive = TRUE), add = TRUE) + if (!all(file.copy(file.path(saio_repo, "database", files), file.path(staging, files)))) { + cli::cli_abort("Could not copy all five SAIO tables; the previous manifest remains selected.") + } + if (!file.rename(staging, target)) cli::cli_abort("Could not publish the SAIO snapshot.") + } + # Parse the copied tables once, using the same base-R reader as before. + parsed <- file.path(target, "database.rds") + if (!file.exists(parsed)) { + tables <- lapply(file.path(target, files), read.csv, stringsAsFactors = FALSE, + na.strings = c("", "NA"), check.names = FALSE) + names(tables) <- sub("[.]csv$", "", files) + temporary <- tempfile(".database-", tmpdir = target) + on.exit(unlink(temporary), add = TRUE) + saveRDS(tables, temporary) + if (!file.rename(temporary, parsed)) cli::cli_abort("Could not save the parsed SAIO cache.") + } + # Select the revision only after its five CSVs have been copied successfully. + temporary <- tempfile(".saio-manifest-", tmpdir = dirname(manifest)) + on.exit(unlink(temporary), add = TRUE) + write.csv(data.frame(revision = revision), temporary, row.names = FALSE) + if (!file.rename(temporary, manifest)) cli::cli_abort("Could not replace the SAIO snapshot manifest.") + cli::cli_inform("SAIO snapshot selected: {revision}. Both translation tiers use these local CSVs.") + invisible(revision) +} diff --git a/analysis/comp_assessments/README.md b/analysis/comp_assessments/README.md index 1ee534b0..9d4a3060 100644 --- a/analysis/comp_assessments/README.md +++ b/analysis/comp_assessments/README.md @@ -4,8 +4,8 @@ Source data are maintained in the independent **SAIO — Stock Assessment Inputs ## Curated and preliminary translations -- scripts/translation/curated/: the 35 scripts retained from main at 78f3d347331b0e770d55a855de4c5b90307fd400. This preserves the existing paper working set, including its documented blocked cases. Membership does not imply convergence or scientific equivalence. -- scripts/translation/preliminary/: additional translations and changed alternatives from comp-assessments. They have not been promoted into the paper working set. +- scripts/curated/: the 35 scripts retained from main at 78f3d347331b0e770d55a855de4c5b90307fd400. This preserves the existing paper working set, including its documented blocked cases. Membership does not imply convergence or scientific equivalence. +- scripts/preliminary/: additional translations and changed alternatives from comp-assessments. They have not been promoted into the paper working set. - translations.csv: the explicit registry, including each script's originating commit. An assessment can have a curated version and a preliminary alternative. Curated runs are the default. Preliminary runs require an explicit tier. Extraction completeness, translation review and numerical convergence are separate. Move a script and update the registry only after reviewing its sources, assumptions and comparisons. If both tiers contain the same assessment, selecting its ID without a tier uses the curated version. @@ -23,54 +23,68 @@ not establish that data can never be recovered. `reconstruction_pending` means native observations are present but their age/length, sex, area or removal definitions still need a reviewed conversion. Neither status counts as a fit. -## SAIO data +## 1. Refresh source data manually -Clone [SAIO](https://github.com/PaulRegular/saio) beside tinyAM. The default lookup uses the primary tinyAM checkout's parent directory, so it also works from Git worktrees. On this laptop the locations are `C:/Users/paulr/Documents/tinyAM` and `C:/Users/paulr/Documents/saio`. +Source curation and validation belong to [SAIO](https://github.com/PaulRegular/saio). Update its local checkout yourself, then open `scripts/update_database_cache.R`, set `saio_repo`, and run it from the tinyAM repository root. Before running it, commit the five database CSVs in SAIO and ensure they are available as real CSV files, not Git LFS pointers. The script never fetches, switches branches or edits SAIO. -For another location, set SAIO_PATH to your local SAIO checkout, or use: +The updater copies the five tables into ignored `cache/saio//` and parses those copies once into `database.rds` with base R, then updates tracked `saio_revisions.csv` **last**. Both translation tiers use this one snapshot. Previous snapshots remain untouched. Commit the manifest when intentionally advancing the shared data version; collaborators run the updater from that same SAIO commit to obtain its ignored files. + +Normal analysis reads only the local snapshot: ```r -options(tinyAM.saio_path = "/path/to/saio") source("analysis/comp_assessments/R/run_assessment.R") database <- read_database() ``` -Both translation tiers read the latest **committed local SAIO main** by default. The reader resolves main once and records that exact commit; it ignores uncommitted table edits and another checked-out branch. Curated membership remains the same 35 scripts, while their inputs now follow current SAIO data. - -Update SAIO before an analysis with `git -C /path/to/saio switch main`, `git -C /path/to/saio pull --ff-only` and `git -C /path/to/saio lfs pull`. Reading or fitting never fetches data automatically. If the fetched origin/main is ahead of or diverges from local main, reading current data stops with an update instruction. Locally committed changes ahead of origin/main are included and identified by their actual commit. +Normal reads load the parsed cache rather than repeatedly parsing the large CSVs. Reading and fitting do not need SAIO or Git. They do not notice later SAIO edits until the cache is explicitly refreshed. A missing or incomplete snapshot stops with an update instruction. Treat cached snapshots as read-only. There is no automatic historical-revision or working-tree reader; old manifests are preserved in Git history and old snapshot folders are retained locally. -For a reproducible historical run, supply `read_database(revision = "")` or `read_committed_database(revision = "")`. The commit and its LFS objects must be available locally; fetch missing objects explicitly with `git -C /path/to/saio lfs fetch origin `. To deliberately inspect edited tables, use `read_database(file.path(saio_path(), "database"))`; those reads have a separate content fingerprint. +One preliminary English Channel plaice recipe retains its documented native-SAM starting-value retry. That optional retry also needs `source_cache/ices_plaice_7d_2026/fit_local_locked.RData`, copied manually from the reviewed source artifact. It is distinct from the five-table snapshot and is never fetched at fitting time. -Diagnostics and cached fits record the actual SAIO revision, selection and tinyAM revision. Recheck affected translations before refreshing paper figures when source data advance. DATABASE_STRUCTURE.md and PROTOCOL.md point to their maintained SAIO documents. +## 2. Fit assessments -## Run or preview a translation +For one stock, open `scripts/run_stock.R`, select `translation_tier` and `assessment_id`, and source its Fit section. The literal model call remains in the registered recipe. The workspace exposes its inputs, fit and comparison context. Rerun the Preview line after editing the model; previewing never refits it. -Open scripts/translation/run_stock.R, select translation_tier and assessment_id, then source it. For a batch, use scripts/translation/run_all.R. Its translation_tier defaults to curated; use preliminary deliberately for the wider library. Batch membership comes from translations.csv, rather than SAIO's is_current flag. +For a batch, open `scripts/run_all.R`. Its stages are deliberately separate: ```r -result <- run_assessment("afsc_cod_ebs_2024", tier = "curated", - database = database, fit = FALSE) -preliminary <- assessment_translations("preliminary") +future::plan(future::multisession, workers = 10) +runs <- run_assessments(database = database, tier = "curated", + cache = TRUE, save_results = TRUE, timeout = 20 * 60) ``` -The full scientific translation instructions remain in [TINYAM_TRANSLATION.md](TINYAM_TRANSLATION.md). Stock-specific assumptions and inherited fit reviews are in [translation_notes/](translation_notes/README.md); official source evidence remains in SAIO. Shared converters and dashboard helpers serve both tiers. These are analysis-local functions; package model mathematics and public interfaces are unchanged. +Use `future::plan(future::sequential)` to troubleshoot. `run_assessments()` honors the caller's plan and never changes it. Its default `timeout = Inf` is unbounded; the batch script visibly selects a 20-minute deadline. A finite limit uses a supervised R subprocess so native optimizer code can be stopped. Every failed or timed-out attempt remains in diagnostics; model settings and starting-value policies are unchanged. + +Each completed assessment is checkpointed immediately when caching is enabled. Checkpoints are replaced only after serialization completes. `cache` saves results; it never skips fitting. Aggregate CSVs are written only with `save_results = TRUE`, after workers finish. Targeted trials must not overwrite the canonical batch summaries. -## Local outputs +## 3. Render and inspect dashboards -All generated results are ignored by Git and separated under results/curated/ and results/preliminary/. Fits, dashboards and initialization attempts use `cache///`; batch checkpoints share that revision folder. Explicit edited-table reads use a `working-` key. Previous unversioned caches and historical revision folders are preserved and are never substituted for current fits. Plot scripts reject result tables or caches from another or unknown data revision. Preliminary results never enter curated summaries by default. +```r +dashboards <- render_assessment_dashboards(runs) +``` -Open results/curated/index.html or results/preliminary/index.html for dashboards. Regenerated indexes label the selected source revision separately from historical or unknown-revision outputs, without rewriting old HTML. Fresh previews show source provenance and reject a known mismatch between the supplied fit and assessment context. Older comp-assessments outputs for curated stocks are under curated/legacy_comp_assessments/ and require revalidation before paper use. Older mixed batch summaries remain in preliminary/ and are historical outputs, not a newly completed preliminary batch. results/output_migration.json records the source and destination of relocated files. +This stage uses returned fits and their original source context. It does not reread SAIO, refit models or calculate OSA residuals. Nonconverged fits with usable predictions may produce clearly identified **troubleshooting** dashboards; they do not become numerically eligible comparisons. Missing fits and render errors remain in `dashboard_manifest.csv`. A rendering failure never loses the saved fit. -## Verification and purpose +Open `results//index.html`. Inspect Fisheries/Surveys residuals, Tables → Diagnostics and Model structure before interpreting trends. Rerun dashboard generation independently after fixing a plotting problem. For an edited individual fit, use `view_assessment(fit, assessment)`; explicit mismatches between fit and source revisions remain errors. -Source recovery and translations used substantial agentic-AI assistance. Not all records and translations have been exhaustively human-verified. Check authoritative sources and diagnostic warnings before research use. tinyAM translations are illustrative abstractions, not official assessments or management advice. +The overview scripts `scripts/stats_plots.R` and `scripts/trend_plots.R` can also run separately. They reject result tables from another data revision. -The broad library supports future standardized comparative modelling. A stock-specific approximation of an official assessment does not automatically define the common formulation for a depensation study. +## Retrospectives and hindcasts + +The same caller-owned future plan controls package evaluation functions: + +```r +future::plan(future::multisession, workers = 10) +retro <- fit_retro(fit, folds = 5) +hind <- fit_hindcast(fit, folds = 5, start_from_fit = TRUE) +print(hind) +vis_tam(hind) +future::plan(future::sequential) +``` -## Historical source snapshots +The hindcast default conditions each forecast on actual aggregate catch, while holding out survey observations and catch composition. Catch-total agreement is therefore not forecast skill. `proj_settings = list(F_mult = 1)` is the status-quo-F alternative. Compare validation coverage before comparing scores; failed folds remain in `fold_diagnostics`. See `?fit_retro` for Mohn's rho, log-RMSE and MASE definitions and multi-model calls. -`saio_revisions.csv` retains historical snapshot references, not active defaults. The curated snapshot preserves the original paper-input tables byte for byte; the preliminary snapshot preserves the expanded database at migration. Request one explicitly with `read_database(revision = .saio_snapshot_revision("curated"))`. Old cached estimates keep their original provenance and are not relabeled as results from current data. +## Results and translation guidance -## Migration history +Generated results remain local and ignored under `results/curated/` and `results/preliminary/`. Fits, checkpoints and dashboards are separated by `cache///`; batch checkpoints share that revision folder. Old revisions and unversioned outputs are historical, never substituted for current fits or relabeled. Cached fits record both their SAIO snapshot and tinyAM revision. -The source-database split and its initial snapshot manifest are documented in [migration/](migration/README.md). SAIO is maintained independently; tinyAM owns its translation provenance and migration history. +The scientific translation instructions remain in [TINYAM_TRANSLATION.md](TINYAM_TRANSLATION.md). Stock-specific assumptions and inherited reviews are in [translation_notes/](translation_notes/README.md); official source evidence is maintained in SAIO. The migration record is in [migration/](migration/README.md). No operational assessment or study hypothesis is changed by this workflow. diff --git a/analysis/comp_assessments/TINYAM_TRANSLATION.md b/analysis/comp_assessments/TINYAM_TRANSLATION.md index 11bf5e24..e7e54e76 100644 --- a/analysis/comp_assessments/TINYAM_TRANSLATION.md +++ b/analysis/comp_assessments/TINYAM_TRANSLATION.md @@ -2,18 +2,18 @@ ## Repository and review tiers -Canonical records, importers, source reviews, discovery registers, DATABASE_STRUCTURE.md and PROTOCOL.md are maintained in SAIO. Read those source instructions there before proposing source corrections. Both translation tiers read committed local SAIO main by default and record the exact data and model revisions. saio_revisions.csv contains historical snapshots for explicit reproduction, not active defaults. +Canonical records, importers, source reviews, discovery registers, DATABASE_STRUCTURE.md and PROTOCOL.md are maintained in SAIO. Read those source instructions there before proposing source corrections. Both translation tiers read the same manually refreshed local CSV snapshot. `saio_revisions.csv` selects its source commit. Run `scripts/update_database_cache.R` explicitly after committing the intended SAIO tables; normal reads never access SAIO or Git. -Translations are registered in translations.csv and stored under scripts/translation/curated/ or preliminary/. The curated set is inherited from main; preliminary scripts and alternatives require explicit selection. A successful fit does not promote a script. Default batches and plots select only curated entries. +Translations are registered in translations.csv and stored under scripts/curated/ or preliminary/. The curated set is inherited from main; preliminary scripts and alternatives require explicit selection. A successful fit does not promote a script. Default batches and plots select only curated entries. Stock-specific model choices and inherited fitting notes are kept in [translation_notes/](translation_notes/README.md). Official source evidence belongs in SAIO, even when a downstream comparison revealed the issue. The registered recipe and its tier define current settings; transferred notes do not constitute a new fit or review. -All local outputs, including dashboards and initialization logs, belong under results//, with fits and checkpoints separated by SAIO revision in cache//, never a shared output directory or SAIO source_cache/. Source caches are external in SAIO. Migrated legacy results retain their provenance and are not newly validated results. +All local outputs, including dashboards and initialization logs, belong under results//, with fits and checkpoints separated by SAIO revision in cache//, never a shared output directory or SAIO source_cache/. Source evidence is maintained in SAIO; a recipe needing a native starting-value artifact uses a separately copied local source_cache file. Migrated legacy results retain their provenance and are not newly validated results. ## Purpose This document defines how a curated source assessment is transformed into data and model settings suitable for a tinyAM analysis. -Read the [scope and provenance statement](README.md#verification-and-purpose) +Read the [workflow and provenance guidance](README.md#results-and-translation-guidance) before interpreting these illustrative model comparisons. The canonical assessment database is intentionally richer than tinyAM. It preserves the fleets, surveys, biological inputs, and statistical assumptions of the official source assessment. @@ -71,7 +71,7 @@ database_to_tam_obs(): catch, index, weights, maturity, and M assumption ↓ review source assumptions and specify tinyAM settings ↓ -check_obs() and prepare_tam() +check_tam_data() and prepare_tam() ↓ fit_tam() ↓ @@ -144,31 +144,25 @@ A useful directory structure is: ``` text analysis/comp_assessments/ -├── R/ -│ ├── read_database.R -│ ├── database_to_tam_obs.R -│ ├── database_to_tam_ref.R -│ ├── audit_assumptions.R -│ └── run_assessment.R +├── R/ # converters and workflow functions ├── scripts/ -│ ├── database/ -│ └── translation/ -│ ├── run_stock.R -│ ├── run_all.R -│ └── stocks/ -│ └── .R +│ ├── update_database_cache.R +│ ├── run_stock.R +│ ├── run_all.R +│ ├── observation_readiness.R +│ ├── stats_plots.R +│ ├── trend_plots.R +│ ├── curated/.R +│ └── preliminary/.R +├── saio_revisions.csv # selected source commit +├── cache/saio// # ignored CSV copies and parsed database.rds ├── tests/ -├── results/ -│ ├── observation_readiness.csv -│ ├── fit_diagnostics.csv -│ ├── comparison_summary.csv -│ ├── population_timeseries.csv -│ ├── figures/ -│ └── cache/ # gitignored local fits and dashboards -└── source_cache/ # gitignored authoritative source files +├── results// # ignored shared CSVs and figures +│ └── cache// # fits, checkpoints and dashboards +└── source_cache/ # optional ignored native-reference artifacts ``` -`run_stock.R` reads the working-tree database and sources the selected stock +`scripts/run_stock.R` reads the selected local SAIO snapshot and sources the selected stock script in a fresh environment. Prepared objects, fit and background are exposed in the workspace, together with an `assessment` context containing the canonical source and comparison options. Stock model calls remain visible in their scripts. @@ -202,13 +196,17 @@ can still be previewed when usable predictions exist, with a warning and the existing dashboard diagnostics. Missing uncertainty is not replaced. These are exploratory previews, not successful batch results. The batch convergence rules are unchanged. `run_assessment()` reruns the recipe rather than previewing an -edited fit, and retains its optional dashboard/cache controls. - -`run_all.R` reads committed local SAIO main once for the batch and -uses `future::multisession` through `furrr`; workers load tinyAM from the current -repository checkout. Workers return objects only. The parent process writes -aggregate CSV files after all workers finish, and restores the previous future -plan. Set `parallel = FALSE` when debugging. +edited fit, and retains its optional cache control. Rendering is separate. + +`scripts/run_all.R` reads the local snapshot once and configures +`future::plan(future::multisession, workers = 10)` visibly. The batch runner +honors that plan; choose `future::sequential` for troubleshooting. Workers load +the current tinyAM checkout and save per-stock checkpoints. The parent writes +aggregate CSVs after fitting. Rendering is separate: +`render_assessment_dashboards(runs)` records successful, troubleshooting, +skipped and failed dashboards without changing comparison eligibility. A +nonconverged dashboard is for troubleshooting, not a successful assessment. +See [README.md](README.md) for manual snapshot refresh, deadlines and evaluation. ## Translation units @@ -318,9 +316,10 @@ year, and age rows as `relative_sd` for an explicit `sd_supplied` setting. M is a population input, not an additional likelihood observation. The converter returns a `tam_data` list. Its optional `pop_covariates` table -contains one row per input year and age and supplies all variables referenced -by N/F/M formulas, including supplied M, process-SD groups and recruitment -covariates. It requires `year` and `age`, not `obs`. Missing values are allowed +contains one row per input year and age and supplies variables referenced +by recruitment, N and M formulas, including supplied M and their process-SD groups. +F mean/SD predictors belong in `catch`, and q/index-SD predictors belong in `index`. +The population table requires `year` and `age`, not `obs`. Missing values are allowed where unused; recruitment covariates are read at the youngest modeled age. Population formulas do not search observation or biological tables for columns. @@ -831,7 +830,7 @@ No missing `obs`. Then run: ``` r -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) ``` A passing result means the translated observation object satisfies current tinyAM structural requirements. @@ -1005,8 +1004,8 @@ or double-logistic selectivity automatically. `cor_rw` provides AR1 age correlation between annual F increments; its SDs are marginal increment SDs. Use it only when that covariance matches the source -assumption. N, F and M can have ordinary age-based `sd_form` terms, with sharing -covariates in `pop_covariates`. Designs must be constant across years at each +assumption. N, F and M can have ordinary age-based `sd_form` terms. F sharing covariates +belong in `catch`; N and M sharing covariates belong in `pop_covariates`. Designs must be constant across years at each active age; M sharing must also be constant within fitted M state blocks. Recruitment SD remains separate; no initial-abundance SD is estimated. Inspect group uncertainty and `check_tam()` advisories rather than equating convergence with support. @@ -1178,16 +1177,14 @@ and comparisons only with a complete final batch, not a subset of stocks. # 18. Keep generated outputs small -The committed results are the assessment-level observation/data-readiness -table (`observation_readiness.csv`), one -diagnostics table, one comparison-summary table, and the small sensitivity -summary retained from prior focused checks. Do not commit duplicate per-stock +Shared local results include the observation-readiness, diagnostics and +comparison-summary tables. These generated outputs remain ignored. Do not commit duplicate per-stock fits, translated observations, audits, settings, or dashboards; those can be recreated from the database and stock translation script. `run_assessment(..., cache = TRUE)` optionally saves a fitted object under -`results//cache///`. A dashboard is optional through -`dashboard = TRUE` and is cached there only when caching is enabled. Both +`results//cache///`. Render dashboards separately +with `render_assessment_dashboards(runs)`. Both `run_assessment()` and `run_assessments()` leave caching off by default. `run_assessments(..., save_results = TRUE)` writes the shared diagnostic and comparison-summary tables once in the parent process. @@ -1236,7 +1233,7 @@ assessment may support a clearly limited fit, while a complete source model may contain features that tinyAM cannot represent. The repository's `results//observation_readiness.csv` is an observation/data-readiness -screen. It checks source coverage, observation conversion, and `check_obs()`; +screen. It checks source coverage, observation conversion, and `check_tam_data()`; it does not load stock recipes or call `prepare_tam()`. The model-readiness checks below apply after the recipe and settings are available. @@ -1268,7 +1265,7 @@ below apply after the recipe and settings are available. ## Validation -- `tinyAM::check_obs(obs)` passes; +- `tinyAM::check_tam_data(obs)` passes; - `prepare_tam()` succeeds with the proposed years, ages, and settings; - all retained observations have compatible age groups and prediction definitions; - the stock background explains the official assumptions and chosen differences. @@ -1315,9 +1312,9 @@ Existing stock scripts retain their documented starting-value workflows. For a converged fit, `run_assessment()` returns the fitted object, source reference, detailed differences, and summary in memory. The fit is cached only -when `cache = TRUE`. A dashboard is rendered only when `dashboard = TRUE` and -is stored in the local cache only when caching is also enabled; otherwise it is -written to a temporary file. A successful run does not require a per-stock fit +when `cache = TRUE`. `render_assessment_dashboards(runs)` renders returned fits +separately and records render failures. `view_assessment(fit, assessment)` previews +one supplied fit, using a temporary HTML file unless an output path is given. A successful run does not require a per-stock fit or detailed-difference file on disk. The batch runner writes aggregate diagnostics and comparison summaries only when `save_results = TRUE`. Report investigated blockers, failed attempts, and non-converged fits as separate diff --git a/analysis/comp_assessments/migration/README.md b/analysis/comp_assessments/migration/README.md index 8fbb5af5..a68b90de 100644 --- a/analysis/comp_assessments/migration/README.md +++ b/analysis/comp_assessments/migration/README.md @@ -2,7 +2,7 @@ This history belongs to tinyAM. SAIO is an independent source database: its checkout, instructions, importers, tests and canonical records do not require tinyAM or a translation workflow. -The initial manifest is preserved byte for byte in [saio_initial_migration.json](saio_initial_migration.json). The former SAIO snapshot note is preserved in [SAIO_SNAPSHOTS.md](SAIO_SNAPSHOTS.md). They describe frozen source revisions, not current validation results. [saio_revisions.csv](../saio_revisions.csv) retains those historical references for explicit reproduction. Current curated and preliminary runs both read committed local SAIO main and record its exact revision; they do not default to either historical snapshot. +The initial manifest is preserved byte for byte in [saio_initial_migration.json](saio_initial_migration.json). The former SAIO snapshot note is preserved in [SAIO_SNAPSHOTS.md](SAIO_SNAPSHOTS.md). They describe frozen source revisions, not current validation results. Historical revisions remain recorded in these migration files and Git history. [saio_revisions.csv](../saio_revisions.csv) now selects one manually refreshed local CSV snapshot shared by both tiers; see the current [workflow](../README.md). ## Former SAIO migration note diff --git a/analysis/comp_assessments/migration/SAIO_SNAPSHOTS.md b/analysis/comp_assessments/migration/SAIO_SNAPSHOTS.md index 3ae8524e..fd07c93b 100644 --- a/analysis/comp_assessments/migration/SAIO_SNAPSHOTS.md +++ b/analysis/comp_assessments/migration/SAIO_SNAPSHOTS.md @@ -1,6 +1,6 @@ # Source snapshots -This is the historical migration record. Current tinyAM runs read committed local SAIO main by default; these frozen snapshots remain available only through an explicit revision request. +This is the historical migration record. Current tinyAM runs read the manually refreshed local CSV snapshot selected by saio_revisions.csv. The historical revisions below remain in Git and any existing local caches; they are not current results. The canonical working tables on main are the expanded source database extracted from tinyAM comp-assessments 34470212e1102f3f31bf3f08c26a8a72a985c948. diff --git a/analysis/comp_assessments/saio_revisions.csv b/analysis/comp_assessments/saio_revisions.csv index 08a5d6fd..910cdd85 100644 --- a/analysis/comp_assessments/saio_revisions.csv +++ b/analysis/comp_assessments/saio_revisions.csv @@ -1,3 +1,2 @@ -tier,revision,purpose -curated,849a4a559835dc6117575dbf5a5e32f77a39de02,historical_snapshot -preliminary,6f08c06c49e4b73591427a1495bfb4568caf49f0,historical_snapshot +"revision" +"c8b4a967b6654a7d8a63536825702c72afdc7384" diff --git a/analysis/comp_assessments/scripts/README.md b/analysis/comp_assessments/scripts/README.md index 3b6e2edf..878b564c 100644 --- a/analysis/comp_assessments/scripts/README.md +++ b/analysis/comp_assessments/scripts/README.md @@ -1,41 +1,19 @@ # Assessment scripts -Run these scripts from the repository root in RStudio. +Run these scripts from the tinyAM repository root in RStudio. -## Source database +1. `update_database_cache.R`: manually copy the five clean, committed SAIO CSVs into `cache/saio//`. Set `saio_repo` first. The CSVs are parsed once into `database.rds`; the tracked manifest is updated only after both steps finish; SAIO is never changed or fetched. +2. `run_stock.R`: choose a stock and tier, fit its literal recipe, then preview the supplied fit independently. +3. `run_all.R`: read the snapshot once, configure `future::plan(future::multisession, workers = 10)`, fit/checkpoint the batch, then render dashboards and overview figures in separate sections. +4. `observation_readiness.R`: audit the same supplied `database`; when run alone, read the selected local snapshot. +5. `stats_plots.R` and `trend_plots.R`: rebuild overview figures from results matching the selected source revision. -Source importers, extraction helpers and validators are maintained in [SAIO](https://github.com/PaulRegular/saio/tree/main/scripts/database). Run canonical validation from the SAIO repository root. Routine translations read committed local SAIO main, record its exact revision, and do not rerun source imports. Historical revisions require an explicit request. +`run_assessment(..., fit = FALSE)` prepares inputs without final or preliminary fits. The batch functions honor your existing future plan; choose `future::sequential` for troubleshooting. `run_all.R` selects a 20-minute per-assessment deadline; use `timeout = Inf` for unrestricted fitting. A finite deadline requires `callr` and records a timeout without retuning the model. -## Translation and fitting +With `cache = TRUE`, each completed attempt is saved immediately under `results//cache///`, along with the fit when available and stage logs. Interrupted serialization preserves the previous complete checkpoint. `cache` does not reuse or skip fits. Only an intentional full batch should set `save_results = TRUE` to refresh aggregate CSVs. -Open `translation/run_stock.R`, choose `assessment_id`, and source it. Each -stock script prepares observations and shows its literal `fit_tam()` call. -The workspace retains `obs`, years, ages, `fit`, background and `assessment`. -Rerun the Preview line after editing a fit; previewing never refits it. +Run `render_assessment_dashboards(runs)` after fitting. It records rendered, troubleshooting, skipped and failed outcomes in `dashboard_manifest.csv` and rebuilds the tier's index. It never fits or changes numerical eligibility. Troubleshooting dashboards may lack reliable estimates or uncertainty; inspect `check_tam()` and the diagnostic table. -`run_assessment(..., fit = FALSE)` prepares observations without final or -preliminary fits. Model settings are stored in a fitted object's `dat`. +For retrospectives or hindcasts, configure the same future plan and call `fit_retro(fit, folds = 5)` or `fit_hindcast(fit, folds = 5)`, then `vis_tam(result)`. Close workers with `future::plan(future::sequential)` when finished. See the [workflow](../README.md) for catch conditioning and score interpretation. -`translation/run_all.R` reads the committed database, fits with four workers, -and writes aggregate results only in the parent process. It caches returned -fits before optional dashboards, then runs the two overview-figure scripts. -The controls at the top select parallel execution, worker count, dashboards -(off by default), and a 20-minute per-assessment deadline. A finite deadline -requires `callr` and runs each assessment in a supervised R subprocess, including -when `parallel = FALSE`. A timed-out process is stopped and the batch continues -with an explicit `timed_out` diagnostic; settings and starting-value rules are -unchanged. Set `timeout <- Inf` for unbounded fitting. - -Stock starts and completions are printed as they happen. With `cache = TRUE`, -each completed stock is saved immediately as `results//cache//result.rds`, -alongside its fit (if available), `run.log` with stage timestamps, and -`run.log.output` with subprocess output. These checkpoints do not wait for the -whole batch. Existing old fit files are retained; `result.rds` records the current -run's outcome and database revision. `cache` saves results; it does not skip fits. -Checkpoint replacement happens only after serialization completes, so an -interrupted save does not overwrite a previous complete checkpoint. -Reduce worker count when memory is limited; use serial execution for debugging. - -Summary CSVs, overview figures, fits, dashboards and detailed trial outputs -remain local and ignored under `results//`. Authoritative source files -remain in SAIO's ignored cache. The complete batch alone refreshes aggregate results. +All generated snapshots, fits, dashboards and figures stay local and ignored. Canonical source curation, extraction and validation are maintained in [SAIO](https://github.com/PaulRegular/saio). diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_alaska_plaice_bsai_2024.R b/analysis/comp_assessments/scripts/curated/afsc_alaska_plaice_bsai_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_alaska_plaice_bsai_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_alaska_plaice_bsai_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_arrowtooth_flounder_bsai_2022.R b/analysis/comp_assessments/scripts/curated/afsc_arrowtooth_flounder_bsai_2022.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_arrowtooth_flounder_bsai_2022.R rename to analysis/comp_assessments/scripts/curated/afsc_arrowtooth_flounder_bsai_2022.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_atka_mackerel_bsai_2024.R b/analysis/comp_assessments/scripts/curated/afsc_atka_mackerel_bsai_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_atka_mackerel_bsai_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_atka_mackerel_bsai_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_cod_ai_2024.R b/analysis/comp_assessments/scripts/curated/afsc_cod_ai_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_cod_ai_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_cod_ai_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_cod_ebs_2024.R b/analysis/comp_assessments/scripts/curated/afsc_cod_ebs_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_cod_ebs_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_cod_ebs_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_cod_goa_2026.R b/analysis/comp_assessments/scripts/curated/afsc_cod_goa_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_cod_goa_2026.R rename to analysis/comp_assessments/scripts/curated/afsc_cod_goa_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_northern_rock_sole_ebs_2024.R b/analysis/comp_assessments/scripts/curated/afsc_northern_rock_sole_ebs_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_northern_rock_sole_ebs_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_northern_rock_sole_ebs_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_pollock_ai_2024.R b/analysis/comp_assessments/scripts/curated/afsc_pollock_ai_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_pollock_ai_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_pollock_ai_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_pollock_ebs_2024.R b/analysis/comp_assessments/scripts/curated/afsc_pollock_ebs_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_pollock_ebs_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_pollock_ebs_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_pollock_goa_2024.R b/analysis/comp_assessments/scripts/curated/afsc_pollock_goa_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_pollock_goa_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_pollock_goa_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_pop_bsai_2024.R b/analysis/comp_assessments/scripts/curated/afsc_pop_bsai_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_pop_bsai_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_pop_bsai_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/afsc_yellowfin_sole_ebs_2024.R b/analysis/comp_assessments/scripts/curated/afsc_yellowfin_sole_ebs_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/afsc_yellowfin_sole_ebs_2024.R rename to analysis/comp_assessments/scripts/curated/afsc_yellowfin_sole_ebs_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/dfo_canary_bc_2022.R b/analysis/comp_assessments/scripts/curated/dfo_canary_bc_2022.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/dfo_canary_bc_2022.R rename to analysis/comp_assessments/scripts/curated/dfo_canary_bc_2022.R diff --git a/analysis/comp_assessments/scripts/translation/curated/dfo_cod_2j3kl_2025.R b/analysis/comp_assessments/scripts/curated/dfo_cod_2j3kl_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/dfo_cod_2j3kl_2025.R rename to analysis/comp_assessments/scripts/curated/dfo_cod_2j3kl_2025.R diff --git a/analysis/comp_assessments/scripts/translation/curated/dfo_cod_4t4vn_2019.R b/analysis/comp_assessments/scripts/curated/dfo_cod_4t4vn_2019.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/dfo_cod_4t4vn_2019.R rename to analysis/comp_assessments/scripts/curated/dfo_cod_4t4vn_2019.R diff --git a/analysis/comp_assessments/scripts/translation/curated/dfo_herring_4tvn_spring_2024.R b/analysis/comp_assessments/scripts/curated/dfo_herring_4tvn_spring_2024.R similarity index 99% rename from analysis/comp_assessments/scripts/translation/curated/dfo_herring_4tvn_spring_2024.R rename to analysis/comp_assessments/scripts/curated/dfo_herring_4tvn_spring_2024.R index 1e23c5a0..5b093566 100644 --- a/analysis/comp_assessments/scripts/translation/curated/dfo_herring_4tvn_spring_2024.R +++ b/analysis/comp_assessments/scripts/curated/dfo_herring_4tvn_spring_2024.R @@ -139,9 +139,9 @@ obs$pop_covariates$age_blocks <- cut_ages( c(2, 4, 6, 8, 11) ) -obs$pop_covariates$fishery_period <- cut_years( - obs$pop_covariates$year, - c(1978, 1990, 2005, max(obs$pop_covariates$year)) +obs$catch$fishery_period <- cut_years( + obs$catch$year, + c(1978, 1990, 2005, max(obs$catch$year)) ) # Restrict the catchability random walk to CPUE. diff --git a/analysis/comp_assessments/scripts/translation/curated/dfo_herring_sog_2025.R b/analysis/comp_assessments/scripts/curated/dfo_herring_sog_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/dfo_herring_sog_2025.R rename to analysis/comp_assessments/scripts/curated/dfo_herring_sog_2025.R diff --git a/analysis/comp_assessments/scripts/translation/curated/dfo_petrale_bc_2024.R b/analysis/comp_assessments/scripts/curated/dfo_petrale_bc_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/dfo_petrale_bc_2024.R rename to analysis/comp_assessments/scripts/curated/dfo_petrale_bc_2024.R diff --git a/analysis/comp_assessments/scripts/translation/curated/dfo_pop_bc_2023.R b/analysis/comp_assessments/scripts/curated/dfo_pop_bc_2023.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/dfo_pop_bc_2023.R rename to analysis/comp_assessments/scripts/curated/dfo_pop_bc_2023.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_bluewhiting_northeast_atlantic_2026.R b/analysis/comp_assessments/scripts/curated/ices_bluewhiting_northeast_atlantic_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_bluewhiting_northeast_atlantic_2026.R rename to analysis/comp_assessments/scripts/curated/ices_bluewhiting_northeast_atlantic_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_cod_north_sea_2025.R b/analysis/comp_assessments/scripts/curated/ices_cod_north_sea_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_cod_north_sea_2025.R rename to analysis/comp_assessments/scripts/curated/ices_cod_north_sea_2025.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_cod_northeast_arctic_2026.R b/analysis/comp_assessments/scripts/curated/ices_cod_northeast_arctic_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_cod_northeast_arctic_2026.R rename to analysis/comp_assessments/scripts/curated/ices_cod_northeast_arctic_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_haddock_iceland_2025.R b/analysis/comp_assessments/scripts/curated/ices_haddock_iceland_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_haddock_iceland_2025.R rename to analysis/comp_assessments/scripts/curated/ices_haddock_iceland_2025.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_haddock_north_sea_2026.R b/analysis/comp_assessments/scripts/curated/ices_haddock_north_sea_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_haddock_north_sea_2026.R rename to analysis/comp_assessments/scripts/curated/ices_haddock_north_sea_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_herring_north_sea_2026.R b/analysis/comp_assessments/scripts/curated/ices_herring_north_sea_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_herring_north_sea_2026.R rename to analysis/comp_assessments/scripts/curated/ices_herring_north_sea_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_herring_norwegian_spring_2025.R b/analysis/comp_assessments/scripts/curated/ices_herring_norwegian_spring_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_herring_norwegian_spring_2025.R rename to analysis/comp_assessments/scripts/curated/ices_herring_norwegian_spring_2025.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_herring_western_baltic_2026.R b/analysis/comp_assessments/scripts/curated/ices_herring_western_baltic_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_herring_western_baltic_2026.R rename to analysis/comp_assessments/scripts/curated/ices_herring_western_baltic_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_norway_pout_north_sea_2026_benchmark.R b/analysis/comp_assessments/scripts/curated/ices_norway_pout_north_sea_2026_benchmark.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_norway_pout_north_sea_2026_benchmark.R rename to analysis/comp_assessments/scripts/curated/ices_norway_pout_north_sea_2026_benchmark.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_plaice_north_sea_2026.R b/analysis/comp_assessments/scripts/curated/ices_plaice_north_sea_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_plaice_north_sea_2026.R rename to analysis/comp_assessments/scripts/curated/ices_plaice_north_sea_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_saithe_north_sea_2026.R b/analysis/comp_assessments/scripts/curated/ices_saithe_north_sea_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_saithe_north_sea_2026.R rename to analysis/comp_assessments/scripts/curated/ices_saithe_north_sea_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_sprat_baltic_2026.R b/analysis/comp_assessments/scripts/curated/ices_sprat_baltic_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_sprat_baltic_2026.R rename to analysis/comp_assessments/scripts/curated/ices_sprat_baltic_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/ices_whiting_north_sea_2026.R b/analysis/comp_assessments/scripts/curated/ices_whiting_north_sea_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/ices_whiting_north_sea_2026.R rename to analysis/comp_assessments/scripts/curated/ices_whiting_north_sea_2026.R diff --git a/analysis/comp_assessments/scripts/translation/curated/joint_hake_coastal_2025.R b/analysis/comp_assessments/scripts/curated/joint_hake_coastal_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/joint_hake_coastal_2025.R rename to analysis/comp_assessments/scripts/curated/joint_hake_coastal_2025.R diff --git a/analysis/comp_assessments/scripts/translation/curated/nefsc_atlantic_mackerel_2018.R b/analysis/comp_assessments/scripts/curated/nefsc_atlantic_mackerel_2018.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/nefsc_atlantic_mackerel_2018.R rename to analysis/comp_assessments/scripts/curated/nefsc_atlantic_mackerel_2018.R diff --git a/analysis/comp_assessments/scripts/translation/curated/nefsc_summer_flounder_2018.R b/analysis/comp_assessments/scripts/curated/nefsc_summer_flounder_2018.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/curated/nefsc_summer_flounder_2018.R rename to analysis/comp_assessments/scripts/curated/nefsc_summer_flounder_2018.R diff --git a/analysis/comp_assessments/scripts/translation/observation_readiness.R b/analysis/comp_assessments/scripts/observation_readiness.R similarity index 96% rename from analysis/comp_assessments/scripts/translation/observation_readiness.R rename to analysis/comp_assessments/scripts/observation_readiness.R index 8261a6bc..32eaad7c 100644 --- a/analysis/comp_assessments/scripts/translation/observation_readiness.R +++ b/analysis/comp_assessments/scripts/observation_readiness.R @@ -2,7 +2,7 @@ pkgload::load_all(".", quiet = TRUE) root <- file.path("analysis", "comp_assessments") source(file.path(root, "R", "run_assessment.R")) if (!exists("translation_tier", inherits = FALSE)) translation_tier <- "curated" -database <- read_database(tier = translation_tier) +if (!exists("database", inherits = FALSE)) database <- read_database() read_table <- function(name) { database[[sub("[.]csv$", "", name)]] } @@ -188,7 +188,7 @@ readiness <- lapply(seq_len(nrow(assessments)), function(i) { nrow(model_weight) > 0L, nrow(maturity) + nrow(maturity_static) > 0L )) conversion_ok <- FALSE - check_obs_ok <- FALSE + check_tam_data_ok <- FALSE conversion_error <- "Required catch, index, weight, and maturity rows are not all present." stock_script <- .assessment_script(id, translation_tier) if (has_expected_obs || file.exists(stock_script)) { @@ -210,8 +210,8 @@ readiness <- lapply(seq_len(nrow(assessments)), function(i) { if (conversion_ok) { conversion_error <- "" if (requireNamespace("tinyAM", quietly = TRUE)) { - check_result <- tryCatch(tinyAM::check_obs(conversion), error = identity) - check_obs_ok <- !inherits(check_result, "error") + check_result <- tryCatch(tinyAM::check_tam_data(conversion), error = identity) + check_tam_data_ok <- !inherits(check_result, "error") } } else { conversion_error <- conditionMessage(conversion) @@ -235,8 +235,8 @@ readiness <- lapply(seq_len(nrow(assessments)), function(i) { if (!maturity_grid) "complete calendar-year maturity-at-age matrix for all modeled years and ages", if (!m_represented) "a documented M treatment: supplied numerical values or a source-estimated M structure", if (!conversion_ok) paste("database_to_tam_obs failed:", conversion_error), - if (conversion_ok && !requireNamespace("tinyAM", quietly = TRUE)) "tinyAM is not installed; check_obs was not run", - if (conversion_ok && requireNamespace("tinyAM", quietly = TRUE) && !check_obs_ok) "tinyAM::check_obs failed" + if (conversion_ok && !requireNamespace("tinyAM", quietly = TRUE)) "tinyAM is not installed; check_tam_data was not run", + if (conversion_ok && requireNamespace("tinyAM", quietly = TRUE) && !check_tam_data_ok) "tinyAM::check_tam_data failed" ) type_counts <- table(x$type) count <- function(type) if (type %in% names(type_counts)) as.integer(type_counts[[type]]) else 0L @@ -281,7 +281,7 @@ readiness <- lapply(seq_len(nrow(assessments)), function(i) { M_numerical_values_available = m_grid || m_static, M_estimated_in_source = m_estimated, database_to_tam_obs_succeeds = conversion_ok, - tinyAM_check_obs_passes = check_obs_ok, + tinyAM_check_tam_data_passes = check_tam_data_ok, N_at_age_output = any(y$measure == "numbers_at_age" & !is.na(y$age)), F_at_age_output = any(y$measure == "fishing_mortality_at_age" & !is.na(y$age)), SSB_output = any(y$measure == "SSB"), @@ -299,7 +299,7 @@ print( "minimum_age", "maximum_age", "catch_rows", "catch_at_age_rows", "index_rows", "weight_rows", "catch_weight_rows", "maturity_rows", "M_rows", - "database_to_tam_obs_succeeds", "tinyAM_check_obs_passes", "missing_items" + "database_to_tam_obs_succeeds", "tinyAM_check_tam_data_passes", "missing_items" )], row.names = FALSE ) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/afsc_pollock_goa_2024.R b/analysis/comp_assessments/scripts/preliminary/afsc_pollock_goa_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/afsc_pollock_goa_2024.R rename to analysis/comp_assessments/scripts/preliminary/afsc_pollock_goa_2024.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/asmfc_striped_bass_atlantic_2018.R b/analysis/comp_assessments/scripts/preliminary/asmfc_striped_bass_atlantic_2018.R similarity index 99% rename from analysis/comp_assessments/scripts/translation/preliminary/asmfc_striped_bass_atlantic_2018.R rename to analysis/comp_assessments/scripts/preliminary/asmfc_striped_bass_atlantic_2018.R index 27a26065..aa83befa 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/asmfc_striped_bass_atlantic_2018.R +++ b/analysis/comp_assessments/scripts/preliminary/asmfc_striped_bass_atlantic_2018.R @@ -95,7 +95,7 @@ obs <- database_to_tam_obs( surveys = surveys, assumptions = source$assumptions ) obs$maturity$spawn_time <- 0 -obs$pop_covariates$age_factor <- factor(obs$pop_covariates$age, levels = ages) +obs$catch$age_factor <- factor(obs$catch$age, levels = ages) obs$index$q_key <- interaction(obs$index$survey, factor(obs$index$age, levels = ages), drop = TRUE, lex.order = TRUE) zero_index_rows <- sum(obs$index$obs <= 0, na.rm = TRUE) obs$index <- droplevels(obs$index[is.finite(obs$index$obs) & obs$index$obs > 0, , drop = FALSE]) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_american_plaice_4t_2016.R b/analysis/comp_assessments/scripts/preliminary/dfo_american_plaice_4t_2016.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_american_plaice_4t_2016.R rename to analysis/comp_assessments/scripts/preliminary/dfo_american_plaice_4t_2016.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_cod_2j3kl_2025.R b/analysis/comp_assessments/scripts/preliminary/dfo_cod_2j3kl_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_cod_2j3kl_2025.R rename to analysis/comp_assessments/scripts/preliminary/dfo_cod_2j3kl_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_cod_3pn4rs_2025.R b/analysis/comp_assessments/scripts/preliminary/dfo_cod_3pn4rs_2025.R similarity index 97% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_cod_3pn4rs_2025.R rename to analysis/comp_assessments/scripts/preliminary/dfo_cod_3pn4rs_2025.R index 68ce75f5..31479ce4 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/dfo_cod_3pn4rs_2025.R +++ b/analysis/comp_assessments/scripts/preliminary/dfo_cod_3pn4rs_2025.R @@ -12,14 +12,14 @@ obs <- database_to_tam_obs( assumptions = source$assumptions ) -obs$pop_covariates$F_age_block <- cut( - obs$pop_covariates$age, +obs$catch$F_age_block <- cut( + obs$catch$age, breaks = c(1, 3, 5, 7, 9, 11), labels = c("2-3", "4-5", "6-7", "8-9", "10-11"), include.lowest = TRUE ) -obs$pop_covariates$F_period <- cut( - obs$pop_covariates$year, +obs$catch$F_period <- cut( + obs$catch$year, breaks = c(1994, 1999, 2005, 2013, 2021, 2024), labels = c("1995-1999", "2000-2005", "2006-2013", "2014-2021", "2022-2024") ) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_cod_3ps_2024.R b/analysis/comp_assessments/scripts/preliminary/dfo_cod_3ps_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_cod_3ps_2024.R rename to analysis/comp_assessments/scripts/preliminary/dfo_cod_3ps_2024.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_greenland_halibut_2_3klmno_2026_mp.R b/analysis/comp_assessments/scripts/preliminary/dfo_greenland_halibut_2_3klmno_2026_mp.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_greenland_halibut_2_3klmno_2026_mp.R rename to analysis/comp_assessments/scripts/preliminary/dfo_greenland_halibut_2_3klmno_2026_mp.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_haddock_4x5y_2016.R b/analysis/comp_assessments/scripts/preliminary/dfo_haddock_4x5y_2016.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_haddock_4x5y_2016.R rename to analysis/comp_assessments/scripts/preliminary/dfo_haddock_4x5y_2016.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_herring_4tvn_fall_2024.R b/analysis/comp_assessments/scripts/preliminary/dfo_herring_4tvn_fall_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_herring_4tvn_fall_2024.R rename to analysis/comp_assessments/scripts/preliminary/dfo_herring_4tvn_fall_2024.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_northern_mackerel_2025.R b/analysis/comp_assessments/scripts/preliminary/dfo_northern_mackerel_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_northern_mackerel_2025.R rename to analysis/comp_assessments/scripts/preliminary/dfo_northern_mackerel_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_sgsl_winter_flounder_2017.R b/analysis/comp_assessments/scripts/preliminary/dfo_sgsl_winter_flounder_2017.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_sgsl_winter_flounder_2017.R rename to analysis/comp_assessments/scripts/preliminary/dfo_sgsl_winter_flounder_2017.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_western_component_pollock_2025_hcr_update.R b/analysis/comp_assessments/scripts/preliminary/dfo_western_component_pollock_2025_hcr_update.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_western_component_pollock_2025_hcr_update.R rename to analysis/comp_assessments/scripts/preliminary/dfo_western_component_pollock_2025_hcr_update.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_yellowmouth_2021.R b/analysis/comp_assessments/scripts/preliminary/dfo_yellowmouth_2021.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_yellowmouth_2021.R rename to analysis/comp_assessments/scripts/preliminary/dfo_yellowmouth_2021.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/dfo_yellowtail_flounder_4t_2025.R b/analysis/comp_assessments/scripts/preliminary/dfo_yellowtail_flounder_4t_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/dfo_yellowtail_flounder_4t_2025.R rename to analysis/comp_assessments/scripts/preliminary/dfo_yellowtail_flounder_4t_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_anchovy_gulf_cadiz_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_anchovy_gulf_cadiz_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_anchovy_gulf_cadiz_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_anchovy_gulf_cadiz_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_atlantic_wolffish_iceland_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_atlantic_wolffish_iceland_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_atlantic_wolffish_iceland_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_atlantic_wolffish_iceland_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_bluewhiting_northeast_atlantic_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_bluewhiting_northeast_atlantic_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_bluewhiting_northeast_atlantic_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_bluewhiting_northeast_atlantic_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_celtic_sea_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_celtic_sea_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_celtic_sea_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_celtic_sea_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_faroe_plateau_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_faroe_plateau_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_faroe_plateau_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_faroe_plateau_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_iceland_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_iceland_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_iceland_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_iceland_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_irish_sea_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_irish_sea_2026.R similarity index 97% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_irish_sea_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_irish_sea_2026.R index eed4d021..5a76048b 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_irish_sea_2026.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_cod_irish_sea_2026.R @@ -31,8 +31,8 @@ obs <- database_to_tam_obs( ) obs$maturity$spawn_time <- 0 -obs$pop_covariates$f_age_group <- factor( - ifelse(obs$pop_covariates$age >= 3, "age3_plus", paste0("age", obs$pop_covariates$age)), +obs$catch$f_age_group <- factor( + ifelse(obs$catch$age >= 3, "age3_plus", paste0("age", obs$catch$age)), levels = c("age0", "age1", "age2", "age3_plus") ) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_north_sea_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_north_sea_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_north_sea_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_north_sea_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_northern_coastal_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_northern_coastal_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_northern_coastal_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_northern_coastal_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_west_greenland_inshore_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_west_greenland_inshore_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_west_greenland_inshore_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_west_greenland_inshore_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_west_greenland_offshore_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_west_greenland_offshore_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_west_greenland_offshore_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_west_greenland_offshore_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_west_scotland_2022.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_west_scotland_2022.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_west_scotland_2022.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_west_scotland_2022.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_western_baltic_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_western_baltic_2025.R similarity index 96% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_western_baltic_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_western_baltic_2025.R index 86fbed17..725ef6a7 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_western_baltic_2025.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_cod_western_baltic_2025.R @@ -15,11 +15,11 @@ obs <- database_to_tam_obs( ) obs$maturity$spawn_time <- 0 -obs$pop_covariates$f_age_group <- factor(ifelse( - obs$pop_covariates$age == 0, "age0", - ifelse(obs$pop_covariates$age == 1, "age1", - ifelse(obs$pop_covariates$age == 2, "age2", - ifelse(obs$pop_covariates$age <= 4, "age3_4", "age5plus") +obs$catch$f_age_group <- factor(ifelse( + obs$catch$age == 0, "age0", + ifelse(obs$catch$age == 1, "age1", + ifelse(obs$catch$age == 2, "age2", + ifelse(obs$catch$age <= 4, "age3_4", "age5plus") ) ) ), levels = c("age0", "age1", "age2", "age3_4", "age5plus")) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_western_baltic_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_cod_western_baltic_2026.R similarity index 96% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_cod_western_baltic_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_cod_western_baltic_2026.R index 956118be..03cc6723 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_cod_western_baltic_2026.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_cod_western_baltic_2026.R @@ -28,10 +28,10 @@ obs$index$sd_block <- interaction( drop = TRUE, lex.order = TRUE ) obs$catch$sd_block <- factor(ifelse(obs$catch$age == 1, "age1", "age2plus")) -obs$pop_covariates$f_age_group <- factor( - ifelse(obs$pop_covariates$age == 1, "age1", - ifelse(obs$pop_covariates$age == 2, "age2", - ifelse(obs$pop_covariates$age <= 4, "age3_4", "age5plus"))), +obs$catch$f_age_group <- factor( + ifelse(obs$catch$age == 1, "age1", + ifelse(obs$catch$age == 2, "age2", + ifelse(obs$catch$age <= 4, "age3_4", "age5plus"))), levels = c("age1", "age2", "age3_4", "age5plus") ) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_celtic_sea_7b_k_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_haddock_celtic_sea_7b_k_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_celtic_sea_7b_k_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_haddock_celtic_sea_7b_k_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_faroe_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_haddock_faroe_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_faroe_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_haddock_faroe_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_iceland_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_haddock_iceland_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_iceland_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_haddock_iceland_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_irish_sea_7a_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_haddock_irish_sea_7a_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_irish_sea_7a_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_haddock_irish_sea_7a_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_rockall_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_haddock_rockall_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_haddock_rockall_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_haddock_rockall_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_her_27_irls_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_her_27_irls_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_her_27_irls_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_her_27_irls_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_her_27_nirs_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_her_27_nirs_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_her_27_nirs_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_her_27_nirs_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_herring_central_baltic_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_herring_central_baltic_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_herring_central_baltic_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_herring_central_baltic_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_herring_gulf_bothnia_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_herring_gulf_bothnia_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_herring_gulf_bothnia_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_herring_gulf_bothnia_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_herring_gulf_riga_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_herring_gulf_riga_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_herring_gulf_riga_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_herring_gulf_riga_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_herring_iceland_summer_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_herring_iceland_summer_2026.R similarity index 98% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_herring_iceland_summer_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_herring_iceland_summer_2026.R index 3006b2f3..06ce2b0e 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_herring_iceland_summer_2026.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_herring_iceland_summer_2026.R @@ -20,9 +20,9 @@ obs <- database_to_tam_obs( assumptions = source$assumptions ) -obs$pop_covariates$F_age_block <- factor(ifelse( - obs$pop_covariates$age <= 6, - paste0("age", obs$pop_covariates$age), +obs$catch$F_age_block <- factor(ifelse( + obs$catch$age <= 6, + paste0("age", obs$catch$age), "age7plus" ), levels = c(paste0("age", 2:6), "age7plus")) obs$index$q_age <- factor(ifelse( diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_herring_norwegian_spring_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_herring_norwegian_spring_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_herring_norwegian_spring_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_herring_norwegian_spring_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_herring_west_scotland_ireland_2020.R b/analysis/comp_assessments/scripts/preliminary/ices_herring_west_scotland_ireland_2020.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_herring_west_scotland_ireland_2020.R rename to analysis/comp_assessments/scripts/preliminary/ices_herring_west_scotland_ireland_2020.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_horse_mackerel_9a_2024.R b/analysis/comp_assessments/scripts/preliminary/ices_horse_mackerel_9a_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_horse_mackerel_9a_2024.R rename to analysis/comp_assessments/scripts/preliminary/ices_horse_mackerel_9a_2024.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_ling_faroe_5b_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_ling_faroe_5b_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_ling_faroe_5b_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_ling_faroe_5b_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_norway_pout_north_sea_2026_benchmark.R b/analysis/comp_assessments/scripts/preliminary/ices_norway_pout_north_sea_2026_benchmark.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_norway_pout_north_sea_2026_benchmark.R rename to analysis/comp_assessments/scripts/preliminary/ices_norway_pout_north_sea_2026_benchmark.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_plaice_baltic_21_32_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_plaice_baltic_21_32_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_plaice_baltic_21_32_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_plaice_baltic_21_32_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_plaice_english_channel_7d_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_plaice_english_channel_7d_2026.R similarity index 98% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_plaice_english_channel_7d_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_plaice_english_channel_7d_2026.R index 225f7b26..2e3e7393 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_plaice_english_channel_7d_2026.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_plaice_english_channel_7d_2026.R @@ -91,7 +91,7 @@ if (do_fit) { } retry_start <- function() { source_fit_file <- file.path( - file.path(saio_path(), "source_cache", "ices_plaice_7d_2026"), + file.path("analysis", "comp_assessments", "source_cache", "ices_plaice_7d_2026"), "fit_local_locked.RData" ) if (!file.exists(source_fit_file)) { diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_plaice_irish_sea_7a_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_plaice_irish_sea_7a_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_plaice_irish_sea_7a_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_plaice_irish_sea_7a_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_saithe_faroe_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_saithe_faroe_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_saithe_faroe_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_saithe_faroe_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_saithe_iceland_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_saithe_iceland_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_saithe_iceland_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_saithe_iceland_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_saithe_northeast_arctic_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_saithe_northeast_arctic_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_saithe_northeast_arctic_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_saithe_northeast_arctic_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_1r_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_1r_2026.R similarity index 96% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_1r_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_1r_2026.R index 40b7fb99..00309973 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_1r_2026.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_1r_2026.R @@ -38,11 +38,11 @@ obs$maturity$spawn_time <- 0 effort <- inputs[inputs$type == "covariate" & inputs$measure == "effort" & inputs$season == "annual", ] stopifnot(!anyDuplicated(effort$year), setequal(effort$year, years), all(effort$value > 0)) -pop <- obs$pop_covariates -pop$log_effort <- log(effort$value[match(pop$year, effort$year)]) - mean(log(effort$value)) -period <- cut(pop$year, c(1982, 1998, 2021, 2025), labels = c("early", "middle", "late")) -pop$F_mean_group <- interaction(period, pmin(pop$age, 3), drop = TRUE) -obs$pop_covariates <- pop +fishing <- obs$catch +fishing$log_effort <- log(effort$value[match(fishing$year, effort$year)]) - mean(log(effort$value)) +period <- cut(fishing$year, c(1982, 1998, 2021, 2025), labels = c("early", "middle", "late")) +fishing$F_mean_group <- interaction(period, pmin(fishing$age, 3), drop = TRUE) +obs$catch <- fishing obs$catch$catch_sd_group <- factor(ifelse(obs$catch$age <= 2, "young", "old")) obs$index$index_sd_group <- factor(ifelse(obs$index$survey == "Dredge", "Dredge_1", ifelse(obs$index$age == 1, "RTM_1", "RTM_2_3"))) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_2r_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_2r_2026.R similarity index 97% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_2r_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_2r_2026.R index 4a237807..05fe8e23 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_2r_2026.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_2r_2026.R @@ -37,12 +37,12 @@ obs$maturity$spawn_time <- 0 effort <- inputs[inputs$type == "covariate" & inputs$measure == "effort" & inputs$season == "annual", ] stopifnot(!anyDuplicated(effort$year), setequal(effort$year, years), all(effort$value > 0)) -pop <- obs$pop_covariates -pop$log_effort <- log(effort$value[match(pop$year, effort$year)]) - mean(log(effort$value)) -period <- cut(pop$year, c(1982, 1998, 2004, 2009, 2025), +fishing <- obs$catch +fishing$log_effort <- log(effort$value[match(fishing$year, effort$year)]) - mean(log(effort$value)) +period <- cut(fishing$year, c(1982, 1998, 2004, 2009, 2025), labels = c("early", "middle1", "middle2", "recent")) -pop$F_mean_group <- interaction(period, pmin(pop$age, 3), drop = TRUE) -obs$pop_covariates <- pop +fishing$F_mean_group <- interaction(period, pmin(fishing$age, 3), drop = TRUE) +obs$catch <- fishing obs$catch$catch_sd_group <- factor(ifelse(obs$catch$age <= 2, "young", "old")) cw <- inputs[inputs$type == "catch_weight" & inputs$age %in% ages, ] diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_3r_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_3r_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_3r_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_3r_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_4_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_4_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sandeel_area_4_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_sandeel_area_4_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_seabass_8ab_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_seabass_8ab_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_seabass_8ab_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_seabass_8ab_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sole_20_24_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_sole_20_24_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sole_20_24_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_sole_20_24_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sole_celtic_7fg_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_sole_celtic_7fg_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sole_celtic_7fg_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_sole_celtic_7fg_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sole_eastern_channel_7d_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_sole_eastern_channel_7d_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sole_eastern_channel_7d_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_sole_eastern_channel_7d_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sole_north_sea_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_sole_north_sea_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sole_north_sea_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_sole_north_sea_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_sole_western_channel_7e_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_sole_western_channel_7e_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_sole_western_channel_7e_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_sole_western_channel_7e_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_turbot_north_sea_2025_benchmark.R b/analysis/comp_assessments/scripts/preliminary/ices_turbot_north_sea_2025_benchmark.R similarity index 97% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_turbot_north_sea_2025_benchmark.R rename to analysis/comp_assessments/scripts/preliminary/ices_turbot_north_sea_2025_benchmark.R index 5cf70446..6003b36e 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/ices_turbot_north_sea_2025_benchmark.R +++ b/analysis/comp_assessments/scripts/preliminary/ices_turbot_north_sea_2025_benchmark.R @@ -70,10 +70,10 @@ obs$index$sd_group <- ifelse( ifelse(obs$index$age == 1, "BSAS_age1", "BSAS_ages2_8") ) obs$index$sd_group <- factor(obs$index$sd_group) -obs$pop_covariates$F_sd_group <- factor( - ifelse(obs$pop_covariates$age == 1, "age1", - ifelse(obs$pop_covariates$age == 2, "age2", - ifelse(obs$pop_covariates$age <= 4, "ages3_4", "ages5_8") +obs$catch$F_sd_group <- factor( + ifelse(obs$catch$age == 1, "age1", + ifelse(obs$catch$age == 2, "age2", + ifelse(obs$catch$age <= 4, "ages3_4", "ages5_8") ) ), levels = c("age1", "age2", "ages3_4", "ages5_8") diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_whg_27_7b_ce_k_2026.R b/analysis/comp_assessments/scripts/preliminary/ices_whg_27_7b_ce_k_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_whg_27_7b_ce_k_2026.R rename to analysis/comp_assessments/scripts/preliminary/ices_whg_27_7b_ce_k_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_whiting_irish_sea_2025_benchmark.R b/analysis/comp_assessments/scripts/preliminary/ices_whiting_irish_sea_2025_benchmark.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_whiting_irish_sea_2025_benchmark.R rename to analysis/comp_assessments/scripts/preliminary/ices_whiting_irish_sea_2025_benchmark.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/ices_whiting_west_scotland_2025.R b/analysis/comp_assessments/scripts/preliminary/ices_whiting_west_scotland_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/ices_whiting_west_scotland_2025.R rename to analysis/comp_assessments/scripts/preliminary/ices_whiting_west_scotland_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/jrn_afwg_haddock_northeast_arctic_2026.R b/analysis/comp_assessments/scripts/preliminary/jrn_afwg_haddock_northeast_arctic_2026.R similarity index 98% rename from analysis/comp_assessments/scripts/translation/preliminary/jrn_afwg_haddock_northeast_arctic_2026.R rename to analysis/comp_assessments/scripts/preliminary/jrn_afwg_haddock_northeast_arctic_2026.R index 0ad7b2d2..1f11adee 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/jrn_afwg_haddock_northeast_arctic_2026.R +++ b/analysis/comp_assessments/scripts/preliminary/jrn_afwg_haddock_northeast_arctic_2026.R @@ -20,8 +20,8 @@ obs <- database_to_tam_obs( ) obs$catch$catch_sd_group <- factor(ifelse(obs$catch$age == 3, "age3", "age4plus")) -obs$pop_covariates$F_sd_group <- factor(ifelse( - obs$pop_covariates$age == 3, "age3", "age4plus" +obs$catch$F_sd_group <- factor(ifelse( + obs$catch$age == 3, "age3", "age4plus" )) obs$index$q_age_group <- ifelse(obs$index$age == 3, "age3", ifelse( obs$index$survey == "RU-BTr-Q4", "age4-8", diff --git a/analysis/comp_assessments/scripts/translation/preliminary/jrn_redfish_beaked_2026.R b/analysis/comp_assessments/scripts/preliminary/jrn_redfish_beaked_2026.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/jrn_redfish_beaked_2026.R rename to analysis/comp_assessments/scripts/preliminary/jrn_redfish_beaked_2026.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_american_plaice_5yz_2022_run29f4.R b/analysis/comp_assessments/scripts/preliminary/nefsc_american_plaice_5yz_2022_run29f4.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/nefsc_american_plaice_5yz_2022_run29f4.R rename to analysis/comp_assessments/scripts/preliminary/nefsc_american_plaice_5yz_2022_run29f4.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_cod_georges_bank_2024.R b/analysis/comp_assessments/scripts/preliminary/nefsc_cod_georges_bank_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/nefsc_cod_georges_bank_2024.R rename to analysis/comp_assessments/scripts/preliminary/nefsc_cod_georges_bank_2024.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_gom_cod_2021_m02.R b/analysis/comp_assessments/scripts/preliminary/nefsc_gom_cod_2021_m02.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/nefsc_gom_cod_2021_m02.R rename to analysis/comp_assessments/scripts/preliminary/nefsc_gom_cod_2021_m02.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_pollock_5yz_2024.R b/analysis/comp_assessments/scripts/preliminary/nefsc_pollock_5yz_2024.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/nefsc_pollock_5yz_2024.R rename to analysis/comp_assessments/scripts/preliminary/nefsc_pollock_5yz_2024.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_scup_2015.R b/analysis/comp_assessments/scripts/preliminary/nefsc_scup_2015.R similarity index 99% rename from analysis/comp_assessments/scripts/translation/preliminary/nefsc_scup_2015.R rename to analysis/comp_assessments/scripts/preliminary/nefsc_scup_2015.R index 7476a9e6..1d5eeb0a 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_scup_2015.R +++ b/analysis/comp_assessments/scripts/preliminary/nefsc_scup_2015.R @@ -73,7 +73,7 @@ obs$weight$obs[obs$weight$age == 7] <- plus_weight$weight[ match(obs$weight$year[obs$weight$age == 7], plus_weight$year) ] obs$maturity$spawn_time <- 0.5 -obs$pop_covariates$age_factor <- factor(obs$pop_covariates$age, levels = ages) +obs$catch$age_factor <- factor(obs$catch$age, levels = ages) obs$index$q_key <- interaction(obs$index$survey, factor(obs$index$age, levels = ages), drop = TRUE, lex.order = TRUE ) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_white_hake_2025.R b/analysis/comp_assessments/scripts/preliminary/nefsc_white_hake_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/nefsc_white_hake_2025.R rename to analysis/comp_assessments/scripts/preliminary/nefsc_white_hake_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/nefsc_winter_flounder_gb_2022_vpa.R b/analysis/comp_assessments/scripts/preliminary/nefsc_winter_flounder_gb_2022_vpa.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/nefsc_winter_flounder_gb_2022_vpa.R rename to analysis/comp_assessments/scripts/preliminary/nefsc_winter_flounder_gb_2022_vpa.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/noaa_acadian_redfish_gom_gb_2025.R b/analysis/comp_assessments/scripts/preliminary/noaa_acadian_redfish_gom_gb_2025.R similarity index 98% rename from analysis/comp_assessments/scripts/translation/preliminary/noaa_acadian_redfish_gom_gb_2025.R rename to analysis/comp_assessments/scripts/preliminary/noaa_acadian_redfish_gom_gb_2025.R index 8f6be44e..c32decfa 100644 --- a/analysis/comp_assessments/scripts/translation/preliminary/noaa_acadian_redfish_gom_gb_2025.R +++ b/analysis/comp_assessments/scripts/preliminary/noaa_acadian_redfish_gom_gb_2025.R @@ -26,7 +26,6 @@ inputs <- rbind(inputs[inputs$type != "index", ], index) obs <- database_to_tam_obs(source$assessment$assessment_id, inputs, years = years, ages = ages, assumptions = source$assumptions) obs$maturity$spawn_time <- 0.4 -obs$pop_covariates$F_age <- tinyAM::cut_ages(obs$pop_covariates$age, c(1:9, 26)) obs$catch$F_age <- tinyAM::cut_ages(obs$catch$age, c(1:9, 26)) q_age <- ifelse(grepl("fall", obs$index$survey, ignore.case = TRUE), pmin(obs$index$age, 4), pmin(obs$index$age, 7)) diff --git a/analysis/comp_assessments/scripts/translation/preliminary/noaa_black_rockfish_oregon_2023.R b/analysis/comp_assessments/scripts/preliminary/noaa_black_rockfish_oregon_2023.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/noaa_black_rockfish_oregon_2023.R rename to analysis/comp_assessments/scripts/preliminary/noaa_black_rockfish_oregon_2023.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/noaa_canary_rockfish_2023.R b/analysis/comp_assessments/scripts/preliminary/noaa_canary_rockfish_2023.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/noaa_canary_rockfish_2023.R rename to analysis/comp_assessments/scripts/preliminary/noaa_canary_rockfish_2023.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/noaa_goa_pop_2023.R b/analysis/comp_assessments/scripts/preliminary/noaa_goa_pop_2023.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/noaa_goa_pop_2023.R rename to analysis/comp_assessments/scripts/preliminary/noaa_goa_pop_2023.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/noaa_pacific_coast_dover_sole_2021.R b/analysis/comp_assessments/scripts/preliminary/noaa_pacific_coast_dover_sole_2021.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/noaa_pacific_coast_dover_sole_2021.R rename to analysis/comp_assessments/scripts/preliminary/noaa_pacific_coast_dover_sole_2021.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/noaa_sablefish_pacific_coast_2025.R b/analysis/comp_assessments/scripts/preliminary/noaa_sablefish_pacific_coast_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/noaa_sablefish_pacific_coast_2025.R rename to analysis/comp_assessments/scripts/preliminary/noaa_sablefish_pacific_coast_2025.R diff --git a/analysis/comp_assessments/scripts/translation/preliminary/noaa_west_coast_yelloweye_2025.R b/analysis/comp_assessments/scripts/preliminary/noaa_west_coast_yelloweye_2025.R similarity index 100% rename from analysis/comp_assessments/scripts/translation/preliminary/noaa_west_coast_yelloweye_2025.R rename to analysis/comp_assessments/scripts/preliminary/noaa_west_coast_yelloweye_2025.R diff --git a/analysis/comp_assessments/scripts/run_all.R b/analysis/comp_assessments/scripts/run_all.R new file mode 100644 index 00000000..aa4504d8 --- /dev/null +++ b/analysis/comp_assessments/scripts/run_all.R @@ -0,0 +1,28 @@ +# Run from the tinyAM repository root. Refresh the SAIO cache manually first. +root <- file.path("analysis", "comp_assessments") +translation_tier <- "curated" +timeout <- 20 * 60 # Seconds per assessment; Inf removes the hard deadline. + +pkgload::load_all(".", quiet = TRUE) +source(file.path(root, "R", "run_assessment.R")) +database <- read_database() + +# Configure parallelism here, as for fit_retro() and fit_hindcast(). +# Use future::plan(future::sequential) when troubleshooting. +future::plan(future::multisession, workers = 10) + +## Fit and save first ---- +source(file.path(root, "scripts", "observation_readiness.R")) +runs <- run_assessments(database = database, tier = translation_tier, + cache = TRUE, save_results = TRUE, timeout = timeout) +.assessment_save_rds(runs, file.path(.assessment_cache_root(translation_tier, database), + "assessment_runs.rds")) +cli::cli_inform("Fitting complete. Inspect results/{translation_tier}/fit_diagnostics.csv for failures and timeouts.") + +## Render separately; a render failure never loses a fit ---- +dashboards <- render_assessment_dashboards(runs) + +## Overview figures can also be rerun without fitting ---- +source(file.path(root, "scripts", "stats_plots.R")) +source(file.path(root, "scripts", "trend_plots.R")) +future::plan(future::sequential) diff --git a/analysis/comp_assessments/scripts/translation/run_stock.R b/analysis/comp_assessments/scripts/run_stock.R similarity index 94% rename from analysis/comp_assessments/scripts/translation/run_stock.R rename to analysis/comp_assessments/scripts/run_stock.R index 0b1dfcad..e1eb907a 100644 --- a/analysis/comp_assessments/scripts/translation/run_stock.R +++ b/analysis/comp_assessments/scripts/run_stock.R @@ -6,7 +6,7 @@ source(file.path(root, "R", "run_assessment.R")) translation_tier <- "curated" assessment_id <- "afsc_atka_mackerel_bsai_2024" -database <- read_database(tier = translation_tier) +database <- read_database() source <- read_assessment(assessment_id, database) do_fit <- TRUE silent <- FALSE diff --git a/analysis/comp_assessments/scripts/translation/stats_plots.R b/analysis/comp_assessments/scripts/stats_plots.R similarity index 97% rename from analysis/comp_assessments/scripts/translation/stats_plots.R rename to analysis/comp_assessments/scripts/stats_plots.R index 74a98f52..70c0e8f9 100644 --- a/analysis/comp_assessments/scripts/translation/stats_plots.R +++ b/analysis/comp_assessments/scripts/stats_plots.R @@ -13,7 +13,7 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "translation_registry.R")) if (!exists("translation_tier", inherits = FALSE)) translation_tier <- "curated" results_dir <- .assessment_results(translation_tier) -plot_database <- .saio_metadata(tier = translation_tier) +plot_database <- if (exists("database", inherits = FALSE)) database else read_database() .assessment_check_results_revision(results_dir, plot_database) translation_ids <- assessment_translations(translation_tier)$assessment_id source(file.path(root, "R", "plot_stock_order.R")) @@ -26,9 +26,9 @@ plot_agreement_heatmap <- function(root) { show_col_types = FALSE ) - assessments <- .saio_read_table("assessments.csv", revision = plot_database$commit) + assessments <- plot_database$assessments - stocks <- .saio_read_table("stocks.csv", revision = plot_database$commit) + stocks <- plot_database$stocks comparison <- comparison |> filter(assessment_id %in% translation_ids) diff --git a/analysis/comp_assessments/scripts/translation/run_all.R b/analysis/comp_assessments/scripts/translation/run_all.R deleted file mode 100644 index 30a8b07d..00000000 --- a/analysis/comp_assessments/scripts/translation/run_all.R +++ /dev/null @@ -1,62 +0,0 @@ -root <- file.path("analysis", "comp_assessments") -translation_tier <- "curated" -results_dir <- file.path(root, "results", translation_tier) - -# Batch controls. Dashboards are optional and are rendered only after saving fits. -parallel <- TRUE -workers <- 12L -dashboard <- TRUE -timeout <- 20 * 60 # Seconds per assessment; Inf disables the subprocess deadline. - -pkgload::load_all(".", quiet = TRUE) -required <- c("readr", "dplyr", "tidyr", "stringr", "ggplot2", "patchwork", "ggtext", - if (is.finite(timeout)) "callr", - if (dashboard) c("knitr", "rmarkdown", "flexdashboard")) -missing <- required[!vapply(required, requireNamespace, logical(1), quietly = TRUE)] -if (length(missing)) cli::cli_abort(c( - "Install the batch's analysis packages before fitting: {paste(missing, collapse = ', ')}.", - "i" = "These packages are used by the overview figures and optional subprocess/dashboard stages." -)) -cli::cli_inform("Updating observation readiness.") -source("analysis/comp_assessments/scripts/translation/observation_readiness.R") -source(file.path(root, "R", "run_assessment.R")) - -database <- read_committed_database(tier = translation_tier) -cache_root <- .assessment_cache_root(translation_tier, database) -cli::cli_inform("Fitting assessments from SAIO {database$commit}; checkpoints are saved under {cache_root}//.") -runs <- run_assessments( - tier = translation_tier, - database = database, - parallel = parallel, - workers = workers, - save_results = TRUE, - cache = TRUE, - dashboard = FALSE, # Render previews below, after saving the complete batch. - timeout = timeout -) -cli::cli_inform("Saving combined assessment results.") -.assessment_save_rds(runs, file.path(cache_root, "assessment_runs.rds")) - -# Exploratory dashboards do not change aggregate comparison eligibility. -preview_errors <- list() -if (dashboard) for (id in names(runs)) { - result <- runs[[id]] - if (!inherits(result$fit, "tam_fit")) next - output <- file.path(.assessment_cache(id, translation_tier, database), "dashboard.html") - cli::cli_inform("Rendering dashboard: {id}") - error <- tryCatch({ - view_assessment(result$fit, result, output_file = output, open_file = FALSE) - runs[[id]]$dashboard_file <- output - NULL - }, error = conditionMessage) - if (!is.null(error)) preview_errors[[id]] <- error -} -if (dashboard) .assessment_save_rds(runs, file.path(cache_root, "assessment_runs.rds")) -.assessment_save_rds(preview_errors, file.path(cache_root, "dashboard_errors.rds")) - -index_assessment_dashboards(translation_tier, database) - -cli::cli_inform("Building overview figures.") -source(file.path(root, "scripts", "translation", "stats_plots.R")) -source(file.path(root, "scripts", "translation", "trend_plots.R")) -cli::cli_inform("Assessment batch complete. Inspect results/fit_diagnostics.csv for failures and timeouts.") diff --git a/analysis/comp_assessments/scripts/translation/trend_plots.R b/analysis/comp_assessments/scripts/trend_plots.R similarity index 97% rename from analysis/comp_assessments/scripts/translation/trend_plots.R rename to analysis/comp_assessments/scripts/trend_plots.R index e6f23b7f..704a861f 100644 --- a/analysis/comp_assessments/scripts/translation/trend_plots.R +++ b/analysis/comp_assessments/scripts/trend_plots.R @@ -13,7 +13,7 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "translation_registry.R")) if (!exists("translation_tier", inherits = FALSE)) translation_tier <- "curated" results_dir <- .assessment_results(translation_tier) -plot_database <- .saio_metadata(tier = translation_tier) +plot_database <- if (exists("database", inherits = FALSE)) database else read_database() .assessment_check_results_revision(results_dir, plot_database) translation_ids <- assessment_translations(translation_tier)$assessment_id source(file.path(root, "R", "plot_stock_order.R")) @@ -25,9 +25,9 @@ ts <- read_csv( ) batch_runs <- .assessment_cached_runs(translation_tier, plot_database) -assessments <- .saio_read_table("assessments.csv", revision = plot_database$commit) +assessments <- plot_database$assessments -stocks <- .saio_read_table("stocks.csv", revision = plot_database$commit) +stocks <- plot_database$stocks ts <- ts |> filter(assessment_id %in% translation_ids) diff --git a/analysis/comp_assessments/scripts/update_database_cache.R b/analysis/comp_assessments/scripts/update_database_cache.R new file mode 100644 index 00000000..956f955a --- /dev/null +++ b/analysis/comp_assessments/scripts/update_database_cache.R @@ -0,0 +1,5 @@ +# Run manually from the tinyAM repository root after updating SAIO. +# This copies committed CSV files only; it never fetches or changes SAIO. +saio_repo <- "../saio" # Edit this path if the two repositories are not siblings. +source("analysis/comp_assessments/R/update_database_cache.R") +update_database_cache(saio_repo) diff --git a/analysis/comp_assessments/tests/test_3pn4rs_source_inputs.R b/analysis/comp_assessments/tests/test_3pn4rs_source_inputs.R index dcdd690d..bf0356db 100644 --- a/analysis/comp_assessments/tests/test_3pn4rs_source_inputs.R +++ b/analysis/comp_assessments/tests/test_3pn4rs_source_inputs.R @@ -1,8 +1,6 @@ source("analysis/comp_assessments/R/read_database.R") root <- file.path("analysis", "comp_assessments") -inputs <- read.csv(file.path(saio_path(), "database", "inputs.csv"), - stringsAsFactors = FALSE -) +inputs <- read_database()$inputs inputs <- inputs[inputs$assessment_id == "dfo_cod_3pn4rs_2025", ] index <- inputs[inputs$type == "index", ] weights <- inputs[inputs$type == "catch_weight", ] @@ -58,7 +56,7 @@ stopifnot( ) source(file.path(root, "R", "run_assessment.R")) -source_data <- read_assessment("dfo_cod_3pn4rs_2025", read_database(tier = "preliminary")) +source_data <- read_assessment("dfo_cod_3pn4rs_2025", read_database()) before <- source_data obs <- database_to_tam_obs( "dfo_cod_3pn4rs_2025", source_data$inputs, @@ -73,7 +71,7 @@ stopifnot( nrow(obs$weight) == 30L * 10L, nrow(obs$maturity) == 30L * 10L, all(is.finite(obs$pop_covariates$M_assumption)), - identical(tinyAM::check_obs(obs), TRUE), + identical(tinyAM::check_tam_data(obs), TRUE), identical(source_data, before), source_data$assessment$inputs_status == "partial" ) diff --git a/analysis/comp_assessments/tests/test_age_subsets.R b/analysis/comp_assessments/tests/test_age_subsets.R index 4a0a17b4..8e310759 100644 --- a/analysis/comp_assessments/tests/test_age_subsets.R +++ b/analysis/comp_assessments/tests/test_age_subsets.R @@ -53,7 +53,7 @@ testthat::test_that("observations select biology and retain older catch in the n years = full$years, ages = 0:4, surveys = c("HERAS", "GERAS", "N20", "IBTS/BITSQ1"), assumptions = source_data$assumptions ) - testthat::expect_true(tinyAM::check_obs(obs)) + testthat::expect_true(tinyAM::check_tam_data(obs)) for (component in names(obs)) testthat::expect_true(all(obs[[component]]$age %in% 0:4)) testthat::expect_equal(nrow(obs$weight), 35L * 5L) old_plus <- subset(full$obs$catch, age >= 4) diff --git a/analysis/comp_assessments/tests/test_asmfc_striped_bass_2018_source.R b/analysis/comp_assessments/tests/test_asmfc_striped_bass_2018_source.R index 67769a16..b6ab5957 100644 --- a/analysis/comp_assessments/tests/test_asmfc_striped_bass_2018_source.R +++ b/analysis/comp_assessments/tests/test_asmfc_striped_bass_2018_source.R @@ -1,7 +1,7 @@ .libPaths(c("C:/Users/paulr/AppData/Local/R/win-library/4.4", .libPaths())) pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -db <- read_database(tier = "preliminary") +db <- read_database() record <- read_assessment("asmfc_striped_bass_atlantic_2018", db) years <- 1982:2017 inputs <- record$inputs @@ -82,6 +82,6 @@ stopifnot( nrow(total_biomass) == length(years), !anyDuplicated(total_biomass$year), setequal(total_biomass$year, years), - tinyAM::check_obs(translated$obs) + tinyAM::check_tam_data(translated$obs) ) cat("2018 striped-bass source extraction and tinyAM observation preparation passed.\n") diff --git a/analysis/comp_assessments/tests/test_basin_terminology.R b/analysis/comp_assessments/tests/test_basin_terminology.R index c3b84fa3..2e550802 100644 --- a/analysis/comp_assessments/tests/test_basin_terminology.R +++ b/analysis/comp_assessments/tests/test_basin_terminology.R @@ -16,8 +16,8 @@ source("analysis/comp_assessments/R/plot_stock_order.R") plot_stocks <- assessment_plot_stocks(db$assessments, db$stocks, db$assessments$assessment_id[db$assessments$is_current]) stopifnot(identical(as.character(plot_stocks$basin), plot_stocks$ocean)) -plot_code <- readLines("analysis/comp_assessments/scripts/translation/trend_plots.R") -heatmap_code <- readLines("analysis/comp_assessments/scripts/translation/stats_plots.R") +plot_code <- readLines("analysis/comp_assessments/scripts/trend_plots.R") +heatmap_code <- readLines("analysis/comp_assessments/scripts/stats_plots.R") stopifnot(any(grepl("assessment_plot_stocks(", plot_code, fixed = TRUE)), any(grepl("assessment_plot_stocks(", heatmap_code, fixed = TRUE))) stopifnot(!any(grepl('"North Pacific"', heatmap_code, fixed = TRUE))) diff --git a/analysis/comp_assessments/tests/test_batch_controls.R b/analysis/comp_assessments/tests/test_batch_controls.R index c62e643c..c845d8a3 100644 --- a/analysis/comp_assessments/tests/test_batch_controls.R +++ b/analysis/comp_assessments/tests/test_batch_controls.R @@ -1,81 +1,55 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -# Exercise the actual top-level orchestration without fits, exports or rendering. -script <- parse("analysis/comp_assessments/scripts/translation/run_all.R") -for (dashboards in c(FALSE, TRUE)) { - e <- new.env(parent = globalenv()) - e$source <- function(...) invisible(NULL) - e$requireNamespace <- function(...) TRUE - e$read_committed_database <- function(...) list(commit = paste(rep("a", 40), collapse = "")) - e$run_assessments <- function(...) { - e$batch_args <- list(...) - list(example = list(fit = structure(list(), class = "tam_fit"))) - } - e$.assessment_save_rds <- function(...) invisible(NULL) - e$index_assessment_dashboards <- function(...) invisible(NULL) - e$previews <- 0L - e$view_assessment <- function(...) e$previews <- e$previews + 1L - for (expr in script) { - if (is.call(expr) && identical(expr[[1L]], quote(`<-`)) && - identical(expr[[2L]], quote(dashboard))) expr[[3L]] <- dashboards - eval(expr, e) - } - stopifnot(e$previews == as.integer(dashboards), !e$batch_args$dashboard, - identical(e$batch_args$timeout, 1200), isTRUE(e$batch_args$cache)) -} - -missing_packages <- new.env(parent = globalenv()) -missing_packages$requireNamespace <- function(...) FALSE -missing_packages$run_assessments <- function(...) stop("Fitting must not begin.") -missing_error <- tryCatch({ - for (expr in script) eval(expr, missing_packages) - NULL -}, error = identity) -stopifnot(inherits(missing_error, "error"), - grepl("Install the batch's analysis packages before fitting", conditionMessage(missing_error), fixed = TRUE)) +# The script exposes one caller-owned future plan and a separate render stage. +script <- paste(readLines("analysis/comp_assessments/scripts/run_all.R"), collapse = "\n") +stopifnot(grepl("future::plan(future::multisession, workers = 10)", script, fixed = TRUE), + grepl("timeout <- 20 * 60", script, fixed = TRUE), + grepl("render_assessment_dashboards(runs)", script, fixed = TRUE), + !any(c("parallel", "workers", "dashboard") %in% names(formals(run_assessments))), + !"dashboard" %in% names(formals(run_assessment)), + identical(formals(run_assessments)$timeout, quote(Inf))) database <- read_database() -id <- "ices_cod_north_sea_2025" +ids <- c("ices_cod_north_sea_2025", "ices_herring_north_sea_2026") +old_plan <- future::plan() +future::plan(future::sequential) progress_text <- character() -withCallingHandlers(run_assessments(id, database, fit = FALSE, progress = TRUE), +withCallingHandlers(run_assessments(ids[1], database, fit = FALSE, progress = TRUE), message = function(m) progress_text <<- c(progress_text, conditionMessage(m))) -stopifnot(any(grepl(paste(id, "started"), progress_text, fixed = TRUE)), - any(grepl(paste(id, "not_fitted"), progress_text, fixed = TRUE))) +stopifnot(any(grepl(paste(ids[1], "started"), progress_text, fixed = TRUE)), + any(grepl(paste(ids[1], "not_fitted"), progress_text, fixed = TRUE))) for (bad in list(0, -1, NA_real_, c(1, 2), "10")) { - stopifnot(inherits(tryCatch(run_assessments(id, database, fit = FALSE, + stopifnot(inherits(tryCatch(run_assessments(ids[1], database, fit = FALSE, timeout = bad, progress = FALSE), error = identity), "error")) } -stopifnot(inherits(tryCatch(run_assessments(id, database, fit = FALSE, +stopifnot(inherits(tryCatch(run_assessments(ids[1], database, fit = FALSE, progress = NA), error = identity), "error")) empty_database <- database empty_database$assessments <- empty_database$assessments[FALSE, , drop = FALSE] stopifnot(length(run_assessments(database = empty_database, progress = FALSE)) == 0L) -# A hard deadline must become a diagnostic and leave no live child blocking the -# next job. A tiny limit expires during R startup, without running a model. -timed <- run_assessments(id, database, fit = FALSE, timeout = .01, progress = FALSE) -stopifnot(timed[[id]]$diagnostics$status == "timed_out", - is.null(timed[[id]]$fit), grepl("settings were not changed", timed[[id]]$diagnostics$reason), - is.finite(timed[[id]]$diagnostics$elapsed_seconds)) - -ids <- c(id, "ices_herring_north_sea_2026") -for (parallel in c(FALSE, TRUE)) { - ran <- run_assessments(ids, database, fit = FALSE, parallel = parallel, - workers = 2L, timeout = 60, progress = FALSE) - stopifnot(identical(names(ran), ids), - all(vapply(ran, function(x) x$diagnostics$status == "not_fitted", logical(1)))) +# Both plans retain all attempts and the same prepared observations. +sequential <- run_assessments(ids, database, fit = FALSE, progress = FALSE) +future::plan(future::multisession, workers = 2) +parallel <- run_assessments(ids, database, fit = FALSE, progress = FALSE) +if (!isTRUE(all.equal(lapply(sequential, `[[`, "obs"), lapply(parallel, `[[`, "obs"), tolerance = 0))) { + print(lapply(parallel, function(x) x$diagnostics[, c("status", "reason")])) } - -limited <- run_assessments(ids, database, fit = FALSE, parallel = TRUE, - workers = 2L, timeout = .01, progress = FALSE) +stopifnot(inherits(future::plan(), "multisession"), + identical(names(sequential), names(parallel)), + isTRUE(all.equal(lapply(sequential, `[[`, "obs"), lapply(parallel, `[[`, "obs"), tolerance = 0)), + all(vapply(parallel, function(x) x$diagnostics$status == "not_fitted", logical(1)))) +# A tiny deadline expires in startup without running or retuning a model. +limited <- run_assessments(ids, database, fit = FALSE, timeout = .01, progress = FALSE) stopifnot(identical(names(limited), ids), - all(vapply(limited, function(x) x$diagnostics$status == "timed_out", logical(1)))) + all(vapply(limited, function(x) x$diagnostics$status == "timed_out" && + grepl("settings were not changed", x$diagnostics$reason), logical(1)))) +future::plan(future::sequential) -# Passing a real fitted RTMB object back from a supervised process must preserve -# the estimates, reporting tables, diagnostics and standalone tidying workflow. -direct <- run_assessment(id, database) -supervised <- run_assessments(id, database, timeout = 60, progress = FALSE)[[id]] +# A fitted RTMB result must survive the supervised-process return path. +direct <- run_assessment(ids[1], database) +supervised <- run_assessments(ids[1], database, timeout = 120, progress = FALSE)[[ids[1]]] stopifnot(inherits(supervised$fit, "tam_fit"), isTRUE(all.equal(direct$fit$opt$objective, supervised$fit$opt$objective)), isTRUE(all.equal(direct$fit$parameter_values, supervised$fit$parameter_values)), @@ -84,7 +58,7 @@ stopifnot(inherits(supervised$fit, "tam_fit"), tidied <- tinyAM::tidy_tam(model_list = list(supervised = supervised$fit)) stopifnot(tidied$process_residuals$status$status == "ok") -# Cache each stock before the next serial job is allowed to start. +# Every completed attempt is checkpointed before the next sequential job starts. original_runner <- run_assessment original_root <- .assessment_root test_root <- tempfile("assessment_checkpoint_") @@ -100,14 +74,12 @@ run_assessment <- function(assessment_id, ...) { } tryCatch({ cached <- run_assessments(ids, database, fit = FALSE, cache = TRUE, progress = FALSE) - stopifnot(all(file.exists(file.path(.assessment_cache(ids, "curated", database), "result.rds"))), - all(vapply(cached, function(x) x$diagnostics$status == "not_fitted", logical(1)))) + stopifnot(all(file.exists(file.path(.assessment_cache(ids, "curated", database), "result.rds")))) }, finally = { run_assessment <- original_runner .assessment_root <- original_root unlink(test_root, recursive = TRUE) }) -cat("Batch controls, subprocess deadlines and immediate checkpoints passed.\n") checkpoint <- tempfile(fileext = ".rds") .assessment_save_rds(list(version = 1), checkpoint) @@ -116,4 +88,40 @@ stopifnot(inherits(interrupted, "error"), identical(readRDS(checkpoint), list(ve .assessment_save_rds(list(version = 2), checkpoint) stopifnot(identical(readRDS(checkpoint), list(version = 2))) unlink(checkpoint) -cat("Interrupted checkpoint preservation and replacement passed.\n") + +# Rendering never refits, rereads the source, changes eligibility or loses failures. +local({ + old_root <- .assessment_root; old_view <- view_assessment + old_reader <- read_database; old_runner <- run_assessment + output <- tempfile("assessment_render_"); dir.create(output) + .assessment_root <<- output + on.exit({.assessment_root <<- old_root; view_assessment <<- old_view + read_database <<- old_reader; run_assessment <<- old_runner + unlink(output, recursive = TRUE)}, add = TRUE) + read_database <<- function(...) stop("Rendering must not reread source data") + run_assessment <<- function(...) stop("Rendering must not refit") + view_assessment <<- function(fit, assessment, output_file, open_file) { + if (assessment$assessment_id == "failed") stop("Example render error") + writeLines("Rendered", output_file) + } + result <- function(id, convergence) list(assessment_id = id, + translation_tier = "curated", source = database, + fit = structure(list(is_converged = convergence), class = "tam_fit"), + diagnostics = data.frame(database_key = database$database_key), + summary = data.frame(marker = "unchanged")) + failed_source <- database; failed_source$translation_tier <- "curated" + empty <- .failed_assessment_run("absent", failed_source, simpleError("No fitted model")) + runs <- list(absent = empty, good = result("good", TRUE), + uncertain = result("uncertain", FALSE), failed = result("failed", TRUE)) + original <- serialize(runs, NULL) + rendered <- render_assessment_dashboards(runs) + stopifnot(identical(rendered$status, c("skipped_no_fit", "rendered", "troubleshooting", "render_failed")), + rendered$error[1] == "No fitted model", rendered$error[4] == "Example render error", identical(serialize(runs, NULL), original), + file.exists(file.path(output, "results", "curated", "index.html")), + file.exists(file.path(.assessment_cache_root("curated", database), "dashboard_manifest.csv"))) + all_failed <- render_assessment_dashboards(list(absent = empty)) + stopifnot(identical(all_failed$status, "skipped_no_fit"), + file.exists(file.path(.assessment_cache_root("curated", failed_source), "dashboard_manifest.csv"))) +}) +future::plan(old_plan) +cat("Caller-owned future plans, deadlines, checkpoints and separate dashboard status checks passed.\n") diff --git a/analysis/comp_assessments/tests/test_bc_canary_translation.R b/analysis/comp_assessments/tests/test_bc_canary_translation.R index c0130ce6..a7734fad 100644 --- a/analysis/comp_assessments/tests/test_bc_canary_translation.R +++ b/analysis/comp_assessments/tests/test_bc_canary_translation.R @@ -23,7 +23,7 @@ stopifnot(identical(record, original), is.null(x$fit), identical(x$comparison_aggregates, "ssb"), sum(x$dat$is_proj) == 1L, max(x$dat$years) == 2023L, is.finite(tinyAM::nll_fun(tinyAM::make_par(x$dat), x$dat))) -tinyAM::check_obs(x$obs) +tinyAM::check_tam_data(x$obs) # The biomass-to-number denominator includes both sexes before selection. fixture <- record$inputs[rep(1L, 10L), ] diff --git a/analysis/comp_assessments/tests/test_bc_petrale_readiness.R b/analysis/comp_assessments/tests/test_bc_petrale_readiness.R index c94456be..27b78a38 100644 --- a/analysis/comp_assessments/tests/test_bc_petrale_readiness.R +++ b/analysis/comp_assessments/tests/test_bc_petrale_readiness.R @@ -10,8 +10,7 @@ for (fit in c(FALSE, TRUE)) { stock$env$fit_stage == "translation", is.null(stock$env$obs), is.null(stock$env$fit), is.null(stock$env$fit_model), is.null(stock$env$retry_start), is.null(stock$env$start_par), identical(record, original)) - result <- run_assessment("dfo_petrale_bc_2024", database, fit = fit, - dashboard = TRUE, cache = FALSE) + result <- run_assessment("dfo_petrale_bc_2024", database, fit = fit, cache = FALSE) stopifnot(result$diagnostics$status == "translation_failed", is.null(result$fit), is.null(result$obs), is.null(result$ref), is.null(result$summary), is.null(result$differences), is.null(result$dashboard_file), @@ -20,8 +19,7 @@ for (fit in c(FALSE, TRUE)) { nrow(result$audit) == nrow(record$assumptions), !"dfo_petrale_bc_2024" %in% database$assessments$assessment_id[database$assessments$is_current]) } -summary <- read.csv("analysis/comp_assessments/results/comparison_summary.csv") -series <- read.csv("analysis/comp_assessments/results/population_timeseries.csv") -stopifnot(!"dfo_petrale_bc_2024" %in% summary$assessment_id, - !"dfo_petrale_bc_2024" %in% series$assessment_id) +tables <- .assessment_result_tables(list(result), save_results = FALSE) +stopifnot(nrow(attr(tables, "comparison_summary")) == 0L, + nrow(attr(tables, "population_timeseries")) == 0L) cat("BC petrale remains source-blocked in preparation and fitting; no invented model or comparisons are produced.\n") diff --git a/analysis/comp_assessments/tests/test_bc_pop_translation.R b/analysis/comp_assessments/tests/test_bc_pop_translation.R index 3bd42aa3..14b4ea20 100644 --- a/analysis/comp_assessments/tests/test_bc_pop_translation.R +++ b/analysis/comp_assessments/tests/test_bc_pop_translation.R @@ -8,13 +8,12 @@ for (fit in c(FALSE, TRUE)) { gsub("[[:space:]]+", " ", conditionMessage(x$error)), fixed = TRUE), x$env$fit_stage == "translation", is.null(x$env$fit), is.null(x$env$obs), is.null(x$env$fit_model), is.null(x$env$retry_start), identical(record, original)) - result <- run_assessment("dfo_pop_bc_2023", fit = fit, dashboard = TRUE, cache = FALSE) + result <- run_assessment("dfo_pop_bc_2023", fit = fit, cache = FALSE) stopifnot(result$diagnostics$status == "translation_failed", is.null(result$fit), is.null(result$ref), is.null(result$summary), is.null(result$dashboard_file), identical(record, original)) } -summary <- read.csv("analysis/comp_assessments/results/comparison_summary.csv") -series <- read.csv("analysis/comp_assessments/results/population_timeseries.csv") -stopifnot(!"dfo_pop_bc_2023" %in% summary$assessment_id, - !"dfo_pop_bc_2023" %in% series$assessment_id) +tables <- .assessment_result_tables(list(result), save_results = FALSE) +stopifnot(nrow(attr(tables, "comparison_summary")) == 0L, + nrow(attr(tables, "population_timeseries")) == 0L) cat("BC POP is blocked before fitting/comparison; source records remain intact and no stale comparison rows remain.\n") diff --git a/analysis/comp_assessments/tests/test_coastal_hake_translation.R b/analysis/comp_assessments/tests/test_coastal_hake_translation.R index a464c9be..6a97a4cf 100644 --- a/analysis/comp_assessments/tests/test_coastal_hake_translation.R +++ b/analysis/comp_assessments/tests/test_coastal_hake_translation.R @@ -6,8 +6,10 @@ s <- .test_stock(x) stopifnot(identical(x,original),is.null(s$fit),identical(s$years,1975:2024), identical(s$ages,2:15),!"start_par" %in% names(s$fit_call), all(s$obs$maturity$spawn_time==0),all(s$obs$index$samp_time==.5), - s$settings$rec_settings$sd==1.4,identical(s$dat$rec$curve$type,"bh"), - identical(s$dat$rec$curve$lag,2L),length(s$dat$M_terms)==1L, + s$settings$rec_settings$sd==1.4, + identical(s$settings$rec_settings$process,"iid"), + identical(deparse(s$settings$rec_settings$mu_form),"~1"), + is.null(s$dat$rec$curve),length(s$dat$M_terms)==1L, abs(unique(s$dat$log_mu_supplied_m)+1.60944)<1e-12, identical(levels(s$obs$index$q_block),as.character(2:6)), all(s$obs$index$q_block[s$obs$index$age>=6]=="6"), @@ -29,21 +31,8 @@ ref <- database_to_tam_ref(x$assessment$assessment_id,s$comparison_outputs, comparison_definitions=s$comparison_definitions) stopifnot(nrow(ref$pop$recruitment)==50,all(ref$pop$recruitment$unit=="million fish"), is.null(ref$pop$F) || all(is.na(ref$pop$F$est))) -defaults <- tinyAM::make_par(s$dat) -partial <- s$retry_start -e <- new.env(parent=environment(partial)) -e$source <- x -zero <- e$source$outputs$measure=="numbers_at_age" & - e$source$outputs$year==1977 & e$source$outputs$age==2 -stopifnot(sum(zero)==1) -e$source$outputs$value[zero] <- 0 -environment(partial) <- e -start <- partial() -merged <- tinyAM:::.merge_start_par(defaults,start) -missing <- setdiff(names(defaults$log_r),names(start$log_r)) -matched <- intersect(names(start$log_r),names(merged$log_r)) -stopifnot(length(missing)>0,all(is.finite(unlist(start))), - identical(merged$log_r[missing],defaults$log_r[missing]), - identical(merged$log_f,defaults$log_f),identical(merged$log_q,defaults$log_q), - all(merged$log_r[matched]==start$log_r[matched])) +# The settled recipe uses one direct call, constant-mean age-2 recruitment, +# and bounded effective q; it no longer has a source-state retry. +stopifnot(is.null(s$retry_start), is.null(s$fit_model), + identical(s$settings$index_settings$q_link, "logit")) cat("Coastal hake native-percent conversion, fecundity/sex scaling, q sharing, plus biology and fit-disabled preparation passed.\n") diff --git a/analysis/comp_assessments/tests/test_dfo_cod_2j3kl_translation.R b/analysis/comp_assessments/tests/test_dfo_cod_2j3kl_translation.R index 728e6520..e920f8fb 100644 --- a/analysis/comp_assessments/tests/test_dfo_cod_2j3kl_translation.R +++ b/analysis/comp_assessments/tests/test_dfo_cod_2j3kl_translation.R @@ -19,10 +19,7 @@ all_maturity <- source_data$inputs[ drop = FALSE ] -tinyAM::check_obs(obs) -readiness <- read.csv(file.path(.assessment_results("curated"), "observation_readiness.csv"), - stringsAsFactors = FALSE -) +tinyAM::check_tam_data(obs) dat <- do.call(tinyAM::prepare_tam, c( list(data = obs, years = translated$years, ages = translated$ages), translated$settings @@ -73,9 +70,6 @@ stopifnot( ), identical(source_data$inputs$year, source_year), identical(source_data$inputs$year_basis, source_basis), - readiness$maturity_rows[readiness$assessment_id == "dfo_cod_2j3kl_2025"] == 1065L, - readiness$maturity_full_year_age_grid[readiness$assessment_id == "dfo_cod_2j3kl_2025"], - !any(grepl("maturity_cohort", names(readiness))), audit$tinyam_support[audit$setting == "maturity_at_age"] == "supported", dat$N_settings$process == "off", dat$N_settings$init == "exp", diff --git a/analysis/comp_assessments/tests/test_dfo_cod_3ps_translation.R b/analysis/comp_assessments/tests/test_dfo_cod_3ps_translation.R index 0ac3a721..de4b5097 100644 --- a/analysis/comp_assessments/tests/test_dfo_cod_3ps_translation.R +++ b/analysis/comp_assessments/tests/test_dfo_cod_3ps_translation.R @@ -1,17 +1,10 @@ -source("analysis/comp_assessments/R/read_database.R") +source("analysis/comp_assessments/R/run_assessment.R") +database <- read_database() root <- file.path("analysis", "comp_assessments") -source_data <- read.csv(file.path(saio_path(), "database", "inputs.csv"), - na.strings = c("", "NA"), stringsAsFactors = FALSE -) -outputs <- read.csv(file.path(saio_path(), "database", "outputs.csv"), - na.strings = c("", "NA"), stringsAsFactors = FALSE -) -assessments <- read.csv(file.path(saio_path(), "database", "assessments.csv"), - na.strings = c("", "NA"), stringsAsFactors = FALSE -) -assumptions <- read.csv(file.path(saio_path(), "database", "assumptions.csv"), - na.strings = c("", "NA"), stringsAsFactors = FALSE -) +source_data <- database$inputs +outputs <- database$outputs +assessments <- database$assessments +assumptions <- database$assumptions id <- "dfo_cod_3ps_2024" script_path <- .assessment_script(id) script_lines <- readLines(script_path, warn = FALSE) diff --git a/analysis/comp_assessments/tests/test_dfo_cod_4t4vn_translation.R b/analysis/comp_assessments/tests/test_dfo_cod_4t4vn_translation.R index 9d29c1f9..815410bd 100644 --- a/analysis/comp_assessments/tests/test_dfo_cod_4t4vn_translation.R +++ b/analysis/comp_assessments/tests/test_dfo_cod_4t4vn_translation.R @@ -22,7 +22,7 @@ obs <- translated$obs stopifnot(identical(translated$years, 1971:2018)) stopifnot(identical(translated$ages, 3:12)) -stopifnot(check_obs(obs)) +stopifnot(check_tam_data(obs)) expected_key <- paste(landings_at_age$year, landings_at_age$age, sep = ":") observed_catch <- obs$catch[!is.na(obs$catch$obs), , drop = FALSE] catch_key <- paste(observed_catch$year, observed_catch$age, sep = ":") @@ -83,21 +83,4 @@ stopifnot(all(known_m$year == 2018L), setequal(known_m$age, 5:12)) stopifnot(all(known_m$est[known_m$age %in% 5:8] == 0.81)) stopifnot(all(known_m$est[known_m$age %in% 9:12] == 0.85)) -readiness_env <- new.env(parent = globalenv()) -sys.source( - file.path(saio_path(), "scripts", "database", "003_observation_readiness.R"), - envir = readiness_env -) -readiness <- utils::read.csv( - file.path(.assessment_results("curated"), "observation_readiness.csv"), - stringsAsFactors = FALSE -) -southern_gulf <- readiness[ - readiness$assessment_id == "dfo_cod_4t4vn_2019", , - drop = FALSE -] -stopifnot(nrow(southern_gulf) == 1L) -stopifnot(southern_gulf$catch_at_age_rows == 0L) -stopifnot(southern_gulf$landings_at_age_rows == 480L) -stopifnot(isTRUE(southern_gulf$database_to_tam_obs_succeeds)) -stopifnot(isTRUE(southern_gulf$tinyAM_check_obs_passes)) +# The local observation-readiness stage uses the same prepared-input checks. diff --git a/analysis/comp_assessments/tests/test_dfo_eastern_georges_bank_cod_source.R b/analysis/comp_assessments/tests/test_dfo_eastern_georges_bank_cod_source.R index 6f95622c..6aa8123e 100644 --- a/analysis/comp_assessments/tests/test_dfo_eastern_georges_bank_cod_source.R +++ b/analysis/comp_assessments/tests/test_dfo_eastern_georges_bank_cod_source.R @@ -103,8 +103,7 @@ stopifnot( sum(all_outputs$measure == "fishing_mortality_intensity") == 2L, all(is.na(all_outputs$se)), all(is.na(all_outputs$lwr)), all(is.na(all_outputs$upr)), all(nzchar(all_outputs$source_reference)), - !any(grepl("sensitivity|Run 5|Run 6|Run 9", q$source_reference)), - file.exists(file.path(saio_path(), "source_reviews", "ck_nefsc_trac_cert_morhua_gb.md")) + !any(grepl("sensitivity|Run 5|Run 6|Run 9", q$source_reference)) ) before <- framework error <- tryCatch(database_to_tam_obs(ids[1], framework$inputs, diff --git a/analysis/comp_assessments/tests/test_dfo_herring_fall_translation.R b/analysis/comp_assessments/tests/test_dfo_herring_fall_translation.R index f933dad3..5dfa528f 100644 --- a/analysis/comp_assessments/tests/test_dfo_herring_fall_translation.R +++ b/analysis/comp_assessments/tests/test_dfo_herring_fall_translation.R @@ -2,7 +2,7 @@ source("analysis/comp_assessments/tests/helper_stock.R") pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_record <- read_assessment("dfo_herring_4tvn_fall_2024", database) source_original <- source_record translated <- .test_stock(source_record) @@ -29,7 +29,7 @@ cpue_index <- obs$index$survey %in% c( stopifnot( identical(translated$years, 1978:2023), identical(translated$ages, 2:11), - check_obs(obs), + check_tam_data(obs), nrow(obs$catch) == length(1978:2023) * length(2:11), all(is.finite(obs$catch$obs)), !anyNA(expected_catch_index), diff --git a/analysis/comp_assessments/tests/test_dfo_herring_sgsl_translation.R b/analysis/comp_assessments/tests/test_dfo_herring_sgsl_translation.R index bed1c151..ce409b14 100644 --- a/analysis/comp_assessments/tests/test_dfo_herring_sgsl_translation.R +++ b/analysis/comp_assessments/tests/test_dfo_herring_sgsl_translation.R @@ -14,7 +14,7 @@ obs <- translated$obs stopifnot( identical(translated$years, 1978:2023), identical(translated$ages, 2:11), - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), nrow(obs$catch) == 460L, nrow(obs$index) == 526L, nrow(obs$weight) == 460L, diff --git a/analysis/comp_assessments/tests/test_dfo_northern_mackerel_translation.R b/analysis/comp_assessments/tests/test_dfo_northern_mackerel_translation.R index 22313f9e..af0cb6d7 100644 --- a/analysis/comp_assessments/tests/test_dfo_northern_mackerel_translation.R +++ b/analysis/comp_assessments/tests/test_dfo_northern_mackerel_translation.R @@ -6,7 +6,7 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "dfo_northern_mackerel_2025" -source_data <- read_assessment(assessment_id, read_database(tier = "preliminary")) +source_data <- read_assessment(assessment_id, read_database()) original <- source_data translated <- .test_stock(source_data) obs <- translated$obs @@ -16,7 +16,7 @@ stopifnot( identical(translated$years, 1969:2025), identical(translated$ages, 1:10), translated$age_plus_group == 10, - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), nrow(obs$catch) == 570L, nrow(obs$index) == 0L, nrow(obs$weight) == 570L, diff --git a/analysis/comp_assessments/tests/test_ebs_cod_translation.R b/analysis/comp_assessments/tests/test_ebs_cod_translation.R index ac26cac5..26f13e35 100644 --- a/analysis/comp_assessments/tests/test_ebs_cod_translation.R +++ b/analysis/comp_assessments/tests/test_ebs_cod_translation.R @@ -7,7 +7,8 @@ stopifnot(identical(x,original),is.null(s$fit),identical(s$years,2000:2023), identical(s$ages,1:12),!"start_par" %in% names(s$fit_call), all(s$obs$index$samp_time==.5),all(s$obs$maturity$spawn_time==0), all(s$obs$pop_covariates$M_assumption==.3866), - s$settings$rec_settings$sd==.6908,all(is.finite(s$obs$weight$obs)), + is.null(s$settings$rec_settings$sd), + identical(s$settings$rec_settings$process,"iid"),all(is.finite(s$obs$weight$obs)), all(s$obs$weight$obs>0),all(s$obs$maturity$obs>=0 & s$obs$maturity$obs<=.5), all(abs(rowSums(s$key)-1)<1e-12)) raw <- x$inputs @@ -26,7 +27,7 @@ coverage <- vapply(split(length_rows,length_rows$year),function(z) stopifnot(min(coverage)>.994,all(coverage<1), all(s$comparison_definitions$F$status=="approximate"), s$comparison_definitions$ssb$status=="approximate") -stopifnot(s$dat$F_settings$process == "rw") +stopifnot(s$dat$F_settings$process == "cor_rw") # The reviewed shared-level alternative must not add free projection means. candidate_obs <- s$obs candidate_obs$catch$F_year <- factor(candidate_obs$catch$year) diff --git a/analysis/comp_assessments/tests/test_ebs_translation.R b/analysis/comp_assessments/tests/test_ebs_translation.R index a6ba22af..a5902e65 100644 --- a/analysis/comp_assessments/tests/test_ebs_translation.R +++ b/analysis/comp_assessments/tests/test_ebs_translation.R @@ -18,7 +18,7 @@ stopifnot( ) settings <- translated$settings -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) dat <- do.call(tinyAM::prepare_tam, c( list(data = obs, years = translated$years, ages = translated$ages), settings @@ -30,16 +30,6 @@ age1_ats <- obs$index[ drop = FALSE ] ats_old_age1 <- age1_ats[age1_ats$year < 2024, , drop = FALSE] -high_age <- obs$index[obs$index$age >= 9, , drop = FALSE] -high_age_keys <- unique(high_age[c("survey", "age", "q_key")]) -keys_by_age <- aggregate( - q_key ~ survey + age, high_age_keys, - function(x) length(unique(as.character(x))) -) -keys_by_survey <- aggregate( - q_key ~ survey, high_age_keys, - function(x) length(unique(as.character(x))) -) m_values <- unique(obs$pop_covariates[c("age", "M_assumption")]) m_values <- m_values[order(m_values$age), ] @@ -49,20 +39,16 @@ stopifnot( translated$age_plus_group == 15, identical(dat$years, 1964:2024), identical(dat$ages, 1:15), - identical(settings$N_settings$process, "iid"), + identical(settings$N_settings$process, "off"), identical(settings$N_settings$init, "exp"), - identical(settings$F_settings$process, "rw"), + identical(settings$F_settings$process, "cor_rw"), identical(settings$M_settings$process, "off"), identical(settings$M_settings$mu_form, NULL), grepl("M_assumption", paste(deparse(settings$M_settings$mu_supplied), collapse = "")), - grepl("q_key", paste(deparse(settings$index_settings$q_form), collapse = "")), + grepl("logistic(age, by = survey)", paste(deparse(settings$index_settings$q_form), collapse = ""), fixed = TRUE), grepl("survey", paste(deparse(settings$index_settings$sd_form), collapse = "")), - grepl("age", paste(deparse(settings$catch_settings$sd_form), collapse = ""), fixed = TRUE), - grepl("I(age^2)", - paste(deparse(settings$catch_settings$sd_form), collapse = ""), - fixed = TRUE - ), + identical(deparse(settings$catch_settings$sd_form), "~1"), identical( survey_names, sort(c("NMFS bottom-trawl VAST", "NMFS acoustic-trawl")) @@ -70,16 +56,14 @@ stopifnot( !"NMFS acoustic-trawl age-1 index" %in% survey_names, nrow(ats_old_age1) > 0L, !any(age1_ats$year == 2024), - nrow(high_age_keys) > 0L, - all(high_age$q_age_block == "9+"), - all(keys_by_age$q_key == 1L), - all(keys_by_survey$q_key == 1L), - length(unique(as.character(high_age_keys$q_key))) == length(survey_names), + any(obs$index$age >= 9), + ncol(dat$q_modmat) == length(survey_names), all(m_values$age == 1:15), isTRUE(all.equal(m_values$M_assumption, c(0.9, 0.45, rep(0.3, 13)))), identical(translated$comparison_age_groups$N[["10+"]], 10:15), identical(translated$comparison_age_groups$biomass_at_age[["3+"]], 3:15), - identical(translated$comparison_definitions$ssb$status, "approximate") + identical(translated$comparison_definitions$ssb$status, "matched"), + all(obs$maturity$spawn_time == 0.25) ) cat("EBS pollock translation tests passed.\n") diff --git a/analysis/comp_assessments/tests/test_expansion_01_translations.R b/analysis/comp_assessments/tests/test_expansion_01_translations.R index 7bc8c0b8..70039531 100644 --- a/analysis/comp_assessments/tests/test_expansion_01_translations.R +++ b/analysis/comp_assessments/tests/test_expansion_01_translations.R @@ -1,6 +1,6 @@ source("analysis/comp_assessments/R/run_assessment.R") source("analysis/comp_assessments/tests/helper_stock.R") -database <- read_database(tier = "preliminary") +database <- read_database() testthat::test_that("the expansion register keeps all twenty distinct source targets visible", { batch <- read.csv("analysis/comp_assessments/expansion_batch_01.csv", stringsAsFactors = FALSE) @@ -9,8 +9,8 @@ testthat::test_that("the expansion register keeps all twenty distinct source tar testthat::expect_false(anyDuplicated(batch$assessment_id) > 0L) testthat::expect_true(all(batch$assessment_id %in% database$assessments$assessment_id)) # The batch register records its original source review; do not relabel it - # when current default reads advance to SAIO main. - testthat::expect_true(all(batch$data_revision == .saio_snapshot_revision("preliminary"))) + # when the selected local snapshot is refreshed. + testthat::expect_true(all(batch$data_revision == "6f08c06c49e4b73591427a1495bfb4568caf49f0")) testthat::expect_true(all(nzchar(batch$limitation))) translations <- assessment_translations("preliminary") selected <- translations[match(batch$assessment_id, translations$assessment_id), ] diff --git a/analysis/comp_assessments/tests/test_goa_cod_translation.R b/analysis/comp_assessments/tests/test_goa_cod_translation.R index 6a209701..843bb17b 100644 --- a/analysis/comp_assessments/tests/test_goa_cod_translation.R +++ b/analysis/comp_assessments/tests/test_goa_cod_translation.R @@ -11,8 +11,7 @@ obs <- translated$obs settings <- translated$settings stock <- .assessment_stock(source_data, do_fit = FALSE, silent = TRUE)$env -annual_years <- sort(unique(stats::na.omit(stock$age_key$year))) -pooled_key <- stock$age_key[is.na(stock$age_key$year), , drop = FALSE] +pooled_key <- stock$age_key pooled_catch <- stock$.goa_age_shares( stock$inputs, pooled_key, "catch", "Trawl fishery", "", stock$years, stock$ages @@ -27,23 +26,19 @@ trawl_shares <- stock$catch_shares[ ] pooled_catch_match <- match(share_key(trawl_shares), share_key(pooled_catch)) -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) stopifnot( identical(source_data$inputs, inputs_before), identical(translated$years, 2007:2025), identical(translated$ages, 1:10), translated$age_plus_group == 10, - identical(annual_years, 2007:2024), + !"year" %in% names(pooled_key), nrow(pooled_key) > 0L, !anyNA(pooled_catch_match), - any(abs( - trawl_shares$proportion - - pooled_catch$proportion[pooled_catch_match] - ) > 1e-6), - isTRUE(all.equal( - trawl_shares$proportion[trawl_shares$year == 2025], - pooled_catch$proportion[pooled_catch$year == 2025] - )), + isTRUE(all.equal(trawl_shares$proportion, + pooled_catch$proportion[pooled_catch_match])), + all(abs(aggregate(age_given_length ~ type + fleet + survey + + length_bin_lower + length_bin_upper, pooled_key, sum)$age_given_length - 1) < 1e-12), isTRUE(all.equal(stock$index_shares, pooled_index)), nrow(obs$catch) == 19L * 10L, nrow(obs$index) == 10L * 10L, @@ -51,8 +46,8 @@ stopifnot( all(is.finite(obs$index$obs)), identical(settings$N_settings$process, "off"), identical(settings$N_settings$init, "exp"), - identical(settings$F_settings$process, "iid"), - grepl("age", paste(deparse(settings$F_settings$mu_form), collapse = "")), + identical(settings$F_settings$process, "cor_rw"), + is.null(settings$F_settings$mu_form), identical(settings$M_settings$process, "off"), identical(settings$M_settings$mu_form, NULL), grepl( @@ -60,10 +55,10 @@ stopifnot( paste(deparse(settings$M_settings$mu_supplied), collapse = "") ), grepl( - "q_block", - paste(deparse(settings$index_settings$q_form), collapse = "") + "logistic(age)", + paste(deparse(settings$index_settings$q_form), collapse = ""), fixed = TRUE ), - length(unique(obs$index$q_block)) > 1L, + grepl("rw(year)", paste(deparse(settings$index_settings$q_form), collapse = ""), fixed = TRUE), all(is.finite(obs$pop_covariates$M_assumption)), all(obs$pop_covariates$M_assumption[obs$pop_covariates$year %in% 2014:2016] == 0.84), all(obs$pop_covariates$M_assumption[!obs$pop_covariates$year %in% 2014:2016] == 0.50), diff --git a/analysis/comp_assessments/tests/test_goa_pollock_translation.R b/analysis/comp_assessments/tests/test_goa_pollock_translation.R index 6be388c2..99b242c4 100644 --- a/analysis/comp_assessments/tests/test_goa_pollock_translation.R +++ b/analysis/comp_assessments/tests/test_goa_pollock_translation.R @@ -3,7 +3,7 @@ source("analysis/comp_assessments/R/read_database.R") source("analysis/comp_assessments/R/run_assessment.R") assessment <- run_assessment("afsc_pollock_goa_2024", fit = FALSE) -comparison_outputs <- assessment$comparison$comparison_outputs +comparison_outputs <- assessment$source$outputs f <- comparison_outputs[comparison_outputs$measure == "fishing_mortality_at_age" & comparison_outputs$source_type == "derived_source_output", ] @@ -14,8 +14,8 @@ stopifnot( nrow(f) == 371L, all(f$year %in% 1970:2023), all(f$age %in% 1:8), - identical(assessment$comparison$comparison_definitions$F$status, "approximate"), - any(grepl("partial reconstruction", assessment$background, fixed = TRUE)) + is.null(assessment$comparison$comparison_definitions$F), + any(grepl("official F-at-age is unavailable", assessment$background, fixed = TRUE)) ) -cat("GOA pollock translation retains the approximate, partial F comparison without fitting.\n") +cat("GOA pollock translation preserves source-derived F records and the documented native-F limitation without fitting.\n") diff --git a/analysis/comp_assessments/tests/test_goa_translation.R b/analysis/comp_assessments/tests/test_goa_translation.R index 278cd737..bdcb0567 100644 --- a/analysis/comp_assessments/tests/test_goa_translation.R +++ b/analysis/comp_assessments/tests/test_goa_translation.R @@ -10,7 +10,7 @@ source_data <- read_assessment("afsc_pollock_goa_2024", database) translated <- .test_stock(source_data) obs <- translated$obs -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) stopifnot( any(is.finite(obs$catch$obs[obs$catch$age == 1])), any(is.finite(obs$catch$obs[obs$catch$age == 2])), diff --git a/analysis/comp_assessments/tests/test_herring_translation.R b/analysis/comp_assessments/tests/test_herring_translation.R index dbdc0363..e14094b8 100644 --- a/analysis/comp_assessments/tests/test_herring_translation.R +++ b/analysis/comp_assessments/tests/test_herring_translation.R @@ -5,12 +5,12 @@ pkgload::load_all(".", quiet = TRUE) source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) -database <- read_committed_database() -source_data <- read_committed_assessment("ices_herring_north_sea_2026", database) +database <- read_database() +source_data <- read_assessment("ices_herring_north_sea_2026", database) translated <- .test_stock(source_data) obs <- translated$obs -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) dat <- do.call(tinyAM::prepare_tam, c( list(data = obs, years = translated$years, ages = translated$ages), translated$settings diff --git a/analysis/comp_assessments/tests/test_ices_bluewhiting_translation.R b/analysis/comp_assessments/tests/test_ices_bluewhiting_translation.R index bc6aa3dc..18401672 100644 --- a/analysis/comp_assessments/tests/test_ices_bluewhiting_translation.R +++ b/analysis/comp_assessments/tests/test_ices_bluewhiting_translation.R @@ -8,14 +8,18 @@ source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_bluewhiting_northeast_atlantic_2026" database <- read_database() source_data <- read_assessment(assessment_id, database) +before <- source_data translated <- .test_stock(source_data) source_q <- source_data$outputs[ source_data$outputs$type == "catchability" & source_data$outputs$measure == "q", , drop = FALSE ] -comparison_q <- translated$comparison_outputs[ - translated$comparison_outputs$type == "catchability" & - translated$comparison_outputs$measure == "q", , drop = FALSE -] +expected_q <- vapply(c("1", "2", "3", "4", "5-8"), function(group) { + rows <- if (group == "5-8") source_q[source_q$age_group %in% group, , drop = FALSE] else + source_q[as.character(source_q$age) %in% group, , drop = FALSE] + unique(rows$value) * 1000 +}, numeric(1)) +names(expected_q) <- names(translated$start_par$log_q) + dat <- do.call(tinyAM::prepare_tam, c( list(data = translated$obs, years = translated$years, ages = translated$ages), translated$settings @@ -23,7 +27,7 @@ dat <- do.call(tinyAM::prepare_tam, c( par <- tinyAM::make_par(dat) stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1981:2026), identical(translated$ages, 1:10), nrow(translated$obs$catch) == 460L, @@ -37,9 +41,9 @@ stopifnot( identical(names(translated$start_par$log_sd_index), names(par$log_sd_index)), length(unique(translated$obs$index$q_key)) == 5L, setequal(levels(translated$obs$index$sd_group), c("1", "2", "3", "4-6", "7-8")), - isTRUE(all.equal(comparison_q$value, source_q$value * 1000)), - all(comparison_q$unit == "unitless"), - all(grepl("Converted q by 1000", comparison_q$notes)) + isTRUE(all.equal(exp(translated$start_par$log_q), expected_q)), + identical(source_data, before), + all(is.finite(translated$start_par$log_q)) ) cat("Blue whiting translation structure passed.\n") diff --git a/analysis/comp_assessments/tests/test_ices_cod_celtic_sea_2026_translation.R b/analysis/comp_assessments/tests/test_ices_cod_celtic_sea_2026_translation.R index 8b0def45..8fc8e85b 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_celtic_sea_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_cod_celtic_sea_2026_translation.R @@ -15,7 +15,7 @@ source_F <- .translation_start_surface( ) stopifnot( - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), identical(translated$years, 1980:2025), identical(translated$ages, 1:7), translated$age_plus_group == 7L, diff --git a/analysis/comp_assessments/tests/test_ices_cod_faroe_plateau_2025_translation.R b/analysis/comp_assessments/tests/test_ices_cod_faroe_plateau_2025_translation.R index d03ebe37..e0867e53 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_faroe_plateau_2025_translation.R +++ b/analysis/comp_assessments/tests/test_ices_cod_faroe_plateau_2025_translation.R @@ -1,10 +1,10 @@ root <- file.path("analysis", "comp_assessments") pkgload::load_all(".", quiet = TRUE) -source(file.path(root, "R", "read_database.R")) +source(file.path(root, "R", "run_assessment.R")) source(file.path(root, "R", "database_to_tam_obs.R")) id <- "ices_cod_faroe_plateau_2025" -source_data <- read_assessment(id, read_database(tier = "preliminary")) +source_data <- read_assessment(id, read_database()) env <- new.env(parent = globalenv()) env$source <- source_data env$do_fit <- FALSE diff --git a/analysis/comp_assessments/tests/test_ices_cod_iceland_2026_translation.R b/analysis/comp_assessments/tests/test_ices_cod_iceland_2026_translation.R index bf1975de..8b71b442 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_iceland_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_cod_iceland_2026_translation.R @@ -1,7 +1,7 @@ root <- file.path("analysis", "comp_assessments") -source(file.path(root, "R", "read_database.R")) +source(file.path(root, "R", "run_assessment.R")) source(file.path(root, "R", "database_to_tam_obs.R")) -source_data <- read_assessment("ices_cod_iceland_2026", read_database(tier = "preliminary")) +source_data <- read_assessment("ices_cod_iceland_2026", read_database()) env <- new.env(parent = globalenv()) env$source <- source_data env$do_fit <- FALSE diff --git a/analysis/comp_assessments/tests/test_ices_cod_north_sea_translation.R b/analysis/comp_assessments/tests/test_ices_cod_north_sea_translation.R index bfe80946..000236f0 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_north_sea_translation.R +++ b/analysis/comp_assessments/tests/test_ices_cod_north_sea_translation.R @@ -5,13 +5,13 @@ pkgload::load_all(".", quiet = TRUE) source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) -database <- read_committed_database() -source_data <- read_committed_assessment("ices_cod_north_sea_2025", database) +database <- read_database() +source_data <- read_assessment("ices_cod_north_sea_2025", database) source_inputs <- source_data$inputs translated <- .test_stock(source_data) obs <- translated$obs -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) dat <- do.call(tinyAM::prepare_tam, c( list(data = obs, years = translated$years, ages = translated$ages), translated$settings @@ -32,7 +32,9 @@ comparison_total <- comparison[comparison$measure == "total_numbers", ] source_n <- source_data$outputs[source_data$outputs$measure == "numbers_at_age", ] sum_n <- stats::aggregate(value ~ year + age, source_n, sum) source_total <- source_data$outputs[ - source_data$outputs$measure == "total_numbers", ] + source_data$outputs$measure == "total_numbers" & + source_data$outputs$source_type == "derived_source_output" & + is.na(source_data$outputs$region), ] sum_total <- stats::aggregate(value ~ year, source_n, sum) source_ssb <- source_data$outputs[source_data$outputs$measure == "SSB", ] sum_ssb <- stats::aggregate(value ~ year, source_ssb, sum) @@ -95,14 +97,7 @@ stopifnot( as.numeric(source_total$value), sum_total$value[match(source_total$year, sum_total$year)] )), - nrow(comparison_total) == 43L, - identical(as.integer(comparison_total$year), 1983:2025), - all(comparison_total$source_type == "derived_source_output"), - all(is.na(comparison_total$age)), - isTRUE(all.equal( - as.numeric(comparison_total$value), - sum_total$value[match(comparison_total$year, sum_total$year)] - )), + nrow(comparison_total) == 0L, # Compare the complete N-at-age sums directly below. all(is.na(comparison$region)), isTRUE(all.equal( comparison$value[comparison$measure == "numbers_at_age"], diff --git a/analysis/comp_assessments/tests/test_ices_cod_northern_coastal_2026_source.R b/analysis/comp_assessments/tests/test_ices_cod_northern_coastal_2026_source.R index bdeebb24..1a80d450 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_northern_coastal_2026_source.R +++ b/analysis/comp_assessments/tests/test_ices_cod_northern_coastal_2026_source.R @@ -3,7 +3,7 @@ pkgload::load_all(".", quiet = TRUE) source(file.path(root, "R", "run_assessment.R")) id <- "ices_cod_northern_coastal_2026" -database <- read_database(tier = "preliminary") +database <- read_database() assessment <- read_assessment(id, database) inputs <- assessment$inputs outputs <- assessment$outputs diff --git a/analysis/comp_assessments/tests/test_ices_cod_west_scotland_2022_translation.R b/analysis/comp_assessments/tests/test_ices_cod_west_scotland_2022_translation.R index a9237bde..4bf1dedd 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_west_scotland_2022_translation.R +++ b/analysis/comp_assessments/tests/test_ices_cod_west_scotland_2022_translation.R @@ -1,6 +1,6 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -record <- read_assessment("ices_cod_west_scotland_2022", read_database(tier = "preliminary")) +record <- read_assessment("ices_cod_west_scotland_2022", read_database()) before <- record stock <- .assessment_stock(record, do_fit = FALSE, silent = TRUE) stopifnot(is.null(stock$error), is.null(stock$env$fit), identical(record, before)) diff --git a/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2025_translation.R b/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2025_translation.R index 42a9fa16..44a2f1ef 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2025_translation.R +++ b/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2025_translation.R @@ -1,7 +1,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment("ices_cod_western_baltic_2025", database) translation <- new.env(parent = environment()) translation$source <- source_data @@ -32,7 +32,7 @@ stopifnot( length(unique(index$q_key)) == 10L, all(!is.na(index$sd_block)), nrow(obs$pop_covariates) == length(years) * length(ages), - setequal(levels(obs$pop_covariates$f_age_group), c("age0", "age1", "age2", "age3_4", "age5plus")), + setequal(levels(obs$catch$f_age_group), c("age0", "age1", "age2", "age3_4", "age5plus")), all(obs$maturity$spawn_time == 0) ) diff --git a/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2026_translation.R b/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2026_translation.R index af63b90d..d45ae9b5 100644 --- a/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_cod_western_baltic_2026_translation.R @@ -1,7 +1,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment("ices_cod_western_baltic_2026", database) translation <- new.env(parent = environment()) translation$source <- source_data diff --git a/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_source.R b/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_source.R index 4168c4b4..7b266bd7 100644 --- a/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_source.R +++ b/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_source.R @@ -4,7 +4,7 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_haddock_celtic_sea_7b_k_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_record <- read_assessment(assessment_id, database) inputs <- source_record$inputs outputs <- source_record$outputs diff --git a/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_translation.R b/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_translation.R index 68d84a79..24a8f83a 100644 --- a/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_translation.R +++ b/analysis/comp_assessments/tests/test_ices_haddock_celtic_sea_translation.R @@ -22,7 +22,7 @@ zero_source_catch <- source_record$inputs[ ] zero_source_rows <- match(weight_key(zero_source_catch), weight_key(obs$catch)) -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) stopifnot( identical(translated$years, 1993:2025), identical(translated$ages, 0:8), diff --git a/analysis/comp_assessments/tests/test_ices_haddock_faroe_2025_translation.R b/analysis/comp_assessments/tests/test_ices_haddock_faroe_2025_translation.R index 4e9f9452..4d9b90ba 100644 --- a/analysis/comp_assessments/tests/test_ices_haddock_faroe_2025_translation.R +++ b/analysis/comp_assessments/tests/test_ices_haddock_faroe_2025_translation.R @@ -1,7 +1,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() assessment <- read_assessment("ices_haddock_faroe_2025", database) env <- new.env(parent = environment()) env$source <- assessment diff --git a/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_source.R b/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_source.R index e0f23428..1f229fd2 100644 --- a/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_source.R +++ b/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_source.R @@ -71,13 +71,7 @@ stopifnot( other_assessment <- database$assessments[ database$assessments$assessment_id == "ices_haddock_iceland_2025", ] stopifnot(nrow(other_assessment) == 1L, !isTRUE(other_assessment$is_current)) -review <- paste(readLines(file.path(saio_path(), "source_reviews", "ices_haddock_iceland_2026.md"), warn = FALSE), collapse = " ") -stopifnot( - grepl("4,000 g", review, fixed = TRUE), - grepl("role in the assessment projections is not specified", review, fixed = TRUE), - grepl("Fbar", review, fixed = TRUE), - grepl("interval coverage", review, fixed = TRUE), - grepl("not used to fill gaps", review, fixed = TRUE) -) +# Source-review text is validated in SAIO; this test checks the cached source records. + cat("Icelandic haddock 2026 source records passed.\n") diff --git a/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_translation.R b/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_translation.R index 1541f788..53351bd7 100644 --- a/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_haddock_iceland_2026_translation.R @@ -5,7 +5,7 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_haddock_iceland_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment(assessment_id, database) original <- source_data translated <- .test_stock(source_data) diff --git a/analysis/comp_assessments/tests/test_ices_haddock_irish_sea_7a_2025_source.R b/analysis/comp_assessments/tests/test_ices_haddock_irish_sea_7a_2025_source.R index 3958a437..081d2d90 100644 --- a/analysis/comp_assessments/tests/test_ices_haddock_irish_sea_7a_2025_source.R +++ b/analysis/comp_assessments/tests/test_ices_haddock_irish_sea_7a_2025_source.R @@ -3,7 +3,7 @@ source("analysis/comp_assessments/R/database_to_tam_obs.R") assessment_id <- "ices_haddock_irish_sea_7a_2025" advice_id <- "ices_haddock_irish_sea_7a_2026_summary" -database <- read_database(tier = "preliminary") +database <- read_database() assessment <- read_assessment(assessment_id, database) i <- assessment$inputs o <- assessment$outputs @@ -58,7 +58,7 @@ stopifnot( ) source("analysis/comp_assessments/R/run_assessment.R") -prepared <- run_assessment(assessment_id, fit = FALSE, dashboard = FALSE, cache = FALSE) +prepared <- run_assessment(assessment_id, fit = FALSE, cache = FALSE) stopifnot( identical(prepared$diagnostics$status, "not_fitted"), !is.null(prepared$obs), diff --git a/analysis/comp_assessments/tests/test_ices_haddock_rockall_translation.R b/analysis/comp_assessments/tests/test_ices_haddock_rockall_translation.R index bae013df..00d893eb 100644 --- a/analysis/comp_assessments/tests/test_ices_haddock_rockall_translation.R +++ b/analysis/comp_assessments/tests/test_ices_haddock_rockall_translation.R @@ -1,9 +1,9 @@ root <- file.path("analysis", "comp_assessments") -source(file.path(root, "R", "read_database.R")) +source(file.path(root, "R", "run_assessment.R")) source(file.path(root, "R", "database_to_tam_obs.R")) .translation_abort <- function(message) stop(message, call. = FALSE) id <- "ices_haddock_rockall_2026" -source_data <- read_assessment(id, read_database(tier = "preliminary")) +source_data <- read_assessment(id, read_database()) env <- new.env(parent = globalenv()) env$source <- source_data env$do_fit <- FALSE diff --git a/analysis/comp_assessments/tests/test_ices_herring_gulf_riga_2026_translation.R b/analysis/comp_assessments/tests/test_ices_herring_gulf_riga_2026_translation.R index 9ab0e355..a9fb7433 100644 --- a/analysis/comp_assessments/tests/test_ices_herring_gulf_riga_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_herring_gulf_riga_2026_translation.R @@ -1,7 +1,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_record <- read_assessment("ices_herring_gulf_riga_2026", database) stock <- .assessment_stock(source_record, do_fit = FALSE, silent = TRUE) stopifnot(is.null(stock$error)) diff --git a/analysis/comp_assessments/tests/test_ices_herring_iceland_summer_translation.R b/analysis/comp_assessments/tests/test_ices_herring_iceland_summer_translation.R index 4bed1353..a365edb1 100644 --- a/analysis/comp_assessments/tests/test_ices_herring_iceland_summer_translation.R +++ b/analysis/comp_assessments/tests/test_ices_herring_iceland_summer_translation.R @@ -4,7 +4,7 @@ pkgload::load_all(".", quiet = TRUE) source(file.path(root, "R", "run_assessment.R")) assessment_id <- "ices_herring_iceland_summer_2026" -source_data <- read_assessment(assessment_id, read_database(tier = "preliminary")) +source_data <- read_assessment(assessment_id, read_database()) stock_env <- new.env(parent = environment(.assessment_stock)) stock_env$source <- source_data stock_env$do_fit <- FALSE @@ -21,7 +21,7 @@ stopifnot( sum(is.na(stock_env$obs$catch$obs)) == 4L, all(stock_env$obs$catch$obs[!is.na(stock_env$obs$catch$obs)] > 0), all(stock_env$obs$index$obs > 0), - identical(levels(stock_env$obs$pop_covariates$F_age_block), + identical(levels(stock_env$obs$catch$F_age_block), c(paste0("age", 2:6), "age7plus")), identical(levels(stock_env$obs$index$q_age), c("age2to3", "age4", "age5", "age6", "age7plus")), diff --git a/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_2026_translation.R b/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_2026_translation.R index 75d186a6..85b7c4d5 100644 --- a/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_2026_translation.R @@ -4,14 +4,14 @@ pkgload::load_all(".", quiet = TRUE) source(file.path(root, "R", "run_assessment.R")) assessment_id <- "ices_herring_norwegian_spring_2026" -database <- read_database(tier = "preliminary") +database <- read_database() result <- run_assessment(assessment_id, database = database, fit = FALSE) obs <- result$obs stopifnot( identical(result$diagnostics$status, "not_fitted"), is.null(result$fit), - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), identical(sort(unique(as.integer(obs$catch$year))), 1988:2025), identical(sort(unique(as.integer(obs$catch$age))), 2:12), nrow(obs$catch) == 38L * 11L, diff --git a/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_translation.R b/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_translation.R index 212c12fd..fa6035a0 100644 --- a/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_translation.R +++ b/analysis/comp_assessments/tests/test_ices_herring_norwegian_spring_translation.R @@ -36,7 +36,7 @@ n_source <- source_data$outputs[source_data$outputs$type == "population" & source_data$outputs$age == "2", ] stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1988:2024), identical(translated$ages, 2:12), nrow(translated$obs$catch) == 37L * 11L, diff --git a/analysis/comp_assessments/tests/test_ices_herring_west_scotland_ireland_translation.R b/analysis/comp_assessments/tests/test_ices_herring_west_scotland_ireland_translation.R index 1c78d81e..3cf95b46 100644 --- a/analysis/comp_assessments/tests/test_ices_herring_west_scotland_ireland_translation.R +++ b/analysis/comp_assessments/tests/test_ices_herring_west_scotland_ireland_translation.R @@ -3,7 +3,7 @@ pkgload::load_all(".", quiet = TRUE) source(file.path(root, "R", "run_assessment.R")) assessment_id <- "ices_herring_west_scotland_ireland_2020" -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment(assessment_id, database) translated <- run_assessment( assessment_id, database = database, fit = FALSE, silent = TRUE @@ -40,7 +40,7 @@ stopifnot( identical(translated$diagnostics$status, "not_fitted"), is.null(translated$fit), inherits(obs, "tam_data"), - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), sum(is.finite(obs$catch$obs)) == 567L, isTRUE(all.equal(obs$catch$obs, expected_catch, tolerance = 1e-12)), identical(unique(source_catch$fleet), c("Catch 6aN", "Catch 6aS/7bc")), diff --git a/analysis/comp_assessments/tests/test_ices_norway_pout_translation.R b/analysis/comp_assessments/tests/test_ices_norway_pout_translation.R index 2187069e..1f079053 100644 --- a/analysis/comp_assessments/tests/test_ices_norway_pout_translation.R +++ b/analysis/comp_assessments/tests/test_ices_norway_pout_translation.R @@ -101,7 +101,7 @@ common_ssb <- comparison[ common_ssb <- stats::aggregate(value ~ year, common_ssb, sum) stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1984:2024), identical(translated$ages, 0:3), nrow(translated$obs$catch) == 41L * 4L, @@ -148,10 +148,7 @@ stopifnot( isTRUE(all.equal(common_ssb$value, as.numeric(ssb_q1$value))), nrow(comparison[comparison$measure == "biomass_at_age", ]) == 41L * 4L, nrow(source_q) == 13L, - nrow(comparison_q) == 13L, - isTRUE(all.equal( - sort(as.numeric(comparison_q$value)), sort(as.numeric(source_q$value)) - )), + nrow(comparison_q) == 0L, # Native quarterly q is not an annual-q comparison. all(is.na(comparison$se[comparison$source_type == "derived_common_definition"])) ) diff --git a/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_source.R b/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_source.R index d5cafcb4..84bf8d38 100644 --- a/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_source.R +++ b/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_source.R @@ -4,7 +4,7 @@ root <- "analysis/comp_assessments" source(file.path(root, "R", "read_database.R")) assessment_id <- "ices_plaice_baltic_21_32_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_record <- read_assessment(assessment_id, database) inputs <- source_record$inputs outputs <- source_record$outputs @@ -180,11 +180,7 @@ stopifnot( all(as.numeric(maturity$value) >= 0 & as.numeric(maturity$value) <= 1) ) -review <- paste(readLines(file.path(saio_path(), "source_reviews", "ices_plaice_baltic_21_32_2026.md"), warn = FALSE), collapse = " ") -stopifnot( - grepl("fbarRange=3:6", review, fixed = TRUE), - grepl("14,910,084", review, fixed = TRUE), - grepl("95% confidence", review, fixed = TRUE) -) +# Source-review text is validated in SAIO; this test checks the cached source records. + cat("ICES Baltic plaice source records passed.\n") diff --git a/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_translation.R b/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_translation.R index 519e25eb..7214a300 100644 --- a/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_plaice_baltic_21_32_2026_translation.R @@ -5,7 +5,7 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_plaice_baltic_21_32_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_record <- read_assessment(assessment_id, database) translated <- .test_stock(source_record) obs <- translated$obs diff --git a/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_source.R b/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_source.R index b0e065fc..d2a97b3f 100644 --- a/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_source.R +++ b/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_source.R @@ -8,11 +8,11 @@ source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_plaice_english_channel_7d_2026" stock_id <- "ck_ices_wgnssk_platessa_ns_7d" -database <- read_database(tier = "preliminary") +database <- read_database() source <- read_assessment(assessment_id, database) inputs <- source$inputs outputs <- source$outputs -cache <- file.path(saio_path(), "source_cache", "ices_plaice_7d_2026") +cache <- file.path("analysis", "comp_assessments", "source_cache", "ices_plaice_7d_2026") data_env <- new.env(parent = baseenv()) load(file.path(cache, "run/data.RData"), envir = data_env) dat <- data_env$dat diff --git a/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_translation.R b/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_translation.R index a1434b61..da723300 100644 --- a/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_plaice_english_channel_7d_2026_translation.R @@ -4,7 +4,7 @@ source(file.path(root, "R", "run_assessment.R")) source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) -database <- read_database(tier = "preliminary") +database <- read_database() source <- read_assessment("ices_plaice_english_channel_7d_2026", database) model <- .test_stock(source) diff --git a/analysis/comp_assessments/tests/test_ices_plaice_irish_sea_7a_2026_translation.R b/analysis/comp_assessments/tests/test_ices_plaice_irish_sea_7a_2026_translation.R index 7d4ff0b1..f85b48d1 100644 --- a/analysis/comp_assessments/tests/test_ices_plaice_irish_sea_7a_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_plaice_irish_sea_7a_2026_translation.R @@ -4,7 +4,7 @@ source(file.path(root, "R", "run_assessment.R")) source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) -database <- read_database(tier = "preliminary") +database <- read_database() source_record <- read_assessment("ices_plaice_irish_sea_7a_2026", database) translated <- .test_stock(source_record) diff --git a/analysis/comp_assessments/tests/test_ices_plaice_north_sea_translation.R b/analysis/comp_assessments/tests/test_ices_plaice_north_sea_translation.R index 10ac82c3..20e9711d 100644 --- a/analysis/comp_assessments/tests/test_ices_plaice_north_sea_translation.R +++ b/analysis/comp_assessments/tests/test_ices_plaice_north_sea_translation.R @@ -17,7 +17,7 @@ par <- tinyAM::make_par(dat) inputs <- source_data$inputs outputs <- source_data$outputs stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1957:2025), identical(translated$ages, 1:10), identical(source_data$assessment$terminal_year, 2025L), diff --git a/analysis/comp_assessments/tests/test_ices_saithe_faroe_2025_translation.R b/analysis/comp_assessments/tests/test_ices_saithe_faroe_2025_translation.R index d0c05765..fb32e8ab 100644 --- a/analysis/comp_assessments/tests/test_ices_saithe_faroe_2025_translation.R +++ b/analysis/comp_assessments/tests/test_ices_saithe_faroe_2025_translation.R @@ -1,7 +1,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment("ices_saithe_faroe_2025", database) env <- new.env(parent = environment()) env$source <- source_data diff --git a/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_source.R b/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_source.R index a6dcf111..14fe9bb6 100644 --- a/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_source.R +++ b/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_source.R @@ -4,7 +4,7 @@ root <- "analysis/comp_assessments" source(file.path(root, "R", "read_database.R")) assessment_id <- "ices_saithe_iceland_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment(assessment_id, database) inputs <- source_data$inputs outputs <- source_data$outputs @@ -76,13 +76,7 @@ stopifnot( !any(outputs$measure == "Fbar" & outputs$year == 2026L) ) -review <- paste(readLines(file.path(saio_path(), "source_reviews", "ices_saithe_iceland_2026.md"), warn = FALSE), collapse = " ") -stopifnot( - grepl("28 blank age-year cells", review, fixed = TRUE), - grepl("Table 2 `F` column's age range and calculation are not defined", review, fixed = TRUE), - grepl("Through 2025, `HR` agrees to rounding", review, fixed = TRUE), - grepl("exact 2026 production settings are not fully published", review, fixed = TRUE), - grepl("0.20 as a month-midpoint approximation", review, fixed = TRUE) -) +# Source-review text is validated in SAIO; this test checks the cached source records. + cat("Icelandic saithe 2026 source records passed.\n") \ No newline at end of file diff --git a/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_translation.R b/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_translation.R index cb3dbc0a..ede170f4 100644 --- a/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_saithe_iceland_2026_translation.R @@ -5,7 +5,7 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_saithe_iceland_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment(assessment_id, database) original_inputs <- source_data$inputs translated <- .test_stock(source_data) diff --git a/analysis/comp_assessments/tests/test_ices_saithe_north_sea_translation.R b/analysis/comp_assessments/tests/test_ices_saithe_north_sea_translation.R index 6900cdba..26b35ebe 100644 --- a/analysis/comp_assessments/tests/test_ices_saithe_north_sea_translation.R +++ b/analysis/comp_assessments/tests/test_ices_saithe_north_sea_translation.R @@ -40,7 +40,7 @@ comparison_f_10plus <- translated$comparison_outputs[ ] stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1967:2025), identical(translated$ages, 3:8), identical(translated$age_plus_group, 8), diff --git a/analysis/comp_assessments/tests/test_ices_saithe_northeast_arctic_translation.R b/analysis/comp_assessments/tests/test_ices_saithe_northeast_arctic_translation.R index 96c969a7..6d863ed4 100644 --- a/analysis/comp_assessments/tests/test_ices_saithe_northeast_arctic_translation.R +++ b/analysis/comp_assessments/tests/test_ices_saithe_northeast_arctic_translation.R @@ -6,7 +6,7 @@ source(file.path(root, "R", "database_to_tam_obs.R")) source(file.path(root, "R", "database_to_tam_ref.R")) assessment_id <- "ices_saithe_northeast_arctic_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment(assessment_id, database) translated <- .test_stock(source_data) dat <- do.call(tinyAM::prepare_tam, c( @@ -40,7 +40,7 @@ ref <- database_to_tam_ref( ) stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1960:2025), identical(translated$ages, 3:12), identical(translated$age_plus_group, 12L), diff --git a/analysis/comp_assessments/tests/test_ices_sole_20_24_2025_translation.R b/analysis/comp_assessments/tests/test_ices_sole_20_24_2025_translation.R index 8dd3d24a..b52135c1 100644 --- a/analysis/comp_assessments/tests/test_ices_sole_20_24_2025_translation.R +++ b/analysis/comp_assessments/tests/test_ices_sole_20_24_2025_translation.R @@ -4,14 +4,14 @@ source(file.path(root, "R", "run_assessment.R")) source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment("ices_sole_20_24_2025", database) translated <- .test_stock(source_data) obs <- translated$obs dat <- translated$dat survey_names <- c("Q4Solesurvey1-9+", "Gillnet", "Trawl") -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) stopifnot( identical(translated$years, 1984:2024), diff --git a/analysis/comp_assessments/tests/test_ices_sole_celtic_7fg_2026_source.R b/analysis/comp_assessments/tests/test_ices_sole_celtic_7fg_2026_source.R index 83cc2122..c7601fa3 100644 --- a/analysis/comp_assessments/tests/test_ices_sole_celtic_7fg_2026_source.R +++ b/analysis/comp_assessments/tests/test_ices_sole_celtic_7fg_2026_source.R @@ -4,7 +4,7 @@ source("analysis/comp_assessments/R/read_database.R") source("analysis/comp_assessments/R/database_to_tam_obs.R") assessment_id <- "ices_sole_celtic_7fg_2026" -database <- read_database(tier = "preliminary") +database <- read_database() assessment <- read_assessment(assessment_id, database) inputs <- assessment$inputs outputs <- assessment$outputs diff --git a/analysis/comp_assessments/tests/test_ices_sole_eastern_channel_7d_2026_translation.R b/analysis/comp_assessments/tests/test_ices_sole_eastern_channel_7d_2026_translation.R index 59946257..fd929e06 100644 --- a/analysis/comp_assessments/tests/test_ices_sole_eastern_channel_7d_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_sole_eastern_channel_7d_2026_translation.R @@ -2,7 +2,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") assessment_id <- "ices_sole_eastern_channel_7d_2026" -database <- read_database(tier = "preliminary") +database <- read_database() source_record <- read_assessment(assessment_id, database) original_inputs <- source_record$inputs original_outputs <- source_record$outputs @@ -12,7 +12,7 @@ prepared <- stock$env stopifnot( is.null(stock$error), is.null(prepared$fit), - isTRUE(tinyAM::check_obs(prepared$obs)), + isTRUE(tinyAM::check_tam_data(prepared$obs)), identical(prepared$years, 1982:2025), identical(prepared$ages, 1:11), identical(prepared$age_plus_group, 11L), diff --git a/analysis/comp_assessments/tests/test_ices_sole_north_sea_translation.R b/analysis/comp_assessments/tests/test_ices_sole_north_sea_translation.R index 22fbb430..134d6cc2 100644 --- a/analysis/comp_assessments/tests/test_ices_sole_north_sea_translation.R +++ b/analysis/comp_assessments/tests/test_ices_sole_north_sea_translation.R @@ -5,14 +5,14 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_sole_north_sea_2025" -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment(assessment_id, database) source_inputs <- source_data$inputs translated <- .test_stock(source_data) obs <- translated$obs dat <- translated$dat -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) source_catch <- source_inputs[ source_inputs$type == "catch" & @@ -41,13 +41,10 @@ expected_m <- c(.754, .465, .368, .321, .295, .278, .267, .260, .254, .248) actual_m <- vapply(1:10, function(age) { unique(obs$pop_covariates$M_assumption[obs$pop_covariates$age == age]) }, numeric(1)) -readiness <- read.csv( - file.path(.assessment_results("curated"), "observation_readiness.csv"), - stringsAsFactors = FALSE, check.names = FALSE -) -sole_readiness <- readiness[ - readiness$assessment_id == assessment_id, , drop = FALSE -] +grid <- expand.grid(year = translated$years, age = translated$ages) +key <- function(x) paste(x$year, x$age) +catch_weights <- source_inputs[source_inputs$type == "catch_weight" & + source_inputs$year %in% translated$years & source_inputs$age %in% translated$ages, ] stopifnot( identical(translated$years, 1957:2024), @@ -78,12 +75,11 @@ stopifnot( is.null(translated$start_par), !"relative_biomass_index" %in% obs$index$measure, identical(source_data$inputs, source_inputs), - nrow(sole_readiness) == 1L, - isTRUE(sole_readiness$weight_full_year_age_grid), - isTRUE(sole_readiness$catch_weight_full_year_age_grid), - isTRUE(sole_readiness$maturity_full_year_age_grid), - isTRUE(sole_readiness$M_numerical_values_available), - !isTRUE(sole_readiness$M_estimated_in_source) + setequal(key(obs$weight), key(grid)), + setequal(key(obs$maturity), key(grid)), + setequal(key(catch_weights), key(grid)), + all(is.finite(obs$weight$obs)), + all(is.finite(obs$pop_covariates$M_assumption)) ) cat("North Sea sole translation structure passed.\n") diff --git a/analysis/comp_assessments/tests/test_ices_sole_western_channel_7e_2026_translation.R b/analysis/comp_assessments/tests/test_ices_sole_western_channel_7e_2026_translation.R index 34209038..7930a31a 100644 --- a/analysis/comp_assessments/tests/test_ices_sole_western_channel_7e_2026_translation.R +++ b/analysis/comp_assessments/tests/test_ices_sole_western_channel_7e_2026_translation.R @@ -1,6 +1,6 @@ source("analysis/comp_assessments/tests/helper_stock.R") source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() assessment_id <- "ices_sole_western_channel_7e_2026" assessment <- read_assessment(assessment_id, database) trans <- .test_stock(assessment) diff --git a/analysis/comp_assessments/tests/test_ices_sprat_baltic_translation.R b/analysis/comp_assessments/tests/test_ices_sprat_baltic_translation.R index 1beeac88..460d587c 100644 --- a/analysis/comp_assessments/tests/test_ices_sprat_baltic_translation.R +++ b/analysis/comp_assessments/tests/test_ices_sprat_baltic_translation.R @@ -29,7 +29,7 @@ expected_total_numbers <- tapply( ) stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), all(translated$obs$maturity$spawn_time == .4), identical(translated$years, 1974:2025), identical(translated$ages, 1:8), diff --git a/analysis/comp_assessments/tests/test_ices_turbot_north_sea_2025_benchmark_translation.R b/analysis/comp_assessments/tests/test_ices_turbot_north_sea_2025_benchmark_translation.R index 1d362758..d7f8b118 100644 --- a/analysis/comp_assessments/tests/test_ices_turbot_north_sea_2025_benchmark_translation.R +++ b/analysis/comp_assessments/tests/test_ices_turbot_north_sea_2025_benchmark_translation.R @@ -5,13 +5,13 @@ source(file.path(root, "R", "read_database.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "ices_turbot_north_sea_2025_benchmark" -source_data <- read_assessment(assessment_id, read_database(tier = "preliminary")) +source_data <- read_assessment(assessment_id, read_database()) translated <- .test_stock(source_data) obs <- translated$obs dat <- translated$dat inputs <- source_data$inputs -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) catch <- inputs[ inputs$type == "catch" & inputs$measure == "numbers_at_age", @@ -64,7 +64,7 @@ stopifnot( length(unique(obs$index$q_key)) == 13L, length(unique(obs$catch$sd_group)) == 3L, length(unique(obs$index$sd_group)) == 5L, - length(unique(obs$pop_covariates$F_sd_group)) == 4L, + length(unique(obs$catch$F_sd_group)) == 4L, all(obs$index$q_key[obs$index$survey == "BTS+COAST" & obs$index$age %in% 6:7] == obs$index$q_key[obs$index$survey == "BTS+COAST" & obs$index$age == 6][1]), all(obs$index$q_key[obs$index$survey == "BSAS" & obs$index$age %in% 7:8] == diff --git a/analysis/comp_assessments/tests/test_ices_whiting_irish_sea_2025_source.R b/analysis/comp_assessments/tests/test_ices_whiting_irish_sea_2025_source.R index 941f6b05..4d584918 100644 --- a/analysis/comp_assessments/tests/test_ices_whiting_irish_sea_2025_source.R +++ b/analysis/comp_assessments/tests/test_ices_whiting_irish_sea_2025_source.R @@ -1,7 +1,7 @@ source("analysis/comp_assessments/tests/helper_stock.R") source("analysis/comp_assessments/R/read_database.R") -database <- read_database(tier = "preliminary") +database <- read_database() benchmark_id <- "ices_whiting_irish_sea_2025_benchmark" summary_id <- "ices_whiting_irish_sea_2025_sag_summary" benchmark <- read_assessment(benchmark_id, database) diff --git a/analysis/comp_assessments/tests/test_ices_whiting_north_sea_translation.R b/analysis/comp_assessments/tests/test_ices_whiting_north_sea_translation.R index 809ebe03..b8bb5217 100644 --- a/analysis/comp_assessments/tests/test_ices_whiting_north_sea_translation.R +++ b/analysis/comp_assessments/tests/test_ices_whiting_north_sea_translation.R @@ -24,7 +24,7 @@ m_surface <- translated$obs$pop_covariates m_2022 <- m_surface[m_surface$year == 2022, c("age", "M_assumption")] stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1978:2026), identical(translated$ages, 0:8), nrow(translated$obs$catch) == 49L * 9L, diff --git a/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_source.R b/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_source.R index 97c7d0e1..14ed656d 100644 --- a/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_source.R +++ b/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_source.R @@ -1,7 +1,7 @@ source("analysis/comp_assessments/tests/helper_stock.R") source("analysis/comp_assessments/R/read_database.R") -database <- read_database(tier = "preliminary") +database <- read_database() assessment_id <- "ices_whiting_west_scotland_2025" assessment <- database$assessments[ database$assessments$assessment_id == assessment_id, , drop = FALSE diff --git a/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_translation.R b/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_translation.R index 82d2634d..8e3da617 100644 --- a/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_translation.R +++ b/analysis/comp_assessments/tests/test_ices_whiting_west_scotland_translation.R @@ -3,7 +3,7 @@ source("analysis/comp_assessments/R/run_assessment.R") source("analysis/comp_assessments/R/database_to_tam_obs.R") source("analysis/comp_assessments/R/read_database.R") -database <- read_database(tier = "preliminary") +database <- read_database() assessment_id <- "ices_whiting_west_scotland_2025" source_data <- read_assessment(assessment_id, database) translated <- .test_stock(source_data) @@ -21,7 +21,7 @@ matched <- match(key(index), weight_key) has_weight <- !is.na(matched) stopifnot( - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), identical(translated$years, 1981:2025), identical(translated$ages, 0:7), identical(translated$age_plus_group, 7L), diff --git a/analysis/comp_assessments/tests/test_irish_sea_cod_translation.R b/analysis/comp_assessments/tests/test_irish_sea_cod_translation.R index bd1d6632..d1b07644 100644 --- a/analysis/comp_assessments/tests/test_irish_sea_cod_translation.R +++ b/analysis/comp_assessments/tests/test_irish_sea_cod_translation.R @@ -2,7 +2,7 @@ source("analysis/comp_assessments/tests/helper_stock.R") pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment("ices_cod_irish_sea_2026", database) translated <- .test_stock(source_data) obs <- translated$obs @@ -12,7 +12,7 @@ index <- obs$index excluded <- catch$year %in% 2003:2005 stopifnot( - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), identical(translated$years, 1968:2018), identical(translated$ages, 0:6), nrow(catch) == 51L * 7L, diff --git a/analysis/comp_assessments/tests/test_jrn_afwg_haddock_2026_translation.R b/analysis/comp_assessments/tests/test_jrn_afwg_haddock_2026_translation.R index 4078e75a..f6076dd6 100644 --- a/analysis/comp_assessments/tests/test_jrn_afwg_haddock_2026_translation.R +++ b/analysis/comp_assessments/tests/test_jrn_afwg_haddock_2026_translation.R @@ -1,10 +1,10 @@ pkgload::load_all(".", quiet = TRUE, helpers = FALSE) root <- file.path("analysis", "comp_assessments") -source(file.path(root, "R", "read_database.R")) +source(file.path(root, "R", "run_assessment.R")) source(file.path(root, "R", "database_to_tam_obs.R")) assessment_id <- "jrn_afwg_haddock_northeast_arctic_2026" -source_data <- read_assessment(assessment_id, read_database(tier = "preliminary")) +source_data <- read_assessment(assessment_id, read_database()) env <- new.env(parent = globalenv()) env$source <- source_data env$do_fit <- FALSE @@ -53,7 +53,7 @@ stopifnot( all(is.finite(env$obs$pop_covariates$M_assumption)), all(env$obs$pop_covariates$M_assumption[env$obs$pop_covariates$age >= 7] == 0.2), identical(levels(env$obs$catch$catch_sd_group), c("age3", "age4plus")), - identical(levels(env$obs$pop_covariates$F_sd_group), c("age3", "age4plus")), + identical(levels(env$obs$catch$F_sd_group), c("age3", "age4plus")), ncol(prepared$process_sd$F$matrix) == 2L, identical(prepared$F_settings$mean_ages, 4:7), env$age_plus_group == 13L, diff --git a/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_source.R b/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_source.R index 69ebe8e1..77b1d0e8 100644 --- a/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_source.R +++ b/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_source.R @@ -1,6 +1,6 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -record <- read_assessment("jrn_redfish_beaked_2026", read_database(tier = "preliminary")) +record <- read_assessment("jrn_redfish_beaked_2026", read_database()) inputs <- record$inputs outputs <- record$outputs stopifnot( @@ -41,12 +41,12 @@ catch_weight <- inputs[inputs$type == "catch_weight", ] maturity <- inputs[inputs$type == "maturity", ] M <- inputs[inputs$type == "M", ] stopifnot( - identical(weight$age, 6:19), all(is.na(weight$year)), + isTRUE(all.equal(weight$age, 6:19, tolerance = 0)), all(is.na(weight$year)), identical(weight$value, c(.141, .188, .237, .286, .334, .381, .424, .465, .503, .537, .569, .597, .623, .755)), identical(catch_weight$value, weight$value), - identical(maturity$age, 6:19), all(is.na(maturity$year)), + isTRUE(all.equal(maturity$age, 6:19, tolerance = 0)), all(is.na(maturity$year)), identical(maturity$value, c(.02, .04, .08, .14, .24, .37, .49, .58, .66, .73, .77, .81, .85, 1)), - identical(M$age, 2:19), all(M$value == .05), all(is.na(M$year)) + isTRUE(all.equal(M$age, 2:19, tolerance = 0)), all(M$value == .05), all(is.na(M$year)) ) russian <- select_input("numbers_at_age", survey = "Russian autumn groundfish") eco <- select_input("numbers_at_age", survey = "Ecosystem survey") @@ -114,6 +114,6 @@ prepared <- run_assessment(record$assessment$assessment_id, fit = FALSE) stopifnot( prepared$diagnostics$status == "not_fitted", is.null(prepared$fit), - isTRUE(tinyAM::check_obs(prepared$obs)) + isTRUE(tinyAM::check_tam_data(prepared$obs)) ) cat("Beaked redfish source coverage, fixed biology, missing cells, year basis, units and rounded F passed.\n") diff --git a/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_translation.R b/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_translation.R index 86c9ea03..d49f5a2e 100644 --- a/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_translation.R +++ b/analysis/comp_assessments/tests/test_jrn_beaked_redfish_2026_translation.R @@ -2,7 +2,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") assessment_id <- "jrn_redfish_beaked_2026" -database <- read_database(tier = "preliminary") +database <- read_database() record <- read_assessment(assessment_id, database) original_inputs <- record$inputs original_outputs <- record$outputs @@ -22,7 +22,7 @@ stopifnot( deparse(~ 0 + survey + survey:age)), identical(deparse(prepared$index_settings$sd_form), deparse(~ 0 + survey)), - isTRUE(tinyAM::check_obs(obs)), + isTRUE(tinyAM::check_tam_data(obs)), nrow(obs$catch) == length(years) * length(ages), identical(as.integer(sort(unique(obs$catch$year))), years), identical(as.integer(sort(unique(obs$catch$age))), ages), diff --git a/analysis/comp_assessments/tests/test_nefsc_atlantic_mackerel_translation.R b/analysis/comp_assessments/tests/test_nefsc_atlantic_mackerel_translation.R index c72dbabb..427eee3f 100644 --- a/analysis/comp_assessments/tests/test_nefsc_atlantic_mackerel_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_atlantic_mackerel_translation.R @@ -36,7 +36,7 @@ expected_recruitment <- outputs$value[ ] stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1968:2016), identical(translated$ages, 1:10), translated$age_plus_group == 10L, @@ -77,7 +77,8 @@ stopifnot( outputs$value[outputs$measure == "Fbar" & outputs$year == 2016] == 0.468, outputs$age[outputs$measure == "recruitment" & outputs$year == 2016] == 1, egg_ssb$value[egg_ssb$year == 1979] == 1131094, - nrow(summary_outputs) == 30L, + sum(summary_outputs$measure %in% c("SSB", "Fbar", "recruitment") & + summary_outputs$year %in% 2015:2024) == 30L, summary_outputs$value[summary_outputs$measure == "SSB" & summary_outputs$year == 2024] == 94702, summary_outputs$lwr[summary_outputs$measure == "SSB" & summary_outputs$year == 2024] == 52539, summary_outputs$upr[summary_outputs$measure == "SSB" & summary_outputs$year == 2024] == 170702, diff --git a/analysis/comp_assessments/tests/test_nefsc_atlantic_pollock_translation.R b/analysis/comp_assessments/tests/test_nefsc_atlantic_pollock_translation.R index ce654b75..7a7c03c6 100644 --- a/analysis/comp_assessments/tests/test_nefsc_atlantic_pollock_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_atlantic_pollock_translation.R @@ -1,7 +1,7 @@ source("analysis/comp_assessments/tests/helper_stock.R") source("analysis/comp_assessments/R/run_assessment.R") source("analysis/comp_assessments/R/read_database.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment("nefsc_pollock_5yz_2024", database) translated <- .test_stock(source_data) @@ -30,7 +30,7 @@ expected_index <- aggregate_index$value * survey_weights$value[survey_weights$age == 1] stopifnot( - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), identical(years, 1970:2023), identical(ages, 1:9), translated$age_plus_group == 9L, diff --git a/analysis/comp_assessments/tests/test_nefsc_cod_georges_bank_2024_translation.R b/analysis/comp_assessments/tests/test_nefsc_cod_georges_bank_2024_translation.R index a038137e..9c799da5 100644 --- a/analysis/comp_assessments/tests/test_nefsc_cod_georges_bank_2024_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_cod_georges_bank_2024_translation.R @@ -1,5 +1,5 @@ source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() record <- read_assessment("nefsc_cod_georges_bank_2024", database) original <- record for (fit in c(FALSE, TRUE)) { @@ -12,7 +12,7 @@ for (fit in c(FALSE, TRUE)) { is.null(stock$env$retry_start), is.null(stock$env$start_par), identical(record, original)) result <- run_assessment("nefsc_cod_georges_bank_2024", database, - fit = fit, dashboard = TRUE, cache = FALSE) + fit = fit, cache = FALSE) stopifnot(result$diagnostics$status == "translation_failed", is.null(result$fit), is.null(result$obs), is.null(result$ref), is.null(result$summary), is.null(result$differences), diff --git a/analysis/comp_assessments/tests/test_nefsc_gom_cod_2021_translation.R b/analysis/comp_assessments/tests/test_nefsc_gom_cod_2021_translation.R index 95a5114e..a186663e 100644 --- a/analysis/comp_assessments/tests/test_nefsc_gom_cod_2021_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_gom_cod_2021_translation.R @@ -10,7 +10,7 @@ stopifnot( is.null(stock$env$fit), identical(as.integer(stock$env$years), 1982:2019), identical(as.integer(stock$env$ages), 1:9), - tinyAM::check_obs(result$obs), + tinyAM::check_tam_data(result$obs), nrow(result$obs$catch) == 38L * 9L, nrow(result$obs$weight) == 38L * 9L, nrow(result$obs$maturity) == 38L * 9L, diff --git a/analysis/comp_assessments/tests/test_nefsc_scup_translation.R b/analysis/comp_assessments/tests/test_nefsc_scup_translation.R index c3965f8f..24e1dcf6 100644 --- a/analysis/comp_assessments/tests/test_nefsc_scup_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_scup_translation.R @@ -45,7 +45,7 @@ ssb_check <- ssb$value[!is.na(ssb$year) & ssb$year == 2014 & ssb_age == 3] stopifnot( identical(x$diagnostics$status, "not_fitted"), is.null(x$fit), - isTRUE(tinyAM::check_obs(x$obs)), + isTRUE(tinyAM::check_tam_data(x$obs)), nrow(biomass) == 31L * 8L, nrow(ssb) == 31L * 8L, identical(sort(unique(as.integer(biomass$year))), 1984:2014), diff --git a/analysis/comp_assessments/tests/test_nefsc_snema_yellowtail_source.R b/analysis/comp_assessments/tests/test_nefsc_snema_yellowtail_source.R index 28ff3042..5ef1ec4d 100644 --- a/analysis/comp_assessments/tests/test_nefsc_snema_yellowtail_source.R +++ b/analysis/comp_assessments/tests/test_nefsc_snema_yellowtail_source.R @@ -20,7 +20,7 @@ x <- framework$inputs catch <- x[x$type == "catch", ] stopifnot(nrow(catch) == 300, all(catch$unit == "thousand fish"), identical(sort(unique(catch$year)), 1973:2022), - identical(sort(unique(catch$age)), 1:6), + isTRUE(all.equal(sort(unique(catch$age)), 1:6, tolerance = 0)), sum(is.na(catch$value)) == 18, all(is.na(catch$value[catch$year >= 2020])), catch$value[catch$year == 1975 & catch$age == 1] == 8037, @@ -35,16 +35,16 @@ spring <- indices[indices$season == "spring", ] fall <- indices[indices$season == "fall", ] winter <- indices[indices$season == "winter", ] stopifnot(identical(sort(unique(spring$year)), setdiff(1968:2022, 2020L)), - identical(sort(unique(spring$age)), 0:11), + isTRUE(all.equal(sort(unique(spring$age)), 0:11, tolerance = 0)), spring$value[spring$year == 1968 & spring$age == 3] == 47.65, spring$value[spring$year == 2004 & spring$age == 7] == .019, identical(sort(unique(fall$year)), setdiff(1963:2022, c(2017L, 2020L))), - identical(sort(unique(fall$age)), 1:10), + isTRUE(all.equal(sort(unique(fall$age)), 1:10, tolerance = 0)), fall$value[fall$year == 1984 & fall$age == 4] == 1.865, fall$value[fall$year == 1997 & fall$age == 4] == 1.459, all(grepl("incomplete age-length key", fall$notes[fall$year == 2013 & fall$age %in% c(2:7, 9)])), identical(sort(unique(winter$year)), 1992:2007), - identical(sort(unique(winter$age)), 1:8), + isTRUE(all.equal(sort(unique(winter$age)), 1:8, tolerance = 0)), winter$value[winter$year == 2006 & winter$age == 2] == 18.736, winter$value[winter$year == 1996 & winter$age == 8] == .015, any(indices$value == 0), !anyNA(indices$value)) @@ -69,7 +69,7 @@ stopifnot(nrow(cv) == 240, all(is.na(cv$age)), all(cv$basis == "relative_scale") !any(x$type %in% c("weight", "maturity")), all(is.na(x$year[x$type == "M"])), all(is.na(x$year_basis[x$type == "M"])), - identical(x$age[x$type == "M"], 1:6), + isTRUE(all.equal(x$age[x$type == "M"], 1:6, tolerance = 0)), identical(x$value[x$type == "M"], c(.97, .45, .37, .34, .33, .33)), all(x$unit[x$type == "M"] == "per year"), all(grepl("ages 6 and 7", x$notes[x$type == "M"], fixed = TRUE)), @@ -126,24 +126,5 @@ for (id in c(framework$assessment$assessment_id, update$assessment$assessment_id blocked <- run_assessment(id, fit = FALSE) stopifnot(blocked$diagnostics$status == "blocked_no_stock_spec", is.null(blocked$fit)) } -validate_in_memory <- function(tables) { - env <- new.env(parent = globalenv()) - env$read.csv <- function(file, ...) tables[[sub(".csv", "", basename(file), fixed = TRUE)]] - tryCatch({ - invisible(capture.output(sys.source(file.path(saio_path(), "scripts", "database", "002_validate_database.R"), envir = env))) - NULL - }, error = identity) -} -at <- which(db$inputs$assessment_id == framework$assessment$assessment_id & - db$inputs$measure == "biomass_index_cv" & db$inputs$season == "spring" & db$inputs$year == 2022) -stopifnot(length(at) == 1L) -wrong <- db -wrong$inputs$age[at] <- 2L -error <- validate_in_memory(wrong) -stopifnot(inherits(error, "error"), grepl("without an age", conditionMessage(error), fixed = TRUE)) -wrong <- db -wrong$inputs <- wrong$inputs[!(wrong$inputs$assessment_id == framework$assessment$assessment_id & - wrong$inputs$measure == "total_biomass" & wrong$inputs$season == "spring" & wrong$inputs$year == 2022), ] -error <- validate_in_memory(wrong) -stopifnot(inherits(error, "error"), grepl("corresponding total_biomass", conditionMessage(error), fixed = TRUE)) +# Canonical schema rejection tests run in SAIO, which owns its validator. cat("SNEMA yellowtail source tables, selected-run separation, units, missing values and unresolved translation gaps passed.\n") diff --git a/analysis/comp_assessments/tests/test_nefsc_summer_flounder_translation.R b/analysis/comp_assessments/tests/test_nefsc_summer_flounder_translation.R index ecc7041a..f0ddb1dd 100644 --- a/analysis/comp_assessments/tests/test_nefsc_summer_flounder_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_summer_flounder_translation.R @@ -27,7 +27,7 @@ expected_catch <- published_catch$value[match( )] stopifnot( - tinyAM::check_obs(translated$obs), + tinyAM::check_tam_data(translated$obs), identical(translated$years, 1982:2016), identical(translated$ages, 0:7), nrow(translated$obs$catch) == 35L * 8L, diff --git a/analysis/comp_assessments/tests/test_nefsc_white_hake_2025_translation.R b/analysis/comp_assessments/tests/test_nefsc_white_hake_2025_translation.R index e798c0c1..89715811 100644 --- a/analysis/comp_assessments/tests/test_nefsc_white_hake_2025_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_white_hake_2025_translation.R @@ -1,7 +1,7 @@ pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -database <- read_database(tier = "preliminary") +database <- read_database() source_before <- read_assessment("nefsc_white_hake_2025", database) result <- run_assessment("nefsc_white_hake_2025", database, fit = FALSE, silent = TRUE) obs <- result$obs @@ -60,7 +60,7 @@ stopifnot( stopifnot( result$diagnostics$status == "not_fitted", inherits(obs, "list"), - tinyAM::check_obs(obs), + tinyAM::check_tam_data(obs), isTRUE(all.equal(as.numeric(sort(unique(obs$weight$year))), 1963:2024)), isTRUE(all.equal(as.numeric(sort(unique(obs$weight$age))), 1:9)), nrow(obs$weight) == 62L * 9L, diff --git a/analysis/comp_assessments/tests/test_nefsc_winter_flounder_translation.R b/analysis/comp_assessments/tests/test_nefsc_winter_flounder_translation.R index a25f532b..648db69b 100644 --- a/analysis/comp_assessments/tests/test_nefsc_winter_flounder_translation.R +++ b/analysis/comp_assessments/tests/test_nefsc_winter_flounder_translation.R @@ -2,14 +2,14 @@ source("analysis/comp_assessments/tests/helper_stock.R") root <- file.path("analysis", "comp_assessments") source(file.path(root, "R", "run_assessment.R")) -database <- read_database(tier = "preliminary") +database <- read_database() source_data <- read_assessment("nefsc_winter_flounder_gb_2022_vpa", database) original_inputs <- source_data$inputs translated <- .test_stock(source_data) obs <- translated$obs index <- obs$index -tinyAM::check_obs(obs) +tinyAM::check_tam_data(obs) stopifnot( identical(translated$years, 1982:2021), diff --git a/analysis/comp_assessments/tests/test_pacific_M_priors.R b/analysis/comp_assessments/tests/test_pacific_M_priors.R index ec776e5e..299338ae 100644 --- a/analysis/comp_assessments/tests/test_pacific_M_priors.R +++ b/analysis/comp_assessments/tests/test_pacific_M_priors.R @@ -5,16 +5,6 @@ for (id in "joint_hake_coastal_2025") { record <- read_assessment(id, database) original <- record spec <- .test_stock(record) - baseline_script <- tempfile(fileext = ".R") - status <- system2("git", c("show", shQuote(paste0( - "86e44bf:analysis/comp_assessments/scripts/translation/stocks/", id, ".R" - ))), stdout = baseline_script) - stopifnot(status == 0) - baseline <- .test_stock(record, script = baseline_script) - unlink(baseline_script) - for (table in c("catch", "index", "weight", "maturity")) { - stopifnot(identical(spec$obs[[table]], baseline$obs[[table]])) - } stopifnot(attr(spec$obs, "translation")$M$status != "fixed_numerical_input") dat <- spec$dat par <- tinyAM::make_par(dat) @@ -31,7 +21,7 @@ for (id in "joint_hake_coastal_2025") { } center <- exp(unique(dat$log_mu_supplied_m)) stopifnot(abs(log(center) + 1.60944) < 1e-12, term$sd == .1, - !"mu_m" %in% names(spec$retry_start())) + is.null(spec$retry_start)) } cat("One shared M level receives one fixed-SD Gaussian penalty; source prior scales and input preservation passed.\n") diff --git a/analysis/comp_assessments/tests/test_plot_stock_order.R b/analysis/comp_assessments/tests/test_plot_stock_order.R index bb137e57..1c3792e6 100644 --- a/analysis/comp_assessments/tests/test_plot_stock_order.R +++ b/analysis/comp_assessments/tests/test_plot_stock_order.R @@ -1,9 +1,9 @@ source("analysis/comp_assessments/R/plot_stock_order.R") source("analysis/comp_assessments/R/run_assessment.R") root <- "analysis/comp_assessments" -revision <- .saio_revision() -assessments <- .saio_read_table("assessments.csv", revision = revision) -stocks <- .saio_read_table("stocks.csv", revision = revision) +database <- read_database() +assessments <- database$assessments +stocks <- database$stocks ids <- intersect(assessment_translations("curated")$assessment_id, assessments$assessment_id) info <- assessment_plot_stocks(assessments, stocks, ids) stopifnot(nrow(info) == length(ids), !anyDuplicated(info$assessment_id), diff --git a/analysis/comp_assessments/tests/test_run_assessment.R b/analysis/comp_assessments/tests/test_run_assessment.R index fd9fabd6..88019bae 100644 --- a/analysis/comp_assessments/tests/test_run_assessment.R +++ b/analysis/comp_assessments/tests/test_run_assessment.R @@ -5,9 +5,9 @@ source(file.path(root, "R", "run_assessment.R")) result <- run_assessment("dfo_cod_2j3kl_2025", fit = FALSE) stopifnot( result$source$assessment$assessment_id == "dfo_cod_2j3kl_2025", - result$source$database_source == "saio_committed", - result$source$database_selection == "latest_main", - result$source$commit == .saio_revision(), + result$source$database_source == "saio_snapshot", + result$source$database_selection == "cached_snapshot", + result$source$commit == .assessment_snapshot(), is.data.frame(result$obs$catch), is.data.frame(result$obs$index), is.data.frame(result$audit), diff --git a/analysis/comp_assessments/tests/test_run_assessments.R b/analysis/comp_assessments/tests/test_run_assessments.R index 413ee3cf..679da404 100644 --- a/analysis/comp_assessments/tests/test_run_assessments.R +++ b/analysis/comp_assessments/tests/test_run_assessments.R @@ -39,7 +39,9 @@ stopifnot( "assessment_id" %in% names(attr(serial, "comparison_summary")) ) -previous_plan <- future::plan("list")[[1L]] +previous_plan <- future::plan() +future::plan(future::multisession, workers = 2) +configured_plan <- future::plan("list")[[1L]] previous_workers <- future::nbrOfWorkers() shared_outputs <- file.path(.assessment_results("curated"), c( "fit_diagnostics.csv", "comparison_summary.csv" @@ -48,14 +50,14 @@ shared_outputs_existed <- file.exists(shared_outputs) cache_existed <- dir.exists(file.path(.assessment_results("curated"), "cache")) parallel <- run_assessments( assessment_ids, - database = database, parallel = TRUE, workers = 2, + database = database, fit = FALSE ) stopifnot( identical(names(parallel), assessment_ids), identical( attr(future::plan("list")[[1L]], "call"), - attr(previous_plan, "call") + attr(configured_plan, "call") ), future::nbrOfWorkers() == previous_workers, identical(file.exists(shared_outputs), shared_outputs_existed), @@ -72,7 +74,7 @@ bad_database$inputs <- bad_database$inputs[ ] failed <- run_assessments( c("dfo_cod_2j3kl_2025", "ices_cod_north_sea_2025"), - database = bad_database, parallel = TRUE, workers = 2, fit = FALSE + database = bad_database, fit = FALSE ) goa <- run_assessments("afsc_cod_goa_2026", database = database, @@ -85,4 +87,5 @@ stopifnot( !is.null(goa$afsc_cod_goa_2026$obs) ) +future::plan(previous_plan) cat("Multi-assessment runner tests passed.\n") diff --git a/analysis/comp_assessments/tests/test_saio_migration.R b/analysis/comp_assessments/tests/test_saio_migration.R index f983a838..4db513a6 100644 --- a/analysis/comp_assessments/tests/test_saio_migration.R +++ b/analysis/comp_assessments/tests/test_saio_migration.R @@ -1,20 +1,14 @@ -source("analysis/comp_assessments/R/read_database.R") source("analysis/comp_assessments/R/run_assessment.R") - +source("analysis/comp_assessments/R/update_database_cache.R") registry <- assessment_translations() stopifnot(all(file.exists(registry$script)), !anyDuplicated(paste(registry$assessment_id, registry$tier)), - nrow(assessment_translations("curated")) == 35L, - !anyNA(.saio_read_table("stocks.csv")$stock_id), - identical(.database_head(saio_path(), "refs/heads/main"), .saio_revision()), - identical(.saio_revision("curated"), .saio_revision("preliminary"))) + nrow(assessment_translations("curated")) == 35L) local({ original_wd <- getwd() - fixture <- tempfile("saio_migration_") + fixture <- tempfile("saio_snapshot_") dir.create(fixture) - stopifnot(startsWith(normalizePath(fixture, winslash = "/"), - normalizePath(tempdir(), winslash = "/"))) on.exit({setwd(original_wd); unlink(fixture, recursive = TRUE)}, add = TRUE) relative_root <- file.path("analysis", "comp_assessments") dir.create(file.path(fixture, relative_root, "R"), recursive = TRUE) @@ -31,86 +25,60 @@ local({ stocks <- data.frame(stock_id = "source_stock", scientific_name = "Source species") assessments <- data.frame(assessment_id = c("shared", "extra"), stock_id = "source_stock", is_current = c(FALSE, TRUE)) - assumptions <- data.frame(assessment_id = assessments$assessment_id, - component = "population", setting = "age_range", value = "1-2", - source_reference = "fixture", notes = "fixture") tables <- list(stocks = stocks, assessments = assessments, - assumptions = assumptions, + assumptions = data.frame(assessment_id = assessments$assessment_id, + component = "population", setting = "age_range", value = "1-2", + source_reference = "fixture", notes = "fixture"), inputs = data.frame(assessment_id = assessments$assessment_id), outputs = data.frame(assessment_id = assessments$assessment_id)) for (name in names(tables)) write.csv(tables[[name]], file.path("data_repo/database", paste0(name, ".csv")), row.names = FALSE) git("init", "-b", "main") git("add", "database") - git("-c", "user.name=MigrationTest", "-c", "user.email=migration@example.invalid", - "-c", "commit.gpgsign=false", "commit", "-m", "fixture") + commit <- function(text) git("-c", "user.name=SnapshotTest", "-c", "user.email=snapshot@example.invalid", + "-c", "commit.gpgsign=false", "commit", "-m", text) + commit("fixture") revision <- git("rev-parse", "HEAD")[[1]] - stocks$scientific_name <- "Uncommitted replacement" - write.csv(stocks, "data_repo/database/stocks.csv", row.names = FALSE) - source(file.path(relative_root, "R", "read_database.R")) - original_options <- options(tinyAM.saio_path = normalizePath("data_repo", winslash = "/")) - on.exit(options(original_options), add = TRUE) - pinned <- read_committed_database(revision, repo = "data_repo") - latest <- read_database() - latest_preliminary <- read_database(tier = "preliminary") - working <- read_database("data_repo/database") + update_database_cache("data_repo") + pinned <- read_database() stopifnot(pinned$stocks$scientific_name == "Source species", - latest$stocks$scientific_name == "Source species", - identical(latest$commit, latest_preliminary$commit), - latest$database_selection == "latest_main", - latest$database_ref == "refs/heads/main", - pinned$database_selection == "explicit_revision", - working$stocks$scientific_name == "Uncommitted replacement", - grepl("^working-[[:xdigit:]]{32}$", working$database_key), - identical(read_database("data_repo/database")$database_key, working$database_key), - identical(pinned$commit, revision)) - stocks$scientific_name <- "Another uncommitted value" - write.csv(stocks, "data_repo/database/stocks.csv", row.names = FALSE) - stopifnot(read_database("data_repo/database")$database_key != working$database_key, - read_database()$stocks$scientific_name == "Source species") - stocks$scientific_name <- "Uncommitted replacement" - write.csv(stocks, "data_repo/database/stocks.csv", row.names = FALSE) - git("switch", "-c", "experiment") - git("add", "database") - git("-c", "user.name=MigrationTest", "-c", "user.email=migration@example.invalid", - "-c", "commit.gpgsign=false", "commit", "-m", "experiment") - experimental <- git("rev-parse", "HEAD")[[1]] - stopifnot(read_database()$stocks$scientific_name == "Source species", - read_database(revision = experimental)$stocks$scientific_name == "Uncommitted replacement") - git("switch", "main") - git("update-ref", "refs/remotes/origin/main", revision) - stocks$scientific_name <- "Latest committed main" + pinned$commit == revision, pinned$database_selection == "cached_snapshot") + # Reading remains local and stable when upstream data advance or Git is unavailable. + stocks$scientific_name <- "New committed species" write.csv(stocks, "data_repo/database/stocks.csv", row.names = FALSE) - git("add", "database") - git("-c", "user.name=MigrationTest", "-c", "user.email=migration@example.invalid", - "-c", "commit.gpgsign=false", "commit", "-m", "advance main") + stopifnot(read_database()$stocks$scientific_name == "Source species") + git("add", "database"); commit("new data") + stopifnot(read_database()$commit == revision) + update_database_cache("data_repo") current <- read_database() - stopifnot(current$stocks$scientific_name == "Latest committed main", - current$commit != revision, current$database_key == current$commit, - read_database(revision = revision)$stocks$scientific_name == "Source species") - git("update-ref", "refs/remotes/origin/main", experimental) - divergent <- tryCatch(read_database(), error = identity) - stopifnot(inherits(divergent, "error"), grepl("behind or diverged", conditionMessage(divergent), fixed = TRUE), - read_database(revision = revision)$stocks$scientific_name == "Source species") - git("update-ref", "refs/remotes/origin/main", revision) - git("switch", "-c", "remote-ahead") - stocks$scientific_name <- "Remote main ahead" - write.csv(stocks, "data_repo/database/stocks.csv", row.names = FALSE) - git("add", "database") - git("-c", "user.name=MigrationTest", "-c", "user.email=migration@example.invalid", - "-c", "commit.gpgsign=false", "commit", "-m", "remote main") - remote_ahead <- git("rev-parse", "HEAD")[[1]] - git("switch", "main") - git("update-ref", "refs/remotes/origin/main", remote_ahead) - behind <- tryCatch(read_database(), error = identity) - stopifnot(inherits(behind, "error"), grepl("behind or diverged", conditionMessage(behind), fixed = TRUE)) - git("update-ref", "refs/remotes/origin/main", revision) - + stopifnot(current$commit != revision, current$stocks$scientific_name == "New committed species", + dir.exists(file.path(relative_root, "cache", "saio", revision))) + # An incomplete source copy cannot change the selected manifest. + writeLines("next source revision", "data_repo/note.txt") + git("add", "note.txt"); commit("copy interruption fixture") + file.rename("data_repo/database/outputs.csv", "data_repo/database/outputs.saved") + selected <- readLines(file.path(relative_root, "saio_revisions.csv")) + copy_error <- suppressWarnings(tryCatch(update_database_cache("data_repo"), error = identity)) + stopifnot(inherits(copy_error, "error"), + identical(readLines(file.path(relative_root, "saio_revisions.csv")), selected), + identical(read_database()$commit, current$commit)) + file.rename("data_repo/database/outputs.saved", "data_repo/database/outputs.csv") + rename <- file.rename("data_repo", "hidden_source") + original_head <- .database_head + .database_head <- function(...) stop("Reader must not invoke Git") + stopifnot(rename, identical(read_database()$commit, current$commit)) + .database_head <- original_head + # A missing copy gives the manual-refresh instruction. + path <- file.path(relative_root, "cache", "saio", current$commit, "database.rds") + file.rename(path, paste0(path, ".saved")) + bad <- tryCatch(read_database(), error = identity) + stopifnot(inherits(bad, "error"), grepl("unavailable or incomplete", conditionMessage(bad))) + file.rename(paste0(path, ".saved"), path) entries <- data.frame(assessment_id = c("shared", "shared", "extra"), tier = c("curated", "preliminary", "preliminary"), source_commit = revision) write.csv(entries, file.path(relative_root, "translations.csv"), row.names = FALSE) for (tier in c("curated", "preliminary")) { - folder <- file.path(relative_root, "scripts", "translation", tier) + folder <- file.path(relative_root, "scripts", tier) dir.create(folder, recursive = TRUE) for (id in entries$assessment_id[entries$tier == tier]) writeLines(c( paste0('obs <- list(marker = "', tier, '")'), @@ -138,7 +106,7 @@ local({ stopifnot(is.null(.assessment_cached_fit("shared", "curated", current)), .assessment_cached_fit("shared", "curated", pinned)$marker == "historical", current_cache != historical_cache, - .assessment_cache_key(working) != .assessment_cache_key(current)) + .assessment_cache_key(pinned) != .assessment_cache_key(current)) dir.create(current_cache, recursive = TRUE) saveRDS(old_fit, file.path(current_cache, "fit.rds")) mismatched <- tryCatch(.assessment_cached_fit("shared", "curated", current), error = identity) @@ -186,7 +154,7 @@ local({ dir.create(cache, recursive = TRUE, showWarnings = FALSE) writeLines("Cached dashboard", file.path(cache, "dashboard.html")) } - index_assessment_dashboards(tier, current) + .index_assessment_dashboards(tier, current) } curated_index <- readLines(file.path(.assessment_results("curated"), "index.html")) preliminary_index <- readLines(file.path(.assessment_results("preliminary"), "index.html")) @@ -200,4 +168,4 @@ local({ !any(grepl("/experiments/", curated_index, fixed = TRUE)), !any(grepl("/experiments/", preliminary_index, fixed = TRUE))) }) -cat("Latest committed SAIO reads, explicit snapshots, source-keyed caches, tier dispatch and provenance regression checks passed.\n") +cat("Manual SAIO snapshots, stable local reads, tier dispatch and source-keyed cache checks passed.\n") diff --git a/analysis/comp_assessments/tests/test_sandeel_area_1r_source.R b/analysis/comp_assessments/tests/test_sandeel_area_1r_source.R index a57a8699..d2bba1a8 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_1r_source.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_1r_source.R @@ -1,7 +1,7 @@ source("analysis/comp_assessments/R/read_database.R") pkgload::load_all(".", quiet = TRUE) source("analysis/comp_assessments/R/run_assessment.R") -db <- read_database(tier = "preliminary") +db <- read_database() source <- read_assessment("ices_sandeel_area_1r_2026", db) stopifnot(source$stocks$stock_id == "ices_sandeel_area_1r", is.na(source$stocks$charbonneau_id), source$stocks$authority_stock_id == "san.sa.1r", @@ -69,20 +69,4 @@ stopifnot(abs(exp(mean(log(recruits$value))) - 111219266) < 1, stopifnot(grepl("surveySD/catchSD/estSD", source$assumptions$notes[ source$assumptions$setting == "remaining_sources"], fixed = TRUE)) -validate_seasonal_fixture <- function(tables) { - env <- new.env(parent = globalenv()) - env$read.csv <- function(file, ...) tables[[sub(".csv", "", basename(file), fixed = TRUE)]] - tryCatch({ - invisible(capture.output(sys.source( - file.path(saio_path(), "scripts", "database", "002_validate_database.R"), envir = env))) - NULL - }, error = identity) -} -at <- which(db$inputs$assessment_id == source$assessment$assessment_id & db$inputs$type == "M")[1L] -for (field in c("type", "season")) { - wrong <- db - wrong$inputs[[field]][at] <- if (field == "type") "weight" else NA_character_ - error <- validate_seasonal_fixture(wrong) - stopifnot(inherits(error, "error"), grepl("M-at-age and a source season", conditionMessage(error), fixed = TRUE)) -} -cat("Seasonal mortality validation rejects other input types and missing source seasons.\n") +# Canonical schema rejection tests run in SAIO, which owns its validator. diff --git a/analysis/comp_assessments/tests/test_sandeel_area_1r_translation.R b/analysis/comp_assessments/tests/test_sandeel_area_1r_translation.R index 57974d2c..fb8e88da 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_1r_translation.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_1r_translation.R @@ -7,7 +7,7 @@ obs <- x$obs dat <- x$dat stopifnot(identical(source_record, before), is.null(x$fit), identical(x$years, 1983:2025), identical(x$ages, 1:4), - tinyAM::check_obs(obs), nrow(obs$catch) == 172L, nrow(obs$index) == 43L, + tinyAM::check_tam_data(obs), nrow(obs$catch) == 172L, nrow(obs$index) == 43L, all(obs$catch$unit == "thousand fish"), obs$catch$obs[obs$catch$year == 1983 & obs$catch$age == 2] == (28971 + 3085) * 1000, all(obs$index$age >= 1), sum(obs$index$survey == "Dredge") == 22L, @@ -58,7 +58,7 @@ stopifnot(all(ref$pop$recruitment$est == n$value[match(ref$pop$recruitment$year, all(attr(ref, "native_pop")$recruitment$age == 0)) cat("Sandeel annual catch/M aggregation, January biology, original indices, settings and same-year recruitment passed.\n") source("analysis/comp_assessments/R/plot_stock_order.R") -metadata <- assessment_plot_stocks(read_database(tier = "preliminary")$assessments, read_database(tier = "preliminary")$stocks, +metadata <- assessment_plot_stocks(read_database()$assessments, read_database()$stocks, source_record$assessment$assessment_id) stopifnot(nrow(metadata) == 1L, metadata$scientific_name == "Ammodytes spp.", as.character(metadata$basin) == "Northeast Atlantic") diff --git a/analysis/comp_assessments/tests/test_sandeel_area_2r_source.R b/analysis/comp_assessments/tests/test_sandeel_area_2r_source.R index 134cf0c6..c6a4ea1c 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_2r_source.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_2r_source.R @@ -1,5 +1,5 @@ source("analysis/comp_assessments/R/run_assessment.R") -db <- read_database(tier = "preliminary") +db <- read_database() s <- read_assessment("ices_sandeel_area_2r_2026", db) i <- s$inputs; o <- s$outputs stopifnot(s$stocks$authority_stock_id == "san.sa.2r", is.na(s$stocks$charbonneau_id), diff --git a/analysis/comp_assessments/tests/test_sandeel_area_2r_translation.R b/analysis/comp_assessments/tests/test_sandeel_area_2r_translation.R index 29ec8ec5..8d11e9a0 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_2r_translation.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_2r_translation.R @@ -7,7 +7,7 @@ obs <- x$obs dat <- x$dat stopifnot(identical(source_record, before), is.null(x$fit), identical(x$years, 1983:2025), identical(x$ages, 1:4), - tinyAM::check_obs(obs), nrow(obs$catch) == 172L, nrow(obs$index) == 22L, + tinyAM::check_tam_data(obs), nrow(obs$catch) == 172L, nrow(obs$index) == 22L, all(obs$catch$unit == "thousand fish"), obs$catch$obs[obs$catch$year == 1983 & obs$catch$age == 2] == (6191 + 877) * 1000, all(obs$index$age >= 1), sum(obs$index$survey == "Dredge") == 22L, @@ -22,7 +22,7 @@ stopifnot(identical(source_record, before), is.null(x$fit), expected <- c("1983" = "early.1", "1998" = "early.1", "1999" = "middle1.1", "2004" = "middle1.1", "2005" = "middle2.1", "2009" = "middle2.1", "2010" = "recent.1", "2025" = "recent.1") -young <- obs$pop_covariates[obs$pop_covariates$age == 1, ] +young <- obs$catch[obs$catch$age == 1, ] stopifnot(identical(as.character(young$F_mean_group[ match(as.integer(names(expected)), young$year)]), unname(expected))) diff --git a/analysis/comp_assessments/tests/test_sandeel_area_3r_source.R b/analysis/comp_assessments/tests/test_sandeel_area_3r_source.R index dd9051d9..49dd924e 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_3r_source.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_3r_source.R @@ -1,5 +1,5 @@ source("analysis/comp_assessments/R/run_assessment.R") -db <- read_database(tier = "preliminary") +db <- read_database() s <- read_assessment("ices_sandeel_area_3r_2026", db) i <- s$inputs; o <- s$outputs stopifnot(s$stocks$authority_stock_id == "san.sa.3r", is.na(s$stocks$charbonneau_id), diff --git a/analysis/comp_assessments/tests/test_sandeel_area_3r_translation.R b/analysis/comp_assessments/tests/test_sandeel_area_3r_translation.R index 1a797cae..49ac4caa 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_3r_translation.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_3r_translation.R @@ -5,7 +5,7 @@ before <- source_record x <- .test_stock(source_record) obs <- x$obs; dat <- x$dat stopifnot(identical(source_record, before), is.null(x$fit), - identical(x$years, 1987:2025), identical(x$ages, 1:4), tinyAM::check_obs(obs), + identical(x$years, 1987:2025), identical(x$ages, 1:4), tinyAM::check_tam_data(obs), nrow(obs$catch) == 156L, nrow(obs$index) == 88L, all(obs$catch$unit == "thousand fish"), obs$catch$obs[obs$catch$year == 1987 & obs$catch$age == 1] == (33760 + 65) * 1000, diff --git a/analysis/comp_assessments/tests/test_sandeel_area_4_source.R b/analysis/comp_assessments/tests/test_sandeel_area_4_source.R index eb9df0e5..1bfdc1e8 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_4_source.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_4_source.R @@ -1,5 +1,5 @@ source("analysis/comp_assessments/R/run_assessment.R") -db <- read_database(tier = "preliminary") +db <- read_database() s <- read_assessment("ices_sandeel_area_4_2025", db) i <- s$inputs; o <- s$outputs stopifnot(s$stocks$authority_stock_id == "san.sa.4", is.na(s$stocks$charbonneau_id), diff --git a/analysis/comp_assessments/tests/test_sandeel_area_4_translation.R b/analysis/comp_assessments/tests/test_sandeel_area_4_translation.R index 9a7d20dd..61d29f49 100644 --- a/analysis/comp_assessments/tests/test_sandeel_area_4_translation.R +++ b/analysis/comp_assessments/tests/test_sandeel_area_4_translation.R @@ -4,7 +4,7 @@ s <- read_assessment("ices_sandeel_area_4_2025") before <- s x <- .test_stock(s) obs <- x$obs; dat <- x$dat -stopifnot(identical(s, before), is.null(x$fit), tinyAM::check_obs(obs), +stopifnot(identical(s, before), is.null(x$fit), tinyAM::check_tam_data(obs), identical(x$years, 1993:2024), identical(x$ages, 1:4), nrow(obs$catch) == 128L, nrow(obs$index) == 42L, all(obs$catch$unit == "thousand fish"), all(obs$index$age == 1), diff --git a/analysis/comp_assessments/tests/test_stock_scripts.R b/analysis/comp_assessments/tests/test_stock_scripts.R index b46887a8..4f16d734 100644 --- a/analysis/comp_assessments/tests/test_stock_scripts.R +++ b/analysis/comp_assessments/tests/test_stock_scripts.R @@ -37,7 +37,7 @@ stopifnot(!exists("warm_fit", inherits = FALSE)) # Run the interactive setup with fitting disabled, in a separate workspace. interactive_env <- new.env(parent = globalenv()) -for (statement in parse("analysis/comp_assessments/scripts/translation/run_stock.R")) { +for (statement in parse("analysis/comp_assessments/scripts/run_stock.R")) { if (is.call(statement) && identical(statement[[1]], quote(`<-`)) && identical(statement[[2]], quote(do_fit))) { statement[[3]] <- FALSE @@ -53,7 +53,7 @@ cat("Top-level stock scripts and fitting-disabled isolation passed.\n") # Loading another stock must clear absent comparison options, including in the workspace. interactive_env$comparison_age_groups <- list(N = list(stale = 999)) -for (statement in parse("analysis/comp_assessments/scripts/translation/run_stock.R")) { +for (statement in parse("analysis/comp_assessments/scripts/run_stock.R")) { if (is.call(statement) && identical(statement[[1]], quote(`<-`))) { if (identical(statement[[2]], quote(do_fit))) statement[[3]] <- FALSE if (identical(statement[[2]], quote(assessment_id))) statement[[3]] <- "afsc_cod_goa_2026" diff --git a/analysis/comp_assessments/tests/test_translation.R b/analysis/comp_assessments/tests/test_translation.R index 7d5f8bd9..2ae53ee9 100644 --- a/analysis/comp_assessments/tests/test_translation.R +++ b/analysis/comp_assessments/tests/test_translation.R @@ -2,7 +2,7 @@ source("analysis/comp_assessments/R/read_database.R") pkgload::load_all(".", quiet = TRUE) root <- file.path("analysis", "comp_assessments") source(file.path(root, "R", "database_to_tam_obs.R")) -check_obs <- tinyAM::check_obs +check_tam_data <- tinyAM::check_tam_data source(file.path(root, "R", "audit_assumptions.R")) if (!requireNamespace("cli", quietly = TRUE)) { .translation_abort <- function(message) stop(message, call. = FALSE) @@ -469,7 +469,8 @@ expect_equal( ) expect_equal(fixed_m_inputs, fixed_m_inputs_before) -read_table <- function(name) .saio_read_table(name) +database <- read_database() +read_table <- function(name) database[[sub("[.]csv$", "", name)]] assumptions_db <- read_table("assumptions.csv") inputs_db <- read_table("inputs.csv") audit <- audit_assumptions("dfo_cod_4t4vn_2019", assumptions_db) @@ -621,11 +622,9 @@ expect_equal(herring_inputs, herring_before) expect_equal(sum(is.na(herring_obs$catch$obs)), 18L) source(file.path(root, "R", "read_database.R")) -working_db <- read_database() -db <- read_committed_database() -expect_equal(working_db$database_source, "saio_committed") -expect_equal(db$database_source, "saio_committed") -expect_equal(grepl("^[[:xdigit:]]{40}$", working_db$commit), TRUE) +db <- read_database() +expect_equal(db$database_source, "saio_snapshot") +expect_equal(grepl("^[[:xdigit:]]{40}$", db$commit), TRUE) fixture_dir <- tempfile("assessment_database_") dir.create(fixture_dir) @@ -633,12 +632,14 @@ database_files <- c( "stocks.csv", "assessments.csv", "assumptions.csv", "inputs.csv", "outputs.csv" ) -for (name in database_files) { - write.csv(data.frame(source_file = name), file.path(fixture_dir, name), - row.names = FALSE - ) -} -fixture_db <- read_database(fixture_dir) +fixture_revision <- paste(rep("f", 40), collapse = "") +dir.create(file.path(fixture_dir, fixture_revision)) +fixture_tables <- setNames(lapply(database_files, function(name) + data.frame(source_file = name)), sub("[.]csv$", "", database_files)) +saveRDS(fixture_tables, file.path(fixture_dir, fixture_revision, "database.rds")) +fixture_manifest <- file.path(fixture_dir, "saio_revisions.csv") +write.csv(data.frame(revision = fixture_revision), fixture_manifest, row.names = FALSE) +fixture_db <- read_database(fixture_dir, fixture_manifest) expect_equal( unname(vapply( fixture_db[c( @@ -650,12 +651,10 @@ expect_equal( database_files ) -working_ebs <- read_assessment("afsc_pollock_ebs_2024", working_db) -ebs <- read_committed_assessment("afsc_pollock_ebs_2024", database = db) +ebs <- read_assessment("afsc_pollock_ebs_2024", database = db) expect_equal(nrow(ebs$assessment), 1L) expect_equal(all(ebs$inputs$assessment_id == "afsc_pollock_ebs_2024"), TRUE) expect_equal(grepl("^[[:xdigit:]]{40}$", ebs$commit), TRUE) -expect_equal(working_ebs$inputs, ebs$inputs) expect_equal(read_assessment("afsc_pollock_ebs_2024", db)$inputs, ebs$inputs) ebs_surveys <- c( "NMFS bottom-trawl VAST", "NMFS acoustic-trawl", @@ -743,12 +742,12 @@ expect_equal(all(is.na(ebs_reference$obs_pred$catch$pred)), TRUE) expect_equal(all(is.na(ebs_reference$pop$ssb$se_scale)), TRUE) ns_haddock_id <- "ices_haddock_north_sea_2026" -ns_haddock <- read_committed_assessment(ns_haddock_id, database = db) +ns_haddock <- read_assessment(ns_haddock_id, database = db) ns_haddock_obs <- database_to_tam_obs( ns_haddock_id, ns_haddock$inputs, years = 1972:2026, ages = 0:8, assumptions = ns_haddock$assumptions ) -expect_equal(check_obs(ns_haddock_obs), TRUE) +expect_equal(check_tam_data(ns_haddock_obs), TRUE) expect_equal(nrow(ns_haddock_obs$index), 667L) expect_equal(all(is.finite(ns_haddock_obs$index$relative_sd)), TRUE) expect_equal(all(abs(ns_haddock_obs$index$relative_sd^2 * diff --git a/analysis/comp_assessments/translation_notes/ck_ices_afwg_mentella_deep_1_2.md b/analysis/comp_assessments/translation_notes/ck_ices_afwg_mentella_deep_1_2.md index dd7c5725..df30f576 100644 --- a/analysis/comp_assessments/translation_notes/ck_ices_afwg_mentella_deep_1_2.md +++ b/analysis/comp_assessments/translation_notes/ck_ices_afwg_mentella_deep_1_2.md @@ -5,7 +5,7 @@ Transferred from the pre-cleanup SAIO review without refitting. Check the regist ## Limited tinyAM translation The maintained recipe is -[preliminary recipe](../scripts/translation/preliminary/jrn_redfish_beaked_2026.R). It fits 1992–2025 +[preliminary recipe](../scripts/preliminary/jrn_redfish_beaked_2026.R). It fits 1992–2025 at ages 6–19+, using the non-overlapping total catch-at-age series once, fixed M = 0.05, published age-6+ weight and maturity, and the ecosystem and winter number indices for ages 6–15. The million-fish indices are converted diff --git a/analysis/comp_assessments/translation_notes/dfo_cod_3ps_2024.md b/analysis/comp_assessments/translation_notes/dfo_cod_3ps_2024.md index 70545a0a..5c567521 100644 --- a/analysis/comp_assessments/translation_notes/dfo_cod_3ps_2024.md +++ b/analysis/comp_assessments/translation_notes/dfo_cod_3ps_2024.md @@ -4,7 +4,7 @@ Transferred from the pre-cleanup SAIO review without refitting. Check the regist ## tinyAM translation readiness -The translation recipe is in [preliminary recipe](../scripts/translation/preliminary/dfo_cod_3ps_2024.R). It uses reported catch-at-age directly, fits the five index series with independent age-by-survey q values, approximates seasonal timing by within-season midpoints, uses an age-correlated F random walk without the source age-2 separation or 1993 break, and models log M with age-specific levels and separate condition slopes for ages 2–5 and 6+. The N process is now IID to represent independent cohort-survival deviations, with exponential initial abundance. These remain approximations: tinyAM does not reproduce censored zero-index observations, censored landings intervals, continuation-ratio catch composition, the exact condition-to-M relationship, or all HYBRID process structures. Survey index units remain unresolved, with survey-specific q absorbing the reported scale. +The translation recipe is in [preliminary recipe](../scripts/preliminary/dfo_cod_3ps_2024.R). It uses reported catch-at-age directly, fits the five index series with independent age-by-survey q values, approximates seasonal timing by within-season midpoints, uses an age-correlated F random walk without the source age-2 separation or 1993 break, and models log M with age-specific levels and separate condition slopes for ages 2–5 and 6+. The N process is now IID to represent independent cohort-survival deviations, with exponential initial abundance. These remain approximations: tinyAM does not reproduce censored zero-index observations, censored landings intervals, continuation-ratio catch composition, the exact condition-to-M relationship, or all HYBRID process structures. Survey index units remain unresolved, with survey-specific q absorbing the reported scale. The updated recipe first used package-default initialization. Numerical checks failed: `nlminb` returned code 1 (`singular convergence (7)`), with a maximum gradient of 0.000753. The Hessian was positive definite and `sdreport` returned, but the fixed-parameter covariance contained non-finite values. After that failure, one documented retry used the published age-2 recruitment and Fbar estimates for 2020-2024 as starting values only; recruitment was converted from million fish to tinyAM's thousand-fish scale and Fbar initialized ages 5-8 equally. All other parameters retained package defaults, and observations and model settings were unchanged. The retry returned optimizer code 0 (`relative convergence (4)`) and a lower objective of 2100.817, with a maximum gradient of 0.000606, but the fixed-parameter covariance still contained non-finite values. It therefore also failed numerical checks. Both attempts had 80 fixed effects and 1,703 random effects, a positive-definite Hessian, and an advisory that the F-increment age correlation was near its boundary. No converged-fit dashboard was produced; treat both fits and their uncertainty as unavailable. The recipe test verifies the year and age grid, timing, IID N setting, two condition-effect columns, comparison window, and alignment/scale of available source starts. Its observation converter is stubbed, so it does not validate source-to-observation conversion or establish a successful fit. diff --git a/analysis/comp_assessments/translation_notes/dfo_petrale_bc.md b/analysis/comp_assessments/translation_notes/dfo_petrale_bc.md index bc552adb..90d1025e 100644 --- a/analysis/comp_assessments/translation_notes/dfo_petrale_bc.md +++ b/analysis/comp_assessments/translation_notes/dfo_petrale_bc.md @@ -9,7 +9,7 @@ SSB now preserved in the canonical database. Fitting is **source-blocked**. These source gaps must be resolved before preparing a model. There is no catch-only substitute, invented `fit_tam()` model, optimizer result or dashboard. -The stock entry point is now the [curated stock script](../scripts/translation/curated/dfo_petrale_bc_2024.R). It records the source +The stock entry point is now the [curated stock script](../scripts/curated/dfo_petrale_bc_2024.R). It records the source background and stops with the missing-input inventory before `prepare_tam()` or `fit_tam()`, for both `fit = FALSE` and `fit = TRUE`. An explicit runner attempt is recorded as `translation_failed`, with no optimizer or uncertainty diff --git a/analysis/comp_assessments/translation_notes/ices_cod_irish_sea.md b/analysis/comp_assessments/translation_notes/ices_cod_irish_sea.md index e2e6bec7..1806434f 100644 --- a/analysis/comp_assessments/translation_notes/ices_cod_irish_sea.md +++ b/analysis/comp_assessments/translation_notes/ices_cod_irish_sea.md @@ -12,6 +12,6 @@ Index scale multipliers and exact likelihood allocations are unresolved. The nat The default-initialization fit converged (optimizer code 0, maximum gradient 0.000364, positive-definite Hessian). Over 1968–2018, approximate SSB agreement was mean absolute percent difference 36.5%, terminal difference -9.3%, and trend correlation 0.971. Age-0 recruitment agreement was weaker: mean absolute percent difference 61.0%, terminal difference +1568%, and trend correlation 0.731. The simpler recruitment process remains an important limitation; no starting values were supplied. -The comparison period does not include the assessment's terminal 2019–2025 estimates. Official aggregate SSB timing is not stated, while tinyAM calculates beginning-of-year mature biomass, so SSB is approximate. Recruitment is age-aligned but its published point-estimate convention is unspecified, so it is also approximate. Official age-specific N and F are unavailable. Official Fbar is ages 2–4, while tinyAM Fbar is abundance-weighted and the required official N-at-age is unavailable; therefore the Fbar values are not compared. M is fixed at the published input values and shown as an input rather than a fitted output. The maintained translation and structural checks are in [preliminary recipe](../scripts/translation/preliminary/ices_cod_irish_sea_2026.R) and [translation check](../tests/test_irish_sea_cod_translation.R); source values are validated by [SAIO source check](https://github.com/PaulRegular/saio/blob/main/tests/test_irish_sea_cod_source.R). +The comparison period does not include the assessment's terminal 2019–2025 estimates. Official aggregate SSB timing is not stated, while tinyAM calculates beginning-of-year mature biomass, so SSB is approximate. Recruitment is age-aligned but its published point-estimate convention is unspecified, so it is also approximate. Official age-specific N and F are unavailable. Official Fbar is ages 2–4, while tinyAM Fbar is abundance-weighted and the required official N-at-age is unavailable; therefore the Fbar values are not compared. M is fixed at the published input values and shown as an input rather than a fitted output. The maintained translation and structural checks are in [preliminary recipe](../scripts/preliminary/ices_cod_irish_sea_2026.R) and [translation check](../tests/test_irish_sea_cod_translation.R); source values are validated by [SAIO source check](https://github.com/PaulRegular/saio/blob/main/tests/test_irish_sea_cod_source.R). [Official source review](https://github.com/PaulRegular/saio/blob/main/source_reviews/ices_cod_irish_sea.md). diff --git a/analysis/comp_assessments/translation_notes/ices_herring_norwegian_spring_spawning.md b/analysis/comp_assessments/translation_notes/ices_herring_norwegian_spring_spawning.md index d579402b..8f4de44b 100644 --- a/analysis/comp_assessments/translation_notes/ices_herring_norwegian_spring_spawning.md +++ b/analysis/comp_assessments/translation_notes/ices_herring_norwegian_spring_spawning.md @@ -9,7 +9,7 @@ Official assessment evidence is maintained in [SAIO](https://github.com/PaulRegu ### tinyAM translation The current-run approximation is defined in -[preliminary recipe](../scripts/translation/preliminary/ices_herring_norwegian_spring_2026.R). It fits +[preliminary recipe](../scripts/preliminary/ices_herring_norwegian_spring_2026.R). It fits 1988–2025 at ages 2–12, using IID N with free initial abundance, an F random walk, and the standard age-specific M pattern as fixed. Catch and the four numerical survey series are fitted with tinyAM observation errors; SAM's diff --git a/cheatsheet/background.md b/cheatsheet/background.md index b1cd8700..b29c8047 100644 --- a/cheatsheet/background.md +++ b/cheatsheet/background.md @@ -15,10 +15,10 @@ The fits use `cod_obs` for 1983-2025 and model ages 2-14, with age 14 as the plu ### Navigating the dashboard -Use **Fisheries** and **Surveys** to compare observations with fitted values and inspect residual plots. Fisheries lists one page per fleet, then **Aggregate fishery**. Without fleets, the aggregate page contains the single-fishery diagnostics. **Trends** compares population estimates such as spawning stock biomass. The **Parameters** pages show fixed parameter estimates, including coefficients and process or observation standard deviations, and random parameter estimates, including latent states and process deviations across years and ages. +The opening **Model structure** page shows the diagram and function calls. Use **Fisheries** and **Surveys** to compare observations with fitted values and inspect residuals. Plots start with retained OSAs where available, otherwise standardized residuals; the dropdown selects either type. Fisheries lists each fleet, then **Aggregate fishery**. Without fleets, the aggregate page contains the single-fishery diagnostics. **Trends** compares population estimates. **Parameters** shows uncertainty, latent states and process deviations. On **Random**, **Process deviations** shows fitted log-scale departures from mean or cohort predictions, or annual increments for random walks. **Joint-sample residuals** standardizes these innovations using the fitted process correlations and variation, then propagates one shared draw from Gaussian parameter uncertainty. This local Gaussian approximation provides reproducible diagnostic values (default seed `123456`). Missing or invalid joint uncertainty is identified explicitly; fitted deviations remain available. Each viewer separates recruitment line plots from N/F/M matrices or bubbles. -The **Tables** pages contain numerical and statistical diagnostics, input data, model settings and calls, and fitted outputs such as population estimates and parameter tables. Use these checks to assess model fit before interpreting differences. The separate hindcast call in the cheatsheet assesses survey forecast skill conditional on observed catches. +The **Tables** pages contain diagnostics, inputs and fitted outputs. Assess model fit before interpreting differences. The separate hindcast call in the cheatsheet assesses survey forecast skill conditional on observed catches. Hover over Plotly figures to inspect values and units. Drag to zoom, hold Shift while dragging to pan, and double-click to reset the view. Use the legend to show or hide series and use any animation controls to move between models or years. Shaded bands show 95% confidence intervals where available. diff --git a/cheatsheet/examples.R b/cheatsheet/examples.R index d8dface6..f9b7fc44 100644 --- a/cheatsheet/examples.R +++ b/cheatsheet/examples.R @@ -92,8 +92,9 @@ dat <- make_tam_data( ) # ---- end ---- # Reporting/layout changes must not invalidate numerical model fits. - fit_sources <- sources[!names(sources) %in% c("plot.R", "plot-process.R", "palette.R", - "tidy.R", "vis.R", "process-diagnostics.R", "NAMESPACE")] + fit_sources <- sources[!grepl("^plot[-.]", names(sources)) & + !names(sources) %in% c("palette.R", "tidy.R", "vis.R", "model-diagram.R", + "getters.R", "process-diagnostics.R", "NAMESPACE")] fit_key <- list(sources = fit_sources, example = provenance$example_md5, data = fingerprint(dat), runtime = provenance$runtime) records <- list() cached <- function(name, key, code) { @@ -167,7 +168,8 @@ ncam <- update(scaa, provenance$process_diagnostics <- diagnostics tidy_key <- list(fit = fit_key, sources = sources[c("tidy.R", "process-diagnostics.R")], diagnostics = diagnostics) out <- cached("tidy", tidy_key, function() tidy_tam(scaa, sam, ncam, process_seed = process_seed)) - dashboard_key <- list(tidy = tidy_key, sources = sources[c("vis.R", "plot.R", "plot-process.R")], + dashboard_key <- list(tidy = tidy_key, sources = sources[c("vis.R", "model-diagram.R", + names(sources)[grepl("^plot[-.]", names(sources))])], layout = "random-dropdowns-v2", templates = templates, background = file_hashes(background_file)) prior <- if (file.exists(dashboard_file)) readRDS(dashboard_file) else NULL # ---- dashboard ---- diff --git a/cheatsheet/tinyAM_cheatsheet.pdf b/cheatsheet/tinyAM_cheatsheet.pdf index 7c353a52..600c6fd0 100644 Binary files a/cheatsheet/tinyAM_cheatsheet.pdf and b/cheatsheet/tinyAM_cheatsheet.pdf differ diff --git a/inst/js/model-structure.js b/inst/js/model-structure.js new file mode 100644 index 00000000..995847be --- /dev/null +++ b/inst/js/model-structure.js @@ -0,0 +1,169 @@ +(function() { + 'use strict'; + var root = document.currentScript.closest('.tam-model-structure'); + if (!root) return; + var scheduled = false; + var ns = 'http://www.w3.org/2000/svg'; + + function box(element, origin, padding) { + var r = element.getBoundingClientRect(); + return {left: r.left - origin.left - padding, right: r.right - origin.left + padding, + top: r.top - origin.top - padding, bottom: r.bottom - origin.top + padding}; + } + function port(rect, side, fraction) { + var p = side === 'left' || side === 'right' ? + [rect[side], rect.top + fraction * (rect.bottom - rect.top)] : + [rect.left + fraction * (rect.right - rect.left), rect[side]]; + var direction = {left: [-1, 0], right: [1, 0], top: [0, -1], bottom: [0, 1]}[side]; + return {tip: p, outside: [p[0] + 10 * direction[0], p[1] + 10 * direction[1]]}; + } + function clear(a, b, obstacles) { + return !obstacles.some(function(r) { + return a[0] === b[0] ? a[0] > r.left && a[0] < r.right && + Math.max(a[1], b[1]) > r.top && Math.min(a[1], b[1]) < r.bottom : + a[1] > r.top && a[1] < r.bottom && Math.max(a[0], b[0]) > r.left && + Math.min(a[0], b[0]) < r.right; + }); + } + // Orthogonal paths follow measured gaps, keeping arrows outside node text at + // every layout width. The small visibility grid needs no layout dependency. + function route(start, end, obstacles, width, height) { + function round(x) { return Math.round(x * 1000) / 1000; } + function coordinates(values, maximum) { + return Array.from(new Set(values.map(round))).filter(function(x) { + return x >= 2 && x <= maximum - 2; + }).sort(function(a, b) { return a - b; }); + } + start = start.map(round); end = end.map(round); + var xs = coordinates([2, width - 2, start[0], end[0]].concat(obstacles.flatMap(function(r) { + return [r.left - 2, r.right + 2]; + })), width); + var ys = coordinates([2, height - 2, start[1], end[1]].concat(obstacles.flatMap(function(r) { + return [r.top - 2, r.bottom + 2]; + })), height); + var ny = ys.length; + function id(p) { return xs.indexOf(p[0]) * ny + ys.indexOf(p[1]); } + function point(i) { return [xs[Math.floor(i / ny)], ys[i % ny]]; } + function distance(a, b) { return Math.abs(a[0] - b[0]) + Math.abs(a[1] - b[1]); } + if (!xs.includes(start[0]) || !xs.includes(end[0]) || !ys.includes(start[1]) || !ys.includes(end[1])) return []; + var first = id(start), last = id(end), costs = Array(xs.length * ny).fill(Infinity); + var previous = Array(costs.length).fill(-1), open = [{id: first, cost: 0, score: distance(start, end)}]; + costs[first] = 0; + while (open.length) { + open.sort(function(a, b) { return b.score - a.score || a.cost - b.cost; }); + var current = open.pop(); + if (current.cost !== costs[current.id]) continue; + if (current.id === last) { + var result = []; + for (var k = last; k !== -1; k = previous[k]) result.push(point(k)); + return result.reverse(); + } + var ix = Math.floor(current.id / ny), iy = current.id % ny; + [[ix - 1, iy], [ix + 1, iy], [ix, iy - 1], [ix, iy + 1]].forEach(function(next) { + if (next[0] < 0 || next[0] >= xs.length || next[1] < 0 || next[1] >= ny) return; + var nextId = next[0] * ny + next[1], a = point(current.id), b = point(nextId); + if (!clear(a, b, obstacles)) return; + var cost = current.cost + distance(a, b); + if (cost >= costs[nextId]) return; + costs[nextId] = cost; previous[nextId] = current.id; + open.push({id: nextId, cost: cost, score: cost + distance(b, end)}); + }); + } + return []; + } + function arrow(svg, points, name, dashed) { + if (points.length < 2) return; + points = points.filter(function(p, i) { + if (i === 0 || i === points.length - 1) return true; + var a = points[i - 1], b = points[i + 1]; + return !(a[0] === p[0] && p[0] === b[0]) && !(a[1] === p[1] && p[1] === b[1]); + }); + var group = document.createElementNS(ns, 'g'); + group.setAttribute('data-connection', name); + var line = document.createElementNS(ns, 'polyline'); + line.setAttribute('points', points.map(function(p) { return p.join(','); }).join(' ')); + line.setAttribute('fill', 'none'); line.setAttribute('stroke', dashed ? '#af8a27' : '#526a75'); + line.setAttribute('stroke-width', '1.6'); + if (dashed) line.setAttribute('stroke-dasharray', '4,3'); + group.appendChild(line); + var end = points[points.length - 1], before = points[points.length - 2]; + var length = Math.hypot(end[0] - before[0], end[1] - before[1]); + if (!length) return; + var dx = (end[0] - before[0]) / length, dy = (end[1] - before[1]) / length; + var head = document.createElementNS(ns, 'polygon'); + head.setAttribute('points', [end, [end[0] - 7 * dx - 3 * dy, end[1] - 7 * dy + 3 * dx], + [end[0] - 7 * dx + 3 * dy, end[1] - 7 * dy - 3 * dx]].map(function(p) { return p.join(','); }).join(' ')); + head.setAttribute('fill', dashed ? '#af8a27' : '#526a75'); + group.appendChild(head); svg.appendChild(group); + } + function draw(graph) { + var bounds = graph.getBoundingClientRect(); + if (!bounds.width || !bounds.height) return; + graph.setAttribute('data-layout', bounds.width < 460 ? 'stacked' : bounds.width < 760 ? 'compact' : 'wide'); + bounds = graph.getBoundingClientRect(); + var svg = graph.querySelector('.tam-model-connectors'), nodes = {}, obstacles = []; + graph.querySelectorAll('[data-component]').forEach(function(node) { + nodes[node.getAttribute('data-component')] = box(node, bounds, 0); + obstacles.push(box(node, bounds, 4)); + }); + graph.querySelectorAll('[data-input-component]').forEach(function(input) { + obstacles.push(box(input, bounds, 4)); + }); + svg.replaceChildren(); + svg.setAttribute('viewBox', '0 0 ' + bounds.width + ' ' + bounds.height); + var edges = [ + ['initial', 'population', 'right', 'left', .5, .2], + ['recruitment', 'population', 'right', 'left', .5, .5], + ['fishing', 'population', 'top', 'bottom', .5, .25], + ['natural', 'population', 'top', 'left', .5, .8], + ['population', 'survey', 'right', 'left', .3, .5], + ['population', 'catch', 'right', 'left', .7, .5], + ['fishing', 'catch', 'bottom', 'bottom', .5, .5], + ['population', 'ssb', 'bottom', 'top', .7, .5] + ]; + if (graph.getAttribute('data-feedback') === 'true') edges.push(['ssb', 'recruitment', 'left', 'right', .5, .8]); + edges.forEach(function(edge) { + if (!nodes[edge[0]] || !nodes[edge[1]]) return; + var from = port(nodes[edge[0]], edge[2], edge[4]), to = port(nodes[edge[1]], edge[3], edge[5]); + var middle = route(from.outside, to.outside, obstacles, bounds.width, bounds.height); + if (middle.length) arrow(svg, [from.tip].concat(middle, [to.tip]), edge[0] + '-' + edge[1], false); + }); + graph.querySelectorAll('[data-input-component]').forEach(function(input) { + var target = nodes[input.getAttribute('data-input-component')]; + if (!target) return; + var r = box(input, bounds, 0), x = (target.left + target.right) / 2; + arrow(svg, [[x, r.bottom], [x, target.top]], 'input-' + input.getAttribute('data-input-component'), true); + }); + } + function schedule() { + if (scheduled) return; + scheduled = true; + window.requestAnimationFrame(function() { + scheduled = false; + root.querySelectorAll('.tam-model-graph').forEach(draw); + }); + } + var selector = root.querySelector('[data-model-selector]'); + if (selector) selector.addEventListener('change', function() { + var value = selector.value; + root.querySelectorAll('[data-model-pane]').forEach(function(pane) { + pane.style.display = pane.getAttribute('data-model-pane') === value ? '' : 'none'; + }); + schedule(); + }); + if (window.ResizeObserver) { + var resize = new window.ResizeObserver(schedule); + resize.observe(root); + root.querySelectorAll('.tam-model-graph').forEach(function(graph) { resize.observe(graph); }); + } + // Dashboard tabs change ancestor classes/styles without a window resize. + if (window.MutationObserver) { + var visibility = new window.MutationObserver(schedule); + for (var parent = root.parentElement; parent; parent = parent.parentElement) { + visibility.observe(parent, {attributes: true, attributeFilter: ['class', 'style', 'hidden']}); + } + } + window.addEventListener('resize', schedule); + if (document.fonts && document.fonts.ready) document.fonts.ready.then(schedule); + schedule(); +})(); diff --git a/inst/js/residual-selection.js b/inst/js/residual-selection.js index 8bed14f1..0727ae32 100644 --- a/inst/js/residual-selection.js +++ b/inst/js/residual-selection.js @@ -2,6 +2,7 @@ function(el, x, config) { 'use strict'; function array(value) { return Array.isArray(value) ? value : [value]; } config.frames = array(config.frames); + config.defaultViews = array(config.defaultViews); config.views.forEach(function(view) { view.cells.forEach(function(cell) { cell.data.forEach(function(trace) { @@ -12,23 +13,28 @@ function(el, x, config) { }); }); }); - var state = {view: config.view, frame: config.frame}, busy = false, pending = false; + var state = {view: config.view, frame: config.frame, automatic: config.automatic}, busy = false, pending = false; + function selectedView(frame) { + return state.automatic ? config.defaultViews[frame] : state.view; + } function draw() { if (busy) { pending = true; return; } busy = true; - var view = config.views[state.view], cell = view.cells[state.frame]; + state.view = selectedView(state.frame); + var cell = config.views[state.view].cells[state.frame]; var frames = config.frames.map(function(name, i) { - return {name: name, data: view.cells[i].data, layout: view.cells[i].layout, - traces: view.cells[i].data.map(function(trace, j) { return j; })}; + var frameCell = config.views[selectedView(i)].cells[i]; + return {name: name, data: frameCell.data, layout: frameCell.layout, + traces: frameCell.data.map(function(trace, j) { return j; })}; }); var layout = Object.assign({}, x.layout, cell.layout, { - autosize: true, margin: Object.assign({}, cell.layout.margin, {t: 100}), + autosize: true, margin: Object.assign({}, cell.layout.margin, {t: config.showSelector ? 100 : 60}), // Leave the upper-right modebar clear and reserve a separate method row. - updatemenus: [{name: 'tam-residual-type', type: 'dropdown', + updatemenus: config.showSelector ? [{name: 'tam-residual-type', type: 'dropdown', x: 0, y: 1, xanchor: 'left', yanchor: 'bottom', pad: {b: 28}, active: state.view, - buttons: ['Auto', 'Standardized', 'OSA'].map(function(label, i) { + buttons: ['Standardized', 'OSA'].map(function(label, i) { return {label: label, method: 'skip', execute: false, args: [i]}; - })}], + })}] : [], sliders: config.animated ? [{active: state.frame, pad: {t: 45}, currentvalue: {prefix: config.prefix}, steps: config.frames.map(function(name) { return {label: name, method: 'animate', args: [[name], @@ -50,12 +56,17 @@ function(el, x, config) { el.on('plotly_buttonclicked', function(event) { if (!event.menu || event.menu.name !== 'tam-residual-type') return; state.view = event.button.args[0]; + state.automatic = false; draw(); }); el.on('plotly_animatingframe', function(event) { var index = config.frames.indexOf(event.name); if (index >= 0) { state.frame = index; + if (state.automatic) { + state.view = config.defaultViews[index]; + if (!busy && config.showSelector) Plotly.relayout(el, {'updatemenus[0].active': state.view}); + } if (busy) pending = true; } }); diff --git a/inst/rmd/model_structure.Rmd b/inst/rmd/model_structure.Rmd index b46981ab..efeba86d 100644 --- a/inst/rmd/model_structure.Rmd +++ b/inst/rmd/model_structure.Rmd @@ -1,8 +1,28 @@ Model structure ================================================================================ -### Model structure +Row {.tabset} +-------------------------------------------------------------------------------- + +### Diagram ```{r} plot_model(model_list = fits) ``` + +### Function calls + +```{r, results = "asis"} +call_fits <- Filter(function(fit) inherits(fit, "tam_fit"), fits) +calls <- lapply(call_fits, `[[`, "call") +if (length(calls)) { + calls_parsed <- sapply(calls, deparse1, width.cutoff = 50L, collapse = "\n") + calls_html <- paste("
\n",
+                      htmltools::htmlEscape(calls_parsed),
+                      "\n
") + calls_df <- data.frame(Model = htmltools::htmlEscape(names(calls)), Call = calls_html) + cat('
\n\n') + print(knitr::kable(calls_df, format = "html", escape = FALSE, col.names = NULL)) + cat('\n
\n\n') +} +``` diff --git a/inst/rmd/tables.Rmd b/inst/rmd/tables.Rmd index 0be82381..ac1b5b8e 100644 --- a/inst/rmd/tables.Rmd +++ b/inst/rmd/tables.Rmd @@ -50,30 +50,6 @@ if (!is.null(obs_stack$pop_covariates)) { ``` -Settings {data-navmenu="Tables"} -================================================================================ - -Row {.tabset} --------------------------------------------------------------------------------- - -### Function calls - -```{r, results = "asis"} -call_fits <- Filter(function(fit) inherits(fit, "tam_fit"), fits) -calls <- lapply(call_fits, `[[`, "call") -if (length(calls)) { - calls_parsed <- sapply(calls, deparse1, width.cutoff = 50L, collapse = "\n") - calls_html <- paste("
\n",
-                      calls_parsed,
-                      "\n
") - calls_df <- data.frame(Model = names(calls), Call = calls_html) - cat('
\n\n') - print(knitr::kable(calls_df, format = "html", escape = FALSE, col.names = NULL)) - cat('\n
\n\n') -} -``` - - Output {data-navmenu="Tables"} ================================================================================ diff --git a/inst/rmd/vis_tam.Rmd b/inst/rmd/vis_tam.Rmd index 20104eaa..67a6f36b 100644 --- a/inst/rmd/vis_tam.Rmd +++ b/inst/rmd/vis_tam.Rmd @@ -152,6 +152,9 @@ table_link <- function(x, table_name = NULL, download_text = "Download table") { ``` +```{r model-structure, child = "model_structure.Rmd"} +``` + ```{r background, child = if (is.null(background)) NULL else "background.Rmd"} ``` @@ -179,12 +182,3 @@ table_link <- function(x, table_name = NULL, download_text = "Download table") { ```{r tables, child = "tables.Rmd"} ``` -```{r model-structure, child = "model_structure.Rmd"} -``` - - - - - - - diff --git a/man/check_obs.Rd b/man/check_obs.Rd deleted file mode 100644 index b6b550ca..00000000 --- a/man/check_obs.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data.R -\name{check_obs} -\alias{check_obs} -\title{Check the structure of a TAM obs list} -\usage{ -check_obs(obs, quiet = FALSE) -} -\arguments{ -\item{obs}{A named list of tinyAM input tables.} - -\item{quiet}{Logical. Suppress the success summary? Defaults to \code{FALSE}.} -} -\value{ -\code{TRUE} (invisibly) if validation passes; otherwise aborts. -} -\description{ -A convenience wrapper for \code{\link[=check_tam_data]{check_tam_data()}}. -} -\examples{ -check_tam_data(cod_obs) -} diff --git a/man/check_tam.Rd b/man/check_tam.Rd index 0f004856..f7917d3b 100644 --- a/man/check_tam.Rd +++ b/man/check_tam.Rd @@ -20,7 +20,7 @@ through named \code{...} arguments or \code{model_list}.} unnamed models use their expression names. Unused by the print methods.} \item{grad_tol}{Positive gradient tolerance. \code{NULL} uses the tolerance stored -in the fit, or \code{1e-2} if none is stored.} +in the fit.} \item{detailed}{Examine covariance eigenvalues and weak parameter directions?} diff --git a/man/fit_retro.Rd b/man/fit_retro.Rd index 002181cf..b8360127 100644 --- a/man/fit_retro.Rd +++ b/man/fit_retro.Rd @@ -120,8 +120,17 @@ Missing baselines or zero persistence error make MASE unavailable. Failed numerical fits remain in \code{fits}, but not in stacked results or scores. Supplied fits and fitted objectives are unchanged. } +\section{Parallel execution}{ + +Set the execution plan before calling either function, for example +\code{future::plan(future::multisession, workers = 4)}. Without a parallel plan, +folds run sequentially. Neither function changes your plan or worker count. +Use \code{future::plan(future::sequential)} afterwards to shut down the workers. +} + \examples{ \dontrun{ +future::plan(future::multisession, workers = 4) retro <- fit_retro(fit, alternative = other_fit, folds = 5) hind <- fit_hindcast(fit, folds = 10, proj_settings = list(n_proj = 3, n_mean = 3, catch = "observed")) @@ -129,6 +138,7 @@ print(hind) hind$scores vis_tam(hind) vis_tam(retro, model = names(retro$fits)[1]) +future::plan(future::sequential) } } \seealso{ diff --git a/man/fit_tam.Rd b/man/fit_tam.Rd index 888778b9..33955efe 100644 --- a/man/fit_tam.Rd +++ b/man/fit_tam.Rd @@ -65,8 +65,9 @@ RW residuals require independent temporal mean contrasts; constant directions cancel and are rejected. See \link{tinyAM-model}. \item \code{sd_form}: ordinary formula for log SD of older-age survival residuals, default \code{~ 1}. Use \code{~ factor(age)} or a supplied age-sharing column in -\code{data$pop_covariates}. Its design must be constant across years. Recruitment and -initial-abundance SDs remain separate. Random-effect SD terms are not enabled. +\code{data$pop_covariates}. Its design must be constant across years. Recruitment +SD is controlled separately by \code{rec_settings}; initial abundance has no +separate SD. Random-effect SD terms are not enabled. }} \item{rec_settings}{A list controlling recruitment separately from cohort survival: @@ -273,7 +274,9 @@ retain its results, use \code{\link[=add_osa_residuals]{add_osa_residuals()}}.} \item{start_par}{Optional fitted \code{tam_fit} or list of starting parameter values, matching the structure returned by \code{\link[=make_par]{make_par()}}. Useful for warm starts or retrospective runs where parameter estimates from a previous fit are reused to improve -convergence and speed. Non-matching or missing entries are ignored.} +convergence and speed. Non-matching or missing entries are ignored. +Fitted-object starts require the current stored parameter modes; regenerate +older saved fits. Catchability coefficients are omitted if \code{q_link} changes.} \item{grad_tol}{Numeric tolerance passed to \code{\link[=check_tam]{check_tam()}} when evaluating the fitted object's gradients. Defaults to \code{1e-2}.} @@ -316,36 +319,18 @@ RTMB integrates random effects using the Laplace approximation; \code{nlminb} optimizes the remaining fixed effects. \code{\link[=mono]{mono()}} increments \code{dq} and \code{dmu_f} have a zero lower bound, as do initial-abundance decrements \code{d_n0}. Their SEs remain on the increment scale, but symmetric Wald intervals are only local approximations at a boundary. -Set \code{index_settings$q_link = "logit"} to restrict the full catchability -prediction to between zero and one; the default \code{"log"} allows q above one. -Formula coefficients are then named \code{logit_q}, and \code{\link[=mono]{mono()}} increments -act on logit-q. Starting q coefficients must use the selected link scale: -old \code{log_q} starts are not reused as \code{logit_q}. See \code{\link[=prepare_tam]{prepare_tam()}} and \code{\link[=tidy_par]{tidy_par()}}. - -Random-effect blocks are chosen automatically from the model settings: -\itemize{ -\item Includes \code{log_f} when the F process is active, and eligible \code{log_r} states when recruitment is stochastic. Early recruitment -anchors are fixed; see \link{recruitment_formulas}. -\item Includes \code{log_n0} only if \code{N_settings$init == "latent"}. -\item Includes \code{log_n} if \code{N_settings$process != "off"}. -\item Includes \code{log_m} if \code{M_settings$process != "off"}. -\item Includes the unique \verb{eta_q_*} states of Gaussian catchability formula terms. -\item Includes Gaussian F/M mean and catch/index log-SD formula states. -Logistic midpoint/slope and process SD/correlation are fixed effects. -} +Random-effect blocks are chosen from the active processes and Gaussian +formula effects. Initial abundance and recruitment boundaries are integrated +only when their respective \code{init} setting is \code{"latent"}; see \link{tinyAM-model} +and \link{recruitment_formulas}. \code{\link[=make_par]{make_par()}} describes the parameter layout. A warning is issued if the number of random effects exceeds 1.5 times the number of observed data points (rough identifiability check). -For F random walks, \code{\link[=prepare_tam]{prepare_tam()}} removes time-invariant mean columns -because they cancel from all increments. For M random walks, mean coefficients -with no effect on either increments or mortality outside the fitted process -states are held at their starting values. -An RW SD is also held fixed if the process has only one row (no increments). -These parameters cannot be estimated from the likelihood; no constraint is -imposed on the latent states themselves. -For AR1, the correlation for an axis containing a single row or column is -fixed at zero; otherwise it would be confounded with the SD. +Parameters without likelihood support are removed or fixed: examples include +constant mean directions canceled by RW increments, RW SDs with no increments, +and AR1 correlations on singleton axes. The latent states themselves retain +the conventions in \link{tinyAM-model}. \code{is_converged} summarizes optimizer, gradient and uncertainty checks. Also inspect \code{opt$convergence} and \code{opt$message}; a passing numerical check does not diff --git a/man/nll_fun.Rd b/man/nll_fun.Rd index d7974ad9..cde53d91 100644 --- a/man/nll_fun.Rd +++ b/man/nll_fun.Rd @@ -4,8 +4,6 @@ \alias{nll_fun} \title{Evaluate or simulate the tinyAM model} \usage{ -nll_fun(par, dat, simulate = FALSE) - nll_fun(par, dat, simulate = FALSE) } \arguments{ @@ -77,11 +75,6 @@ F scales terminal historical F by a supplied multiplier or a multiplier solved from projected catch biomass. Both paths use the same chronological population. Active M states already extend into projected years under their process density. } -\section{Simulate from fitted parameters}{ -p_hat <- as.list(sdrep, "Estimate") -sims <- nll_fun(p_hat, dat, simulate = TRUE) -} - \examples{ dat <- prepare_tam( cod_obs, @@ -101,7 +94,4 @@ head(exp(simulated$log_r)) } \seealso{ \link{tinyAM-model}, \code{\link[=prepare_tam]{prepare_tam()}}, \code{\link[=make_par]{make_par()}}, \code{\link[=fit_tam]{fit_tam()}}, \code{\link[=sim_tam]{sim_tam()}} - -\code{\link[=prepare_tam]{prepare_tam()}}, \code{\link[=make_par]{make_par()}}, \code{\link[=fit_tam]{fit_tam()}}, \code{\link[=sim_tam]{sim_tam()}}, -\code{\link[=dprocess_ar1]{dprocess_ar1()}}, \code{\link[=rprocess_ar1]{rprocess_ar1()}} } diff --git a/man/plot_age_year.Rd b/man/plot_age_year.Rd index 63098153..22901da3 100644 --- a/man/plot_age_year.Rd +++ b/man/plot_age_year.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R +% Please edit documentation in R/plot-trends.R \name{plot_age_year} \alias{plot_age_year} \title{Switch between annual trends and age profiles} diff --git a/man/plot_matrix.Rd b/man/plot_matrix.Rd index 6a3ec36c..04a92f22 100644 --- a/man/plot_matrix.Rd +++ b/man/plot_matrix.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R +% Please edit documentation in R/plot-matrix.R \name{plot_matrix} \alias{plot_matrix} \title{Explore age-year patterns} diff --git a/man/plot_model.Rd b/man/plot_model.Rd index b745775f..34f72eca 100644 --- a/man/plot_model.Rd +++ b/man/plot_model.Rd @@ -13,7 +13,7 @@ or one named list of these objects.} \item{model_list}{A named list of models, instead of \code{...}.} } \value{ -A browsable HTML container with a responsive SVG diagram and model +A browsable HTML container with responsive HTML nodes, SVG connectors and model settings. Display it directly, or save it with \code{\link[htmltools:save_html]{htmltools::save_html()}}. } \description{ diff --git a/man/plot_tam.Rd b/man/plot_tam.Rd index 4da0b5e6..ab8d27b1 100644 --- a/man/plot_tam.Rd +++ b/man/plot_tam.Rd @@ -1,16 +1,39 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R +% Please edit documentation in R/plot-matrix.R, R/plot-parameters.R, +% R/plot-resid.R, R/plot-trends.R, R/plot-utils.R \name{plot_tam} \alias{plot_tam} -\alias{plot_trend} -\alias{add_plot_buttons} \alias{plot_heatmap} -\alias{plot_obs_pred} +\alias{plot_par} \alias{plot_bubbles} \alias{plot_resid} -\alias{plot_par} +\alias{plot_trend} +\alias{plot_obs_pred} +\alias{add_plot_buttons} \title{Plot utilities for \code{tidy_tam()} outputs} \usage{ +plot_heatmap(data, zlab = "Estimate", title = "", ...) + +plot_par(data, ...) + +plot_bubbles( + data, + res = NULL, + y = ~age, + ylab = "Age", + title = NULL, + residual_type = c("auto", "standardized", "osa"), + ... +) + +plot_resid( + data, + x = ~year, + xlab = "Year", + residual_type = c("auto", "standardized", "osa"), + ... +) + plot_trend( data, x = ~year, @@ -23,10 +46,6 @@ plot_trend( ... ) -add_plot_buttons(p) - -plot_heatmap(data, zlab = "Estimate", title = "", ...) - plot_obs_pred( data, ylab = "", @@ -37,60 +56,43 @@ plot_obs_pred( ... ) -plot_bubbles( - data, - res = NULL, - y = ~age, - ylab = "Age", - title = NULL, - residual_type = c("auto", "standardized", "osa"), - ... -) - -plot_resid( - data, - x = ~year, - xlab = "Year", - residual_type = c("auto", "standardized", "osa"), - ... -) - -plot_par(data, ...) +add_plot_buttons(p) } \arguments{ \item{data}{A data frame of observations or estimates.} -\item{x}{Formula specifying x variable} - -\item{y}{Formula specifying y variable} - -\item{xlab}{Label for the x-axis.} - -\item{ylab}{Label for the y-axis.} +\item{zlab}{Label for the colorbar in heatmaps.} \item{title}{Plot title.} -\item{add_intervals}{Logical; if \code{TRUE}, show confidence intervals when \code{lwr} and \code{upr} are present.} - -\item{add_buttons}{Logical; if \code{TRUE}, include buttons to toggle y-axis between Linear / Log and, if -applicable, Show CI / Hide CI.} - \item{...}{Additional arguments to pass to \code{\link[plotly:plot_ly]{plotly::plot_ly()}} such as \code{color}, \code{colors}, etc.} -\item{p}{A Plotly object, with all desired layers already added.} - -\item{zlab}{Label for the colorbar in heatmaps.} - \item{res}{Optional one-column formula for signed bubble values, e.g. \code{~est} for process deviations. Omitted values use OSA or standardized observation residuals. Use \code{y = ~age_block} for shared M state blocks.} +\item{y}{Formula specifying y variable} + +\item{ylab}{Label for the y-axis.} + \item{residual_type}{Initial observation residual view: \code{"auto"} (default), -\code{"standardized"} or \code{"osa"}. Auto uses available cached OSA residuals -separately for each model in the supplied panel, otherwise standardized -residuals. Partial OSA gaps remain missing. A dropdown switches views; +\code{"standardized"} or \code{"osa"}. The default uses retained OSA residuals +when available, otherwise standardized residuals. Model frames choose +separately; overlays use OSA only when all models have them. A dropdown +offers OSA and Standardized when OSAs are available. Partial gaps stay missing; unavailable OSA values are identified without computing them. A supplied \code{res} formula in \code{plot_bubbles()} bypasses these observation controls.} + +\item{x}{Formula specifying x variable} + +\item{xlab}{Label for the x-axis.} + +\item{add_intervals}{Logical; if \code{TRUE}, show confidence intervals when \code{lwr} and \code{upr} are present.} + +\item{add_buttons}{Logical; if \code{TRUE}, include buttons to toggle y-axis between Linear / Log and, if +applicable, Show CI / Hide CI.} + +\item{p}{A Plotly object, with all desired layers already added.} } \value{ A Plotly object. diff --git a/man/prepare_tam.Rd b/man/prepare_tam.Rd index cc1197ee..a2b4a4d8 100644 --- a/man/prepare_tam.Rd +++ b/man/prepare_tam.Rd @@ -56,8 +56,9 @@ RW residuals require independent temporal mean contrasts; constant directions cancel and are rejected. See \link{tinyAM-model}. \item \code{sd_form}: ordinary formula for log SD of older-age survival residuals, default \code{~ 1}. Use \code{~ factor(age)} or a supplied age-sharing column in -\code{data$pop_covariates}. Its design must be constant across years. Recruitment and -initial-abundance SDs remain separate. Random-effect SD terms are not enabled. +\code{data$pop_covariates}. Its design must be constant across years. Recruitment +SD is controlled separately by \code{rec_settings}; initial abundance has no +separate SD. Random-effect SD terms are not enabled. }} \item{rec_settings}{A list controlling recruitment separately from cohort survival: @@ -290,126 +291,40 @@ function automatically; call it directly to inspect a model specification. Supply only the entries to change from the defaults shown in Usage. Formulas and vectors replace an entire entry. Optional \code{NULL} entries clear a formula, -offset or age selection; recruitment defaults to an anchored RW and a latent -\code{sd_form = NULL} restores \code{~ 1}. Required entries cannot be \code{NULL}. +offset or age selection; \code{sd_form = NULL} restores \code{~ 1}. +Required entries cannot be \code{NULL}. \code{\link[=update]{update()}} retains unspecified entries from the original fit instead. -\strong{Spawning time} +\strong{Inputs and preparation} -An optional \code{data$maturity$spawn_time} column supplies spawning timing as a -fraction of the year for each year and age. If absent, timing is zero -(start-of-year SSB). If present, every value must be finite and between zero -and one, including immature and retained older biological ages. Projections -carry forward the terminal historical value at each biological age. -SSB includes survival through this fraction of annual F and M. The same -definition supplies recruitment parents and uncertainty. Age-specific timing -sums each age's contribution at its own spawning time; it is not a snapshot -on one common date. Hidden plus-age contributions are calculated separately -before summing. Weight and maturity remain supplied quantities; seasonal -growth and maturation are not modeled. +See \code{\link[=as_tam_data]{as_tam_data()}} for table keys, units, fleet-specific catch weights and +covariate routing, and \link{cod_obs} for example data. Catch and survey zeros and +missing values are excluded from the lognormal observation likelihood; +complete predictions are still calculated. -\strong{Observation handling} -\itemize{ -\item Inputs are expected as a list with components \code{catch}, \code{index}, \code{weight}, -and \code{maturity}. Each must include columns \code{year}, \code{age}, and a value column -named \code{obs}. Rename any differently named input columns before calling. See -\link{cod_obs} for an example of the required structure. The optional -\code{pop_covariates} table supplies population formula inputs; see \code{\link[=as_tam_data]{as_tam_data()}}. -\item Catch and maturity must already contain exactly one row per -year-age combination across the input range. Survey tables may be sparse. -Weight needs the same complete grid for every supplied \code{type}; see -\code{\link[=as_tam_data]{as_tam_data()}} for stock and catch weights and fallback rules. -\item A combined observation table is created for catch and index; \code{log(0)} is -excluded from the observation likelihood. -\item When biological inputs extend above the modeled plus age, the underlying -stock/catch weight and maturity values are retained in \code{W_plus_input}, -\code{W_catch_plus_input} and \code{P_plus_input}, -indexed by \code{years} and \code{plus_ages}. Their projection rows use the same -recent-year averages by biological age as other weight/maturity inputs. -\code{dat$W}, \code{dat$W_catch}, \code{dat$P}, and \code{dat$obs} retain input values at modeled ages; -their terminal biological values are placeholders. \code{\link[=nll_fun]{nll_fun()}} replaces -terminal W by an abundance-weighted mean and terminal P by a biomass-weighted -proportion using its reconstructed hidden age composition. See \link{tinyAM-model}. -Formula covariates continue to use the input rows at modeled ages, not these -effective biological values; this avoids circular mortality calculations. -} +Biological ages above the modeled plus age are retained in \code{W_plus_input}, +\code{W_catch_plus_input} and \code{P_plus_input}. The population calculation derives +effective plus-group weights and maturity from their hidden abundances; +prepared terminal biological values are placeholders. Formula covariates +use the supplied modeled-age rows, avoiding circular mortality calculations. +The equations and spawning-time definition are in \link{tinyAM-model}. -\strong{Design matrices} -\itemize{ -\item \code{catch_settings$sd_form} is evaluated on the catch table to produce -\code{sd_catch_modmat} and associated \strong{log-scale} parameters \code{log_sd_catch} -(intercept removed when \code{sd_supplied} is provided so supplied SDs act as -offsets). -\item \code{index_settings$sd_form} is evaluated on the index table to produce -\code{sd_index_modmat} and \strong{log-scale} parameters \code{log_sd_index}. -Both SD formulas support additive \code{\link[=iid]{iid()}}, \code{\link[=rw]{rw()}}, \code{\link[=ar1]{ar1()}} and random -intercepts; their compact unique states are stored in \code{sd_catch_terms} -and \code{sd_index_terms}. They modify log observation SD, with supplied SDs -acting as offsets. See \link{formula_effects} for interpretation and support checks. -\item \code{index_settings$q_form} is evaluated on the index table to produce -\code{q_modmat} and parameters \code{log_q} (log link) or \code{logit_q} (logit link). -Additive \code{\link[=mono]{mono()}} terms instead contribute cumulative indicators -in \code{q_mono_modmat}, with directly fitted non-negative increments \code{dq} -on the selected link scale. -\code{q_mono_steps} records each transition and its optional group. -Structured \code{\link[=iid]{iid()}}, \code{\link[=rw]{rw()}}, \code{\link[=ar1]{ar1()}}, random-intercept and \code{\link[=logistic]{logistic()}} -terms are recorded separately in \code{q_terms}. Their unique states and process -parameters are added by \code{\link[=make_par]{make_par()}}, rather than treated as ordinary columns. -\item If \code{M_settings$mu_form} is provided, \code{M_modmat <- model.matrix(mu_form, data = data$pop_covariates)} and the resulting coefficients are parameters \code{mu_m}. -These coefficients are applied on the log scale to build \eqn{M}, but -retain the \code{mu_} prefix to emphasize they can be positive or negative. -If \code{mu_supplied} is also provided, the intercept in \code{mu_form} is dropped -and a warning is issued. -\item If neither \code{M_settings$mu_form} nor \code{M_settings$mu_supplied} is supplied, -the function stops, because \eqn{M} must be identified by either a supplied -surface or a mean structure. -} +\strong{Formula designs} -\strong{Process options and guards} -\itemize{ -\item Initial abundance is controlled by \code{N_settings$init}, independently of -the subsequent N process. First-year recruitment is the state -\code{log_r0}, controlled separately by \code{rec_settings$init}. The default uses survivorship from recruitment under first-year -total mortality Z, with no equilibrium plus-group correction. -\item \code{"exp"} is the default: a parsimonious, comparatively stable nuisance-state -initialization. More flexible choices are available when first-year data -support them. \code{"free"} estimates unpenalized fixed \code{log_n0} states. -\code{"latent"} integrates those states without an initial density, including -when the subsequent N process is off. It resembles SAM's unpenalized -older-age boundary; use \code{rec_settings$init = "latent"} to integrate first-year recruitment too. -\item \code{"mono"} estimates non-increasing initial abundance from r0, including -the plus group: \verb{log N0[a] = log r0 - cumsum(d_n0)[a-1]}. \code{"capped"} -only requires each older abundance to be no greater than r0: -\verb{log N0[a] = log r0 - d_n0[a-1]}. Both use nonnegative log-decrements, -allow exact ties, and require no N process or separate initial SD. -The pooled plus group can naturally exceed a single age; constraining it -is a deliberate biological assumption. Boundary Wald intervals need care. -\item Recruitment initialization is independent of these choices. Simulations condition on initial states; -joint uncertainty draws can vary fitted latent initial states. No -mortality-history distribution is imposed on initial abundances. -\item \code{M_settings$age_breaks} (vector of break points on ages) -defines \code{M_settings$age_blocks} via \code{\link[=cut_ages]{cut_ages()}}, used -to share absolute latent \eqn{M} states across ages. All mean components -must be constant across ages within each fitted block. -\item The AR(1) correlation parameters are only initialized for -processes whose \code{process == "ar1"}. Correlations are assumed to be 0 -when \code{process == "iid"}. A temporal random walk (\code{"rw"}) has independent -year-to-year increments within each age or age block, with no age -correlation or AR parameter. Its first process row is unpenalized. -For N the walk acts on cohort residuals; for F/M it acts on deviations -from their existing log mean surfaces. Initial abundance, the M process -start year, and terminal-F projections retain their usual meanings. -} +Ordinary formula terms create design matrices. Structured \link{formula_effects}, +\code{\link[=mono]{mono()}} curves and \link{smooth_formulas} also store unique effect states and +their grouping metadata. \code{\link[=make_par]{make_par()}} constructs the associated parameters. +Supplied M and observation SDs act as offsets; their mean/SD formulas omit +an intercept to avoid estimating another baseline. The settings below define +available terms, restrictions and data sources. -\strong{Projections (optional)} -\itemize{ -\item If \code{proj_settings} is supplied, the function adds: -\itemize{ -\item \code{proj_years}: the set of projection years; -\item \code{is_proj}: logical vector identifying the projection years; -\item \code{obs$...$is_proj} rows to each \code{obs} table identifying the projection years. -} -} +\strong{Projections} + +\code{proj_settings} appends future years and marks them with \code{is_proj} in the +prepared grid and tables. Stock/catch weights and maturity use recent-year +averages by biological age; covariates and spawning timing retain terminal +historical values. See \link{tinyAM-model} for forecasting and initial-state +equations, and \code{\link[=fit_hindcast]{fit_hindcast()}} for held-out-data evaluation. } \examples{ dat <- prepare_tam( diff --git a/man/process_ar1.Rd b/man/process_ar1.Rd index f403e4b4..e0bf66fb 100644 --- a/man/process_ar1.Rd +++ b/man/process_ar1.Rd @@ -61,5 +61,5 @@ dprocess_ar1(X_ar1, sd = 0.3, phi = c(0.5, 0.9)) } \seealso{ -\code{\link[RTMB:dseparable]{RTMB::dseparable()}}, \code{\link[RTMB:dautoreg]{RTMB::dautoreg()}}, \code{\link[MASS:mvrnorm]{MASS::mvrnorm()}} +\code{\link[RTMB:MVgauss]{RTMB::dseparable()}}, \code{\link[RTMB:MVgauss]{RTMB::dautoreg()}}, \code{\link[MASS:mvrnorm]{MASS::mvrnorm()}} } diff --git a/man/stack_list.Rd b/man/stack_list.Rd index 13600248..50544755 100644 --- a/man/stack_list.Rd +++ b/man/stack_list.Rd @@ -26,7 +26,7 @@ A single data frame produced by row-binding the list elements. If output. } \description{ -Convenience wrapper around \code{\link[base:rbind]{base::rbind()}} for stacking a (named) list of +Convenience wrapper around \code{\link[base:cbind]{base::rbind()}} for stacking a (named) list of data frames while recording the source list element in a label column. When the list is named, the names are used as labels; otherwise, integer indices (\code{"1"}, \code{"2"}, …) are used. Columns absent in some elements are filled with diff --git a/man/tam_cols.Rd b/man/tam_cols.Rd index 2a1da935..19854c9c 100644 --- a/man/tam_cols.Rd +++ b/man/tam_cols.Rd @@ -29,5 +29,5 @@ tam_pal(3) } \seealso{ -\code{\link[grDevices:colorRampPalette]{grDevices::colorRampPalette()}} +\code{\link[grDevices:colorRamp]{grDevices::colorRampPalette()}} } diff --git a/man/tidy_array.Rd b/man/tidy_array.Rd index 9fee5058..ba6e5ad3 100644 --- a/man/tidy_array.Rd +++ b/man/tidy_array.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/tidy.R \name{tidy_array} \alias{tidy_array} -\alias{tidy_mat} \title{Tidy a (named) matrix/array into long format} \usage{ tidy_array(x, value_name = "x", require_dimnames = TRUE) - -tidy_mat(x, value_name = "x", require_dimnames = TRUE) } \arguments{ \item{x}{A matrix or array. Works with 2D or higher dimensions.} @@ -27,7 +24,7 @@ one column per dimension (using the dimension names if available), and a value column. } \details{ -Internally uses \code{\link[base:as.data.frame.table]{base::as.data.frame.table()}} to reshape \code{x}. After reshaping, +Internally uses \code{\link[base:table]{base::as.data.frame.table()}} to reshape \code{x}. After reshaping, all \strong{dimension columns} are passed through \code{\link[utils:type.convert]{utils::type.convert()}} with \code{as.is = TRUE}, so numeric-like labels (e.g., \code{"1"}, \code{"2.5"}) become numeric. } diff --git a/man/tidy_par.Rd b/man/tidy_par.Rd index 474594fb..a6a2e268 100644 --- a/man/tidy_par.Rd +++ b/man/tidy_par.Rd @@ -94,7 +94,7 @@ initialization, derived \code{n0} estimates use joint RTMB uncertainty. \item For matrices (e.g., \code{log_f}, \code{log_n}), \code{year} and/or \code{age} columns are added from their dimensions; shared F/M states use \code{age_block} rather than duplicating the parameter at each biological age. -via \code{\link[=tidy_mat]{tidy_mat()}}. +via \code{\link[=tidy_array]{tidy_array()}}. } } \examples{ @@ -117,5 +117,5 @@ head(par_tab$random$log_f) } \seealso{ -\code{\link[=tidy_mat]{tidy_mat()}}, \code{\link[=fit_tam]{fit_tam()}} +\code{\link[=tidy_array]{tidy_array()}}, \code{\link[=fit_tam]{fit_tam()}} } diff --git a/man/tidy_rep.Rd b/man/tidy_rep.Rd index 02944fd1..9016027d 100644 --- a/man/tidy_rep.Rd +++ b/man/tidy_rep.Rd @@ -35,5 +35,5 @@ head(trends$N) } \seealso{ -\code{\link[=tidy_obs_pred]{tidy_obs_pred()}}, \code{\link[=tidy_sdrep]{tidy_sdrep()}}, \code{\link[=tidy_pop]{tidy_pop()}}, \code{\link[=tidy_mat]{tidy_mat()}} +\code{\link[=tidy_obs_pred]{tidy_obs_pred()}}, \code{\link[=tidy_sdrep]{tidy_sdrep()}}, \code{\link[=tidy_pop]{tidy_pop()}}, \code{\link[=tidy_array]{tidy_array()}} } diff --git a/man/tinyAM-model.Rd b/man/tinyAM-model.Rd index 4eb968e3..06e4a886 100644 --- a/man/tinyAM-model.Rd +++ b/man/tinyAM-model.Rd @@ -14,7 +14,7 @@ Choose process assumptions to express biological hypotheses. \code{"iid"} allows independent departures, \code{"ar1"} allows departures to be similar in adjacent years and ages, and \code{"rw"} allows departures to accumulate over time without returning to a mean. These choices make different assumptions, even when -they produce similar fitted curves. N and M can also have their process +they produce similar fitted curves. N, F and M can also have their process switched \code{"off"}. Recruitment defaults to a temporal random walk; \code{rec_settings$mu_form} can describe stock-recruit relationships and covariates. @@ -63,10 +63,6 @@ states. Full surfaces \code{log_N}, \code{log_F}, and \code{log_M} are construct them by recursion, age-block expansion, and projection. An \verb{eta_*} quantity is a deviation from an expected log state, never an additional absolute state. All matrices have years in rows. Vectorization stacks columns, as in R. - -Numbers and weights must use consistent units. There is no automatic unit -conversion. For \link{cod_obs}, numbers in thousands and weights in kg give -biomass in tonnes. Survey catchability absorbs differences in survey units. } \subsection{Recruitment and initial abundance}{ @@ -97,6 +93,9 @@ For \code{"mono"}, \eqn{\log N_{1,a}=\log r_0-\sum_{j=2}^a d_j}; for \code{"capped"}, \eqn{\log N_{1,a}=\log r_0-d_a}, with \eqn{d_j\ge0}. These fixed constraints include the terminal plus group and allow ties. +A pooled plus group can exceed a single age's abundance, so imposing these +constraints on it is a deliberate biological assumption. Wald intervals +at a constraint boundary are only local approximations. The baseline always uses the realized preceding initial-age state. No equilibrium plus-group correction is applied in this first year. This is an initial-state assumption, not a reconstruction of past cohorts. @@ -411,9 +410,9 @@ including updated biology within a shortened plus group. Predictions and observation draws then use each row's SD. Initial RW states are retained: F/M walks start from the supplied first latent row; the N walk retains its first \code{log_n} row and computes that row's residual -against the newly generated cohort prediction. Random N0 is redrawn; free -N0, first recruitment and additional early boundary recruitment states -remain supplied fixed states. +against the newly generated cohort prediction. Initial older-age abundance, +first recruitment and additional early recruitment boundaries retain their +supplied values, including when integrated with \code{init = "latent"}. \code{\link[=sim_tam]{sim_tam()}} can hold parameters fixed, draw fixed effects with their estimated covariance while retaining fitted random states, or draw all parameters with diff --git a/man/vis_tam.Rd b/man/vis_tam.Rd index 9eb4f72b..c99237f2 100644 --- a/man/vis_tam.Rd +++ b/man/vis_tam.Rd @@ -89,6 +89,7 @@ Pandoc, included with RStudio or available from Precomputed assessment references may be mixed with tinyAM fits; they are not refittable TAM objects. Supply \code{background} to add a page describing assessment assumptions and translation choices. +Model structure opens first, with Diagram and Function calls tabs. Fisheries is a dropdown with one page per declared catch fleet, followed by Aggregate fishery. Fleet pages show yield, catch and F at age, and observation residuals. Unlabeled catch models appear @@ -96,9 +97,10 @@ only on the aggregate page; they are not allocated among fleets. Without fleets, Aggregate fishery retains all single-fishery diagnostics. With fleets, it shows total yield; residuals are assessed separately within each fleet. -Observation residuals default to Auto: each model uses retained OSA +Observation residuals initially use retained OSA residuals when available in that panel, otherwise standardized -residuals. The dropdown also selects either type explicitly. Partial +residuals. The dropdown offers OSA and Standardized when OSAs are +available. Model frames choose their initial type separately. Partial OSA gaps remain missing, and labels identify the method. Retain OSA calculations with \code{\link[=add_osa_residuals]{add_osa_residuals()}}; rendering never computes them. The Parameters menu separates Fixed and Random pages. Fixed plots diff --git a/tests/testthat/model-structure-controls.js b/tests/testthat/model-structure-controls.js new file mode 100644 index 00000000..6cf950c9 --- /dev/null +++ b/tests/testthat/model-structure-controls.js @@ -0,0 +1,92 @@ +const fs = require('fs'), vm = require('vm'), assert = require('assert'); +const source = fs.readFileSync(process.argv[2], 'utf8'); +const order = ['initial', 'recruitment', 'fishing', 'natural', 'population', 'survey', 'catch', 'ssb']; +function element() { + return {attributes: {}, children: [], + setAttribute(name, value) { this.attributes[name] = String(value); }, + getAttribute(name) { return this.attributes[name]; }, + appendChild(child) { this.children.push(child); }, + replaceChildren() { this.children = []; }}; +} +function widget(width, feedback) { + const queue = [], observations = [], ancestors = [{parentElement: null}]; + const root = {parentElement: ancestors[0], visible: true}; + const pane = {style: {display: ''}, getAttribute: () => '1'}; + const reference = {style: {display: 'none'}, getAttribute: () => '2'}; + const selector = {value: '1', addEventListener: (name, fun) => { selector[name] = fun; }}; + const svg = element(), graph = element(); graph.width = width; + graph.attributes['data-feedback'] = String(feedback); + graph.layout = () => { + if (graph.width >= 760) return { + initial: [24, 60, 200, 120], recruitment: [24, 280, 200, 120], + fishing: [24, 500, 200, 120], natural: [274, 500, 200, 120], + population: [524, 280, 200, 120], survey: [774, 60, 200, 120], + catch: [774, 500, 200, 120], ssb: [524, 500, 200, 120]}; + if (graph.width >= 460) return { + initial: [24, 60, 270, 120], recruitment: [346, 60, 270, 120], + fishing: [24, 280, 270, 120], natural: [346, 280, 270, 120], + population: [24, 500, 592, 120], survey: [24, 720, 270, 120], + catch: [346, 720, 270, 120], ssb: [24, 940, 592, 120]}; + return Object.fromEntries(order.map((name, i) => [name, [24, 60 + i * 200, graph.width - 48, 120]])); + }; + function bounds(name, input) { + const p = graph.layout()[name], top = p[1] - (input ? 42 : 0), height = input ? 26 : p[3]; + return {left: p[0], right: p[0] + p[2], top, bottom: top + height, width: p[2], height}; + } + const nodes = order.map(name => ({getAttribute: () => name, getBoundingClientRect: () => bounds(name, false)})); + const inputs = ['survey', 'fishing'].map(name => ({getAttribute: () => name, getBoundingClientRect: () => bounds(name, true)})); + graph.getBoundingClientRect = () => ({left: 0, top: 0, + width: root.visible && pane.style.display !== 'none' ? graph.width : 0, + height: graph.width >= 760 ? 660 : graph.width >= 460 ? 1100 : 1640}); + graph.querySelector = () => svg; + graph.querySelectorAll = query => query === '[data-component]' ? nodes : inputs; + root.querySelector = () => selector; + root.querySelectorAll = query => query === '.tam-model-graph' ? [graph] : [pane, reference]; + const observers = {}; + const window = { + requestAnimationFrame: fun => queue.push(fun), addEventListener: (name, fun) => { window[name] = fun; }, + ResizeObserver: class {constructor(fun) { observers.resize = fun; } observe(target) { observations.push(target); }}, + MutationObserver: class {constructor(fun) { observers.visibility = fun; } observe() {}} + }; + const document = {currentScript: {closest: () => root}, createElementNS: element}; + vm.runInNewContext(source, {window, document}); + function flush() { while (queue.length) queue.shift()(); } + function validate() { + assert.equal(svg.children.length, 10 + Number(feedback)); + const obstacles = nodes.concat(inputs).map(node => node.getBoundingClientRect()); + svg.children.filter(group => !group.attributes['data-connection'].startsWith('input-')).forEach(group => { + const points = group.children[0].attributes.points.split(' ').map(p => p.split(',').map(Number)); + points.slice(1).forEach((p, i) => { + const a = points[i]; + assert(a[0] === p[0] || a[1] === p[1], 'connector must be orthogonal'); + obstacles.forEach(r => { + const crosses = a[0] === p[0] ? a[0] > r.left && a[0] < r.right && + Math.max(a[1], p[1]) > r.top && Math.min(a[1], p[1]) < r.bottom : + a[1] > r.top && a[1] < r.bottom && Math.max(a[0], p[0]) > r.left && + Math.min(a[0], p[0]) < r.right; + assert(!crosses, 'connector must avoid text boxes: ' + group.attributes['data-connection']); + }); + }); + }); + assert(svg.children.some(group => group.children[0].attributes['stroke-dasharray'] === '4,3')); + } + flush(); validate(); + assert(observations.includes(root) && observations.includes(graph)); + return {root, graph, svg, selector, pane, reference, observers, flush, validate}; +} +const a = widget(1000, true), b = widget(1000, false); +a.graph.width = 640; a.observers.resize(); a.flush(); a.validate(); +assert.equal(a.graph.attributes['data-layout'], 'compact'); +assert.equal(b.graph.attributes['data-layout'], 'wide'); +a.graph.width = 400; a.observers.resize(); a.flush(); a.validate(); +assert.equal(a.graph.attributes['data-layout'], 'stacked'); +assert(a.svg.attributes.viewBox.startsWith('0 0 400 ')); +a.selector.value = '2'; a.selector.change(); a.flush(); +assert.equal(a.pane.style.display, 'none'); assert.equal(a.reference.style.display, ''); +assert.equal(b.pane.style.display, ''); +a.graph.width = 1000; a.selector.value = '1'; a.selector.change(); a.flush(); a.validate(); +assert.equal(a.graph.attributes['data-layout'], 'wide'); +a.root.visible = false; a.graph.width = 640; a.observers.visibility(); a.flush(); +a.root.visible = true; a.observers.visibility(); a.flush(); a.validate(); +assert.equal(a.graph.attributes['data-layout'], 'compact'); +console.log('Responsive model structure controls passed'); diff --git a/tests/testthat/residual-selection-controls.js b/tests/testthat/residual-selection-controls.js index 300a2173..fc6cacff 100644 --- a/tests/testthat/residual-selection-controls.js +++ b/tests/testthat/residual-selection-controls.js @@ -6,7 +6,10 @@ global.Plotly = { react: async (el, data, layout) => { el.data = data; el.layout = layout; }, addFrames: async (el, frames) => { banks++; el._transitionData = {_frames: frames}; }, deleteFrames: async el => { el._transitionData = {_frames: []}; }, - animate: async () => {} + animate: async () => {}, + relayout: async (el, patch) => { + if (patch["updatemenus[0].active"] !== undefined) el.layout.updatemenus[0].active = patch["updatemenus[0].active"]; + } }; const flush = () => new Promise(resolve => setImmediate(resolve)); function widget() { @@ -30,36 +33,38 @@ const points = el => el.data.reduce((n, trace) => n + trace.x.length, 0); await flush(); assert.equal(points(a), 2); assert.equal(points(b), 2); - assert.deepEqual(a.layout.updatemenus[0].buttons.map(button => button.label), ['Auto', 'Standardized', 'OSA']); + assert.deepEqual(a.layout.updatemenus[0].buttons.map(button => button.label), ['Standardized', 'OSA']); assert.equal(a.layout.updatemenus[0].x, 0); assert.equal(a.layout.updatemenus[0].xanchor, 'left'); assert.equal(a.layout.updatemenus[0].yanchor, 'bottom'); assert.equal(a.layout.updatemenus[0].pad.b, 28); assert.equal(a.layout.margin.t, 100); // Header rows stay clear of the upper-right modebar. chooseFrame(a, 'B'); - assert.equal(points(a), 6); // Auto keeps a model without cached OSA. + assert.equal(points(a), 6); // Initial choice keeps models without cached OSA. + assert.equal(a.layout.updatemenus[0].active, 0); const before = banks; chooseFrame(a, 'A'); chooseFrame(a, 'B'); assert.equal(banks, before); // Native frame changes keep their frame bank. - chooseType(a, 2); await flush(); + chooseType(a, 1); await flush(); assert.equal(a.layout.sliders[0].active, 1); assert.equal(points(a), 0); assert(a.layout.annotations[0].text.includes('OSA residuals unavailable')); assert.equal(points(b), 2); // Widgets have independent selections. - chooseType(a, 1); await flush(); + chooseType(a, 0); await flush(); assert.equal(points(a), 6); assert.equal(a.layout.sliders[0].active, 1); chooseFrame(a, 'A'); assert.equal(points(a), 6); - chooseType(a, 0); await flush(); + chooseType(a, 1); await flush(); assert.equal(points(a), 2); // Partial OSA never fills its gaps from standard residuals. assert(a.layout.annotations[0].text.includes('oneStepGeneric')); - for (let i = 0; i < 3; i++) chooseType(a, i); + for (let i = 0; i < 5; i++) chooseType(a, i % 2); await flush(); await flush(); - assert.equal(a.layout.updatemenus[0].active, 2); + assert.equal(a.layout.updatemenus[0].active, 0); const singleConfig = JSON.parse(JSON.stringify(source)); singleConfig.frames = 'Only'; singleConfig.animated = false; + singleConfig.defaultViews = 1; singleConfig.views.forEach(view => { view.cells = [view.cells[0]]; view.cells[0].data.forEach(trace => { @@ -71,5 +76,9 @@ const points = el => el.data.reduce((n, trace) => n + trace.x.length, 0); assert.deepEqual(single.data[0].x, [2000]); assert.deepEqual(single.data[0].customdata, ['custom']); assert.deepEqual(single.layout.sliders, []); + const noOsaConfig = JSON.parse(JSON.stringify(singleConfig)); + noOsaConfig.showSelector = false; noOsaConfig.defaultViews = 0; + const noOsa = widget(); draw(noOsa, {layout: {}}, noOsaConfig); await flush(); + assert.deepEqual(noOsa.layout.updatemenus, []); console.log('Residual controls passed'); })().catch(error => { console.error(error); process.exit(1); }); diff --git a/tests/testthat/setup-fixtures.R b/tests/testthat/setup-fixtures.R index eedeb842..4bba21cc 100644 --- a/tests/testthat/setup-fixtures.R +++ b/tests/testthat/setup-fixtures.R @@ -64,6 +64,7 @@ if (requireNamespace("RTMB", quietly = TRUE) && exists("cod_obs", inherits = TRU age_breaks = c(3, 14) ) ) + fits <- list(N_dev = N_dev, M_dev = M_dev) } else { default_fit <- NULL N_dev <- NULL diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index e921a3ef..5c51f9d9 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -120,8 +120,6 @@ test_that("numerical diagnostics include optimizer status and use one tolerance" fit$sdrep$gradient.fixed <- .005 expect_true(check_tam(fit)$is_converged) expect_false(check_tam(fit, grad_tol = .001)$is_converged) - fit$grad_tol <- NULL - expect_equal(check_tam(fit)$grad_tol, .01) }) test_that("unavailable and non-finite numerical information cannot pass", { diff --git a/tests/testthat/test-dat.R b/tests/testthat/test-dat.R index 41e8784f..f4c3d05c 100644 --- a/tests/testthat/test-dat.R +++ b/tests/testthat/test-dat.R @@ -153,13 +153,6 @@ test_that("prepare_tam stops if neither M mu_supplied nor mu_form is provided", ) }) -test_that("prepare_tam rejects the retired initialization setting", { - expect_error( - make_test_dat(N_settings = list(process = "off", init_N0 = FALSE)), - "has been retired" - ) -}) - test_that("prepare_tam appends projection years and shapes obs correctly with proj_settings (F_mult API)", { # n_proj = 2, n_mean = 3, status-quo F multiplier = 1 dat <- prepare_tam( diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index e2bf3d64..c6864e70 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -35,7 +35,6 @@ test_that("tam_data adds only a class and validates again after edits", { expect_identical(unclass(x), unclass(data)) expect_identical(as_tam_data(x), x) expect_invisible(check_tam_data(x)) - expect_identical(check_obs(x), check_tam_data(x)) a <- make_test_dat(data = data, years = 1983:1990, ages = 2:6) b <- make_test_dat(data = x, years = 1983:1990, ages = 2:6) expect_identical(make_par(a), make_par(b)) diff --git a/tests/testthat/test-fit.R b/tests/testthat/test-fit.R index 6af8395c..478c3f66 100644 --- a/tests/testthat/test-fit.R +++ b/tests/testthat/test-fit.R @@ -72,16 +72,6 @@ test_that("fit_tam objective is unaffected by projections", { expect_true(all(is.finite(fit$rep$log_pred[is_proj]))) }) -test_that("fit_tam does not estimate missing observation values", { - fit <- update( - default_fit, - catch_settings = list(sd_form = ~1), - index_settings = list(sd_form = ~1, q_form = ~ q_block), - silent = TRUE - ) - expect_false("missing" %in% fit$obj$env$.random) -}) - test_that("update can add arguments absent from the original call", { cl <- update( default_fit, @@ -128,23 +118,6 @@ test_that("fit_retro inherits grad_tol stored on the fit when omitted", { expect_false(any(out$fold_diagnostics$is_converged)) }) -test_that("fit_retro falls back to default grad_tol when fit has none", { - fit <- default_fit - fit$grad_tol <- NULL - fit$sdrep$gradient.fixed[] <- 5e-4 - - implicit <- fit_retro(fit, folds = 0, progress = FALSE) - explicit <- fit_retro(fit, folds = 0, progress = FALSE, grad_tol = 1e-2) - - expect_identical(names(implicit$fits[[1]]), names(explicit$fits[[1]])) - expect_identical( - lapply(implicit$fits[[1]], `[[`, "is_converged"), - lapply(explicit$fits[[1]], `[[`, "is_converged") - ) - expect_identical(names(implicit$obs_pred), names(explicit$obs_pred)) - expect_identical(names(implicit$pop), names(explicit$pop)) -}) - test_that("tam_fit summary and print methods provide structured output", { fit <- default_fit diff --git a/tests/testthat/test-math-audit.R b/tests/testthat/test-math-audit.R index 3f4a9e36..ad9f46af 100644 --- a/tests/testthat/test-math-audit.R +++ b/tests/testthat/test-math-audit.R @@ -113,7 +113,7 @@ test_that("invalid grid boundaries cannot enter cohort and mortality matrices", for (nm in c("catch", "weight", "maturity")) { obs <- cod_obs obs[[nm]] <- rbind(obs[[nm]], obs[[nm]][1, ]) - expect_error(check_obs(obs), "exactly one row per year and age") + expect_error(check_tam_data(obs), "exactly one row per year and age") } }) @@ -165,6 +165,6 @@ test_that("missing formula rows and invalid supplied scales cannot misalign like for (nm in c("catch", "index", "weight", "maturity")) { bad <- cod_obs bad[[nm]]$obs[1] <- -1 - expect_error(check_obs(bad), "non-negative values") + expect_error(check_tam_data(bad), "non-negative values") } }) diff --git a/tests/testthat/test-model-diagram.R b/tests/testthat/test-model-diagram.R index 26e8fe45..b04eba71 100644 --- a/tests/testthat/test-model-diagram.R +++ b/tests/testthat/test-model-diagram.R @@ -83,7 +83,7 @@ test_that("model selectors handle references and independent escaped containers" expect_match(html, 'data-model-pane="1" style="display:none"', fixed = TRUE) expect_match(html, "unavailable for a reporting reference", fixed = TRUE) expect_match(html, "Fit <two> "quoted"", fixed = TRUE) - expect_match(html, "closest('.tam-model-structure')", fixed = TRUE) + expect_match(html, "document.currentScript.closest('.tam-model-structure')", fixed = TRUE) expect_false(grepl("document.querySelector", html, fixed = TRUE)) all_refs <- htmltools::renderTags(plot_model(reference))$html expect_match(all_refs, "unavailable", fixed = TRUE) @@ -91,11 +91,40 @@ test_that("model selectors handle references and independent escaped containers" expect_error(plot_model(default_fit, model_list = fits), "either") }) -test_that("the dedicated Model structure page preserves the dashboard initial page", { +test_that("Model structure opens first and groups its diagram with function calls", { template <- readLines(system.file("rmd", "vis_tam.Rmd", package = "tinyAM")) structure <- readLines(system.file("rmd", "model_structure.Rmd", package = "tinyAM")) expect_true(any(grepl('child = "model_structure.Rmd"', template, fixed = TRUE))) expect_true(any(grepl("plot_model(model_list = fits)", structure, fixed = TRUE))) - expect_gt(which(grepl('child = "model_structure.Rmd"', template, fixed = TRUE)), + expect_lt(which(grepl('child = "model_structure.Rmd"', template, fixed = TRUE)), which(grepl('child = "fisheries.Rmd"', template, fixed = TRUE))) + expect_lt(which(grepl('child = "model_structure.Rmd"', template, fixed = TRUE)), + which(grepl('child = if (is.null(background))', template, fixed = TRUE))) + expect_true(any(grepl("Row {.tabset}", structure, fixed = TRUE))) + expect_true(all(c("### Diagram", "### Function calls") %in% structure)) + tables <- readLines(system.file("rmd", "tables.Rmd", package = "tinyAM")) + expect_false(any(grepl("### Function calls", tables, fixed = TRUE))) + expect_false(any(grepl('Settings {data-navmenu="Tables"}', tables, fixed = TRUE))) +}) + +test_that("diagram nodes inherit typography and explain colours and arrows below", { + html <- htmltools::renderTags(plot_model(default_fit))$html + expect_match(html, '
should fail coverage check obs <- cod_obs drop_n <- min(3L, nrow(obs$weight)) obs$weight <- obs$weight[-seq_len(drop_n), , drop = FALSE] - expect_error(check_obs(obs), "`weight` coverage is incomplete", fixed = TRUE) + expect_error(check_tam_data(obs), "`weight` coverage is incomplete", fixed = TRUE) obs <- cod_obs drop_n <- min(3L, nrow(obs$index)) obs$index <- obs$index[-seq_len(drop_n), , drop = FALSE] - expect_invisible(expect_true(check_obs(obs))) + expect_invisible(expect_true(check_tam_data(obs))) }) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index fb0c07b3..718f38a7 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -1,8 +1,5 @@ ## Globals ---- -suppressWarnings( - source(system.file("examples/example_fits.R", package = "tinyAM")) -) tabs <- tidy_tam(model_list = fits) ## Helpers ---- diff --git a/tests/testthat/test-public-api.R b/tests/testthat/test-public-api.R index ec6b9099..5d237be8 100644 --- a/tests/testthat/test-public-api.R +++ b/tests/testthat/test-public-api.R @@ -7,22 +7,11 @@ test_that("prepare_tam and fit_tam expose the same data and model arguments", { expect_true(all(settings %in% names(formals(fit_tam)))) expect_false(any(c("obs", "...") %in% names(formals(fit_tam)))) expect_identical(as.list(formals(fit_tam))[settings], as.list(formals(prepare_tam))) - expect_false("make_dat" %in% getNamespaceExports("tinyAM")) dat <- prepare_tam(data = cod_obs, years = 2000:2005, ages = 2:6) expect_true("obs" %in% names(dat)) expect_false("data" %in% names(dat)) expect_true(all(vapply(dat$obs[c("catch", "index", "weight", "maturity")], function(x) "obs" %in% names(x), logical(1)))) - expect_error(prepare_tam(obs = cod_obs), "unused argument") - expect_error(fit_tam(obs = cod_obs), "unused argument") -}) - -test_that("both input validators use the same checks", { - expect_identical(check_tam_data(cod_obs), check_obs(cod_obs)) - expect_invisible(check_tam_data(cod_obs)) - invalid <- cod_obs - invalid$index$samp_time[1] <- 2 - expect_error(check_tam_data(invalid), "samp_time") }) test_that("update stores evaluated data under the public argument name", { diff --git a/tests/testthat/test-recruitment-init.R b/tests/testthat/test-recruitment-init.R index 08ab3660..1749486e 100644 --- a/tests/testthat/test-recruitment-init.R +++ b/tests/testthat/test-recruitment-init.R @@ -36,10 +36,6 @@ test_that("stock-recruit boundary years retain their values without extra penalt }) test_that("fits classify initial recruitment correctly and preserve warm starts", { - legacy <- default_fit - legacy$refit_args$rec_settings$init <- NULL - call <- update(legacy, rec_settings = list(process = "iid", mu_form = ~1), evaluate = FALSE) - expect_identical(call$rec_settings$init, "free") f <- update(default_fit, rec_settings = list(init = "latent"), start_par = default_fit, silent = TRUE) expect_true("log_r0" %in% f$obj$env$.random) diff --git a/tests/testthat/test-recruitment.R b/tests/testthat/test-recruitment.R index 56453667..85fd3107 100644 --- a/tests/testthat/test-recruitment.R +++ b/tests/testthat/test-recruitment.R @@ -53,15 +53,25 @@ test_that("recruitment covariates come only from youngest-age population covaria test_that("Gaussian recruitment simulation keeps the anchor and residual convention", { for (type in c("iid", "ar1", "rw")) { spec <- list(process = type, mu_form = ~1, sd = .2, phi = if (type == "ar1") .5 else NULL) - d <- make_test_dat(N_settings = list(process = "off"), rec_settings = spec) + d <- make_test_dat(years = 2000:2006, ages = 2:6, + N_settings = list(process = "off"), rec_settings = spec) p <- make_par(d) p$log_r0 <- 1 if (!is.null(p$rec_beta)) p$rec_beta[] <- 2 set.seed(912) - draws <- replicate(500, tinyAM:::.simulate_rec(p, d)) - expected <- if (type == "rw") 1 else 2 - expect_lt(max(abs(rowMeans(draws) - expected)), if (type == "rw") .15 else .05) - expect_equal(p$log_r0, 1) + actual <- .population_states(p, d, d$W * 0 + .3, simulate = TRUE) + set.seed(912) + noise <- stats::rnorm(length(d$years) - 1L) + expected <- c(1, rep(NA_real_, length(noise))) + for (i in seq_along(noise)) { + mean <- switch(type, iid = 2, rw = expected[i], + ar1 = if (i == 1L) 2 else 2 + .5 * (expected[i] - 2)) + sd <- if (type == "ar1" && i == 1L) .2 / sqrt(1 - .5^2) else .2 + expected[i + 1L] <- mean + sd * noise[i] + } + expect_equal(unname(actual$log_recruitment), expected, tolerance = 1e-12) + expect_equal(unname(actual$log_N[, 1L]), expected, tolerance = 1e-12) + expect_equal(actual$log_recruitment[1L], c(`2000` = p$log_r0)) } }) diff --git a/tests/testthat/test-residual-selection.R b/tests/testthat/test-residual-selection.R index 2fe0caaa..26d7a5f2 100644 --- a/tests/testthat/test-residual-selection.R +++ b/tests/testthat/test-residual-selection.R @@ -13,7 +13,7 @@ residual_plot_data <- function() { residual_config <- function(p) p$jsHooks$render[[1L]]$data residual_points <- function(cell) sum(vapply(cell$data, function(trace) length(trace$x), integer(1))) -test_that("Auto selects retained residuals per model and preserves OSA gaps", { +test_that("initial resolution selects retained residuals per model and preserves OSA gaps", { d <- residual_plot_data(); before <- d auto <- .observation_residual_data(d, "auto") expect_identical(auto$status$residual_type, c("osa", "standardized")) @@ -42,39 +42,41 @@ test_that("public residual plots retain models, labels and unavailable OSA frame expect_equal(vapply(p$x$frames, residual_points, integer(1)), c(2L, 6L)) expect_true(all(vapply(p$x$frames, function(frame) length(frame$traces) > 0L, logical(1)))) expect_identical(plotly::plotly_build(p)$x$frames, p$x$frames) - expect_identical(config$view, 0L) - expect_identical(vapply(config$views, `[[`, character(1), "type"), c("auto", "standardized", "osa")) - expect_equal(vapply(config$views[[1]]$cells, residual_points, integer(1)), c(2L, 6L)) - expect_equal(vapply(config$views[[2]]$cells, residual_points, integer(1)), c(6L, 6L)) - expect_equal(vapply(config$views[[3]]$cells, residual_points, integer(1)), c(2L, 0L)) - note <- config$views[[3]]$cells[[2]]$layout$annotations[[1]]$text + expect_identical(config$view, 1L) + expect_identical(config$defaultViews, c(1L, 0L)) + expect_true(config$showSelector) + expect_identical(vapply(config$views, `[[`, character(1), "type"), c("standardized", "osa")) + expect_equal(vapply(config$views[[1]]$cells, residual_points, integer(1)), c(6L, 6L)) + expect_equal(vapply(config$views[[2]]$cells, residual_points, integer(1)), c(2L, 0L)) + note <- config$views[[2]]$cells[[2]]$layout$annotations[[1]]$text expect_match(note, "OSA residuals unavailable", fixed = TRUE) - expect_match(config$views[[1]]$cells[[1]]$layout$annotations[[1]]$text, + expect_match(config$views[[2]]$cells[[1]]$layout$annotations[[1]]$text, "oneStepGeneric", fixed = TRUE) - annotation <- config$views[[1]]$cells[[1]]$layout$annotations[[1]] + annotation <- config$views[[2]]$cells[[1]]$layout$annotations[[1]] expect_equal(annotation$x, 0) expect_identical(annotation$xanchor, "left") expect_equal(annotation$yshift, 8) slots <- unlist(lapply(config$views, function(view) vapply(view$cells, function(cell) length(cell$data), integer(1)))) expect_length(unique(slots), 1L) - expect_identical(residual_config(fun(d, residual_type = "osa"))$view, 2L) + expect_identical(residual_config(fun(d, residual_type = "osa"))$view, 1L) } expect_identical(d, before) expect_error(plot_resid(d, residual_type = "unknown"), "arg") }) -test_that("Auto is chosen for the whole panel rather than separately for animation ages", { +test_that("overlays choose one type for the whole panel before animation", { d <- residual_plot_data() p <- plot_resid(d, frame = ~age, color = ~model, colors = c("#001122", "#ee8800")) config <- residual_config(p) status <- config$views[[1]]$cells[[2]]$status - expect_identical(status$residual_type, c("osa", "standardized")) - expect_equal(status$n, c(0L, 3L)) - expect_equal(residual_points(config$views[[1]]$cells[[2]]), 3L) + expect_identical(status$residual_type, c("standardized", "standardized")) + expect_equal(status$n, c(3L, 3L)) + expect_identical(config$defaultViews, c(0L, 0L)) + expect_equal(residual_points(p$x$frames[[2]]), 6L) p <- plot_resid(d, frame = ~model, color = ~model, colors = c("#001122", "#ee8800")) config <- residual_config(p) for (i in 1:2) { - nonempty <- Filter(function(trace) length(trace$x), config$views[[2]]$cells[[i]]$data) + nonempty <- Filter(function(trace) length(trace$x), config$views[[1]]$cells[[i]]$data) expect_identical(nonempty[[1]]$marker$color, c("#001122", "#ee8800")[i]) } }) @@ -85,14 +87,15 @@ test_that("residual views preserve custom hover, scalar inputs and process bubbl p <- plot_resid(d, text = ~paste("custom", year), hovertemplate = "Custom: %{text}", residual_type = "standardized") expect_false(residual_config(p)$animated) - expect_identical(residual_config(p)$view, 1L) - traces <- Filter(function(trace) length(trace$x), residual_config(p)$views[[2]]$cells[[1]]$data) + expect_identical(residual_config(p)$view, 0L) + traces <- Filter(function(trace) length(trace$x), residual_config(p)$views[[1]]$cells[[1]]$data) expect_identical(traces[[1]]$hovertemplate, "Custom: %{text}") expect_match(traces[[1]]$text, "custom", fixed = TRUE) - expect_match(residual_config(plot_bubbles(d))$views[[1]]$cells[[1]]$layout$annotations[[1]]$text, + expect_match(residual_config(plot_bubbles(d))$views[[2]]$cells[[1]]$layout$annotations[[1]]$text, "method unspecified", fixed = TRUE) d$osa_res <- NA_real_ expect_identical(residual_config(plot_resid(d))$views[[1]]$cells[[1]]$status$residual_type, "standardized") + expect_false(residual_config(plot_resid(d))$showSelector) d$std_res <- NA_real_ expect_equal(residual_points(residual_config(plot_resid(d))$views[[1]]$cells[[1]]), 0L) process <- data.frame(year = 2000:2001, age_block = c("2-4", "5-8"), est = c(-1, 2)) @@ -100,6 +103,7 @@ test_that("residual views preserve custom hover, scalar inputs and process bubbl expect_s3_class(p, "plotly") expect_null(p$jsHooks$render) expect_equal(sum(vapply(plotly::plotly_build(p)$x$data, function(trace) length(trace$x), integer(1))), 2L) + expect_true(all(vapply(plotly::plotly_build(p)$x$data, function(trace) identical(trace$marker$line$width, 0), logical(1)))) }) test_that("native residual dropdown and frames coordinate in independent widgets", { @@ -113,3 +117,35 @@ test_that("native residual dropdown and frames coordinate in independent widgets expect_null(attr(result, "status")) expect_match(paste(result, collapse = "\n"), "Residual controls passed", fixed = TRUE) }) + + +test_that("overlay defaults require eligible OSA in every displayed model", { + d <- residual_plot_data() + p <- plot_resid(d) + config <- residual_config(p) + expect_identical(config$view, 0L) + expect_equal(residual_points(list(data=p$x$data)), 12L) + d$osa_res[7L] <- -.5 + p <- plot_resid(d, frame=~age) + expect_identical(residual_config(p)$defaultViews, c(1L, 1L)) + expect_equal(residual_points(p$x$frames[[2]]), 0L) + traces <- do.call(c, lapply(residual_config(plot_bubbles(d))$views, function(view) + do.call(c, lapply(view$cells, `[[`, "data")))) + expect_true(all(vapply(traces, function(trace) identical(trace$marker$line$width, 0), logical(1)))) +}) + +test_that("explicit hover vectors follow model frames and partial OSA rows", { + d <- residual_plot_data() + labels <- paste0("row-", seq_len(nrow(d))) + p <- plot_resid(d, frame = ~model, text = labels, + customdata = seq_len(nrow(d)), hovertemplate = "%{text}: %{customdata}") + osa <- residual_config(p)$views[[2]]$cells[[1]] + traces <- Filter(function(trace) length(trace$x), osa$data) + expect_identical(as.character(traces[[1]]$text), labels[1:2]) + expect_equal(as.numeric(traces[[1]]$customdata), 1:2) + expect_true(all(as.character(traces[[1]]$hovertemplate) == "%{text}: %{customdata}")) + standard <- residual_config(p)$views[[1]]$cells[[2]] + traces <- Filter(function(trace) length(trace$x), standard$data) + expect_identical(as.character(traces[[1]]$text), labels[7:12]) + expect_equal(as.numeric(traces[[1]]$customdata), 7:12) +}) diff --git a/tests/testthat/test-retro-vis.R b/tests/testthat/test-retro-vis.R index 66c6e31b..0edc0bca 100644 --- a/tests/testthat/test-retro-vis.R +++ b/tests/testthat/test-retro-vis.R @@ -1,4 +1,4 @@ -test_that("S3 dispatch preserves legacy fit, reference and list labels", { +test_that("S3 dispatch preserves fit, reference and list labels", { testthat::local_mocked_bindings(.render_vis_tam = function(fits, ...) names(fits), .package = "tinyAM") first <- second <- default_fit diff --git a/tests/testthat/test-settings.R b/tests/testthat/test-settings.R index e7868a67..a6e6e1db 100644 --- a/tests/testthat/test-settings.R +++ b/tests/testthat/test-settings.R @@ -107,7 +107,6 @@ test_that("Usage shows every supported settings entry and optional projections", }) test_that("recruitment settings validate and merge independently of survival", { - expect_error(make_test_dat(N_settings = list(rec_form = ~ rw(year))), "has moved") expect_error(make_test_dat(rec_settings = list(process = "iid")), "mu_form is required") expect_error(make_test_dat(rec_settings = list(process = "ar1")), "mu_form is required") expect_error(make_test_dat(rec_settings = list(process = "off")), "mu_form is required") diff --git a/tests/testthat/test-sim.R b/tests/testthat/test-sim.R index b35422e5..4ace4411 100644 --- a/tests/testthat/test-sim.R +++ b/tests/testthat/test-sim.R @@ -1,6 +1,3 @@ -suppressWarnings( - source(system.file("examples/example_fits.R", package = "tinyAM")) -) fit <- N_dev ## sim_tam ---- diff --git a/tests/testthat/test-smooth-formulas.R b/tests/testthat/test-smooth-formulas.R index 79a95ca0..f0ccc911 100644 --- a/tests/testthat/test-smooth-formulas.R +++ b/tests/testthat/test-smooth-formulas.R @@ -103,7 +103,7 @@ test_that("temporal smooth forecasts hold training-year values without future ba historical <- .parse_q_formula(form,d) actual <- .parse_q_formula(form,full) for (j in seq_along(actual$q_terms)) { - expect_true(.smooth_basis_compatible(historical$q_terms[[j]],actual$q_terms[[j]])) + expect_false(is.null(.smooth_basis_transform(historical$q_terms[[j]],actual$q_terms[[j]]))) expect_equal(actual$q_terms[[j]]$design[!full$is_proj,,drop=FALSE],historical$q_terms[[j]]$design) expect_equal(unname(actual$q_terms[[j]]$design[full$is_proj,,drop=FALSE]), unname(actual$q_terms[[j]]$design[full$year == 2007,,drop=FALSE])) @@ -287,10 +287,10 @@ test_that("smooth warm starts preserve functions and penalties under explicit ro expect_false(any(colnames(d$q_terms[[1]]$smooth_fixed) %in% names(rejected$log_q))) changed <- d$q_terms[[1]] changed$basis_signature$grid$age <- changed$basis_signature$grid$age+.01 - expect_false(.smooth_basis_compatible(d$q_terms[[1]],changed)) + expect_null(.smooth_basis_transform(d$q_terms[[1]],changed)) changed <- d$q_terms[[1]] changed$scope <- list(type="survey",name="different",id="survey:different") - expect_false(.smooth_basis_compatible(d$q_terms[[1]],changed)) + expect_null(.smooth_basis_transform(d$q_terms[[1]],changed)) fake$dat <- old fake$dat$q_terms <- fake$dat$q_terms[-1] rejected <- suppressMessages(.start_parameters(fake,d)) diff --git a/tests/testthat/test-ssb-timing.R b/tests/testthat/test-ssb-timing.R index 5c64a015..4b8db4a5 100644 --- a/tests/testthat/test-ssb-timing.R +++ b/tests/testthat/test-ssb-timing.R @@ -127,7 +127,7 @@ test_that("timing is validated even at immature and hidden biological ages", { for (value in list(NA_real_, NaN, Inf, -.1, 1.1, "fall", factor("fall"))) { data <- timed_obs() data$maturity$spawn_time <- value - expect_error(check_obs(data), "spawn_time") + expect_error(check_tam_data(data), "spawn_time") expect_error(make_test_dat(data = data, ages = 2:8), "spawn_time") } data <- timed_obs() diff --git a/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R index a8ac0a50..8c841505 100644 --- a/tests/testthat/test-tidy.R +++ b/tests/testthat/test-tidy.R @@ -45,19 +45,6 @@ test_that("tidy_array respects value_name and converts numeric-like dimnames", { }) -## tidy_mat ---- - -test_that("tidy_mat is an alias of tidy_array", { - m <- matrix( - 1:6, - nrow = 2, - dimnames = list(age = c("2", "3"), year = c("2001", "2002", "2003")) - ) - a <- tidy_array(m) - b <- tidy_mat(m) - expect_identical(a, b) -}) - test_that("tidy_array handles 3D arrays, converting only numeric-like dims", { a <- array( 1:8, diff --git a/tests/testthat/test-validation-feedback.R b/tests/testthat/test-validation-feedback.R index 6b237362..15b310f2 100644 --- a/tests/testthat/test-validation-feedback.R +++ b/tests/testthat/test-validation-feedback.R @@ -3,7 +3,6 @@ test_that("input validation reports success while preserving its logical return" expect_message(check_tam_data(cod_obs), "fleets: 1; surveys: 1") expect_silent(result <- check_tam_data(cod_obs, quiet = TRUE)) expect_identical(result, TRUE) - expect_silent(expect_identical(check_obs(cod_obs, quiet = TRUE), TRUE)) for (quiet in list(NA, 1, "yes", logical())) { expect_error(check_tam_data(cod_obs, quiet = quiet), "quiet.*TRUE or FALSE") } diff --git a/tests/testthat/test-vis.R b/tests/testthat/test-vis.R index 418e8396..ba203900 100644 --- a/tests/testthat/test-vis.R +++ b/tests/testthat/test-vis.R @@ -1,9 +1,5 @@ ## vis_tam ---- -suppressWarnings( - source(system.file("examples/example_fits.R", package = "tinyAM")) -) - dashboard_plots <- function(file) { # Embedded Plotly code contains Ctrl-Z, which ends Windows text-mode reads. con <- file(file, "rb") @@ -211,32 +207,6 @@ test_that("render_args must be a named list", { ) }) -test_that("vis_tam accepts models provided via dots", { - tmpfile <- tempfile(fileext = ".html") - - expect_no_error({ - vis_tam(N_dev, M_dev, - output_file = tmpfile, open_file = FALSE, - render_args = list(quiet = TRUE) - ) - }) - - expect_true(file.exists(tmpfile)) -}) - -test_that("vis_tam accepts list input supplied through dots", { - tmpfile <- tempfile(fileext = ".html") - - expect_no_error({ - vis_tam(list(N_dev = N_dev, M_dev = M_dev), - output_file = tmpfile, open_file = FALSE, - render_args = list(quiet = TRUE) - ) - }) - - expect_true(file.exists(tmpfile)) -}) - test_that("vis_tam rejects unnamed or duplicated model lists", { unnamed <- list(N_dev, M_dev) duped <- structure(list(N_dev, M_dev), names = c("N_dev", "N_dev")) @@ -515,7 +485,7 @@ test_that("tam_ref objects accept a Background page", { call_start <- regexpr('
', visible_html, perl = TRUE ))