---
title: "Developments of the RTMB version of the ADMB pollock model"
subtitle: 'September 2026 Plan Team working paper on the corrected full-age 2024 "PM" model bridge and subsequent RTMB developments'
author:
- name: James Ianelli
corresponding: true
orcid: 0000-0002-7170-8677
email: jim.ianelli@noaa.gov
affiliation:
- name: Alaska Fisheries Science Center
city: Seattle
state: WA
date: today
date-format: "MMMM D, YYYY"
lang: en-US
bibliography: ../references/software.bib
link-citations: true
abstract: |
The eastern Bering Sea walleye pollock assessment has long used a custom
AD Model Builder (ADMB) model. This working paper documents its translation
to R Template Model Builder (RTMB) and evaluates agreement between the two
implementations at a common parameter set. The report presents model fits,
fishery and survey selectivity analyses, projections, retrospective results,
and SparseNUTS diagnostics. Candidate refinements are evaluated relative to
the accepted ADMB assessment model.
execute:
echo: false
warning: false
message: false
format:
html:
css: branding.css
toc: true
toc-depth: 3
number-sections: true
embed-resources: true
lightbox: true
code-fold: true
code-summary: "Show code"
code-tools: true
code-copy: true
smooth-scroll: true
link-external-newwindow: true
fig-responsive: true
theme:
light: cosmo
dark: darkly
pdf:
toc: true
toc-depth: 3
number-sections: true
documentclass: scrreprt
classoption:
- open=any
- titlepage=false
papersize: letter
fontsize: 9pt
geometry:
- margin=0.7in
pdf-engine: xelatex
include-before-body: branding-rtmb.tex
keep-tex: true
colorlinks: true
params:
bridge_case: "corrected_full_age_bts"
admb_run_dir: "analysis/output/corrected_full_age_bts/admb_root/runs/full_age_bts"
bts_comp_normalization: "full_ages"
model_file: "analysis/output/corrected_full_age_bts/rtmb_base.rds"
legacy_model_file: "analysis/output/base.rds"
only_bts_file: "analysis/output/corrected_full_age_bts/only_bts.rds"
retro_file: "analysis/output/corrected_full_age_bts/retro_9_peel.rds"
osa_output_file: "analysis/output/corrected_full_age_bts/osa/rtmb_ebswp_osa_residuals.rds"
sparsenuts_file: "analysis/output/sparsenuts/fishery_sel_forms/rtmb_ebswp_sparsenuts_form_2_sparse_adapt095.rds"
projection_dir: "analysis/output/corrected_full_age_bts/spmR_projection"
projection_alt2_dir: "analysis/output/corrected_full_age_bts/spmR_projection_alt2_fixed1300"
refit: false
run_sparsenuts: false
force_sparsenuts: false
---
::: {.content-visible when-format="html"}
::: {.pollock-brand .framework-rtmb}
{fig-alt="Circular Alaska Pollock mark showing a walleye pollock, mountain and water motifs, and Alaska Fisheries Science Center and NOAA NMFS identification." width="32%"}
::: {.pollock-brand-label}
RTMB TECHNICAL REPORT
:::
:::
:::
```{r setup}
#| include: false
suppressPackageStartupMessages({
library(dplyr)
library(tidyr)
library(ggplot2)
library(ggthemes)
library(ggridges)
library(cowplot)
library(gt)
library(knitr)
library(tibble)
})
theme_set(ggthemes::theme_few())
if (!exists("params", inherits = FALSE)) {
params <- list(
bridge_case = "corrected_full_age_bts",
admb_run_dir = "analysis/output/corrected_full_age_bts/admb_root/runs/full_age_bts",
bts_comp_normalization = "full_ages",
model_file = "analysis/output/corrected_full_age_bts/rtmb_base.rds",
legacy_model_file = "analysis/output/base.rds",
only_bts_file = "analysis/output/corrected_full_age_bts/only_bts.rds",
retro_file = "analysis/output/corrected_full_age_bts/retro_9_peel.rds",
osa_output_file = "analysis/output/corrected_full_age_bts/osa/rtmb_ebswp_osa_residuals.rds",
sparsenuts_file = "analysis/output/sparsenuts/fishery_sel_forms/rtmb_ebswp_sparsenuts_form_2_sparse_adapt095.rds",
projection_dir = "analysis/output/corrected_full_age_bts/spmR_projection",
projection_alt2_dir = "analysis/output/corrected_full_age_bts/spmR_projection_alt2_fixed1300",
run_sparsenuts = FALSE,
force_sparsenuts = FALSE,
refit = FALSE
)
}
`%||%` <- function(x, y) {
if (is.null(x) || length(x) == 0) y else x
}
param_is_true <- function(x) {
isTRUE(x) || (
is.character(x) &&
length(x) > 0 &&
tolower(x[1]) %in% c("true", "t", "yes", "y", "1")
)
}
drop_all_na_cols <- function(data) {
data |>
select(where(~!all(is.na(.x))))
}
gt_report <- function(data, ...) {
data <- drop_all_na_cols(data)
table <- gt(data, ...)
integer_cols <- names(data)[tolower(names(data)) %in% c("year", "age")]
if (length(integer_cols) > 0) {
table <- table |>
fmt_number(columns = all_of(integer_cols), decimals = 0, use_seps = FALSE)
}
table
}
qmd_file <- tryCatch(knitr::current_input(dir = TRUE), error = function(e) NULL)
if (is.null(qmd_file)) {
qmd_dir <- normalizePath(file.path(getwd(), "reporting"), mustWork = FALSE)
} else {
qmd_dir <- dirname(normalizePath(qmd_file, mustWork = TRUE))
}
rtmb_root <- normalizePath(file.path(qmd_dir, ".."), mustWork = TRUE)
resolve_pollock_root <- function(rtmb_root) {
has_bridge <- function(path) {
if (is.na(path) || !nzchar(path)) return(FALSE)
file.exists(file.path(path, "admb", "runs", "for_rtmb", "pm.rep")) &&
file.exists(file.path(path, "admb", "runs", "for_rtmb", "pm.par")) &&
file.exists(file.path(path, "admb", "runs", "data", "pm_24.dat"))
}
env_root <- Sys.getenv("POLLOCK_ROOT", unset = NA_character_)
if (is.na(env_root) || !nzchar(env_root)) {
env_root <- Sys.getenv("POLLOCK_BASE", unset = NA_character_)
}
if (!is.na(env_root) && nzchar(env_root)) {
return(normalizePath(env_root, mustWork = TRUE))
}
candidates <- c(rtmb_root, dirname(rtmb_root), file.path(dirname(rtmb_root), "pollock"))
for (cand in candidates) {
if (has_bridge(cand)) {
return(normalizePath(cand, mustWork = TRUE))
}
}
stop("Cannot locate pollock bridge inputs. Set POLLOCK_ROOT or use bundled admb/runs files.")
}
pollock_root <- resolve_pollock_root(rtmb_root)
rtmb_file <- function(...) normalizePath(file.path(rtmb_root, ...), mustWork = FALSE)
pollock_file <- function(...) normalizePath(file.path(pollock_root, ...), mustWork = FALSE)
display_path <- function(path) {
path <- as.character(path)
repo_label <- if (knitr::is_latex_output()) "repo" else "[repo]"
pollock_label <- if (knitr::is_latex_output()) "pollock" else "[pollock]"
path <- ifelse(startsWith(path, rtmb_root), paste0(repo_label, substring(path, nchar(rtmb_root) + 1L)), path)
path <- ifelse(startsWith(path, pollock_root), paste0(pollock_label, substring(path, nchar(pollock_root) + 1L)), path)
path
}
model_file <- rtmb_file(params$model_file)
legacy_model_file <- rtmb_file(params$legacy_model_file %||% "analysis/output/base.rds")
only_bts_file <- rtmb_file(params$only_bts_file %||% "analysis/output/corrected_full_age_bts/only_bts.rds")
retro_file <- rtmb_file(params$retro_file %||% "analysis/output/corrected_full_age_bts/retro_9_peel.rds")
osa_output_file <- rtmb_file(params$osa_output_file %||% "analysis/output/corrected_full_age_bts/osa/rtmb_ebswp_osa_residuals.rds")
sparsenuts_file <- rtmb_file(params$sparsenuts_file)
projection_dir <- rtmb_file(params$projection_dir %||% "analysis/output/corrected_full_age_bts/spmR_projection")
projection_alt2_dir <- rtmb_file(params$projection_alt2_dir %||% "analysis/output/corrected_full_age_bts/spmR_projection_alt2_fixed1300")
if (!file.exists(model_file)) {
stop("Missing saved RTMB output at: ", model_file, "\nRun: Rscript R/write_output.R")
}
Sys.setenv(
EBSWP_BRIDGE_CASE = params$bridge_case,
EBSWP_ADMB_RUN_DIR = rtmb_file(params$admb_run_dir),
EBSWP_BTS_COMP_NORMALIZATION = params$bts_comp_normalization
)
rtmb_env <- new.env(parent = globalenv())
rtmb_env$rm <- function(...) invisible(NULL)
rtmb_env$source <- function(file, ...) {
base::source(file, local = parent.frame(), ...)
}
source(rtmb_file("R", "config.R"), local = rtmb_env)
data <- rtmb_env$data
pm <- rtmb_env$pm
obj <- rtmb_env$obj
rpm <- rtmb_env$rpm
parms <- rtmb_env$parms
admb_rep_path <- rtmb_env$admb_rep_path
admb_par_path <- rtmb_env$admb_par_path
if (is.null(admb_rep_path)) {
admb_rep_path <- rtmb_file("admb", "runs", "for_rtmb", "pm.rep")
}
if (is.null(admb_par_path)) {
admb_par_path <- rtmb_file("admb", "runs", "for_rtmb", "pm.par")
}
compare_max_pct <- rtmb_env$compare_max_pct
if (isTRUE(params$refit)) {
fit <- nlminb(obj$par, obj$fn, obj$gr)
rtmb_report <- obj$report()
rtmb_metadata <- list(
model = "rtmb_ebswp",
created = Sys.time(),
admb_rep = admb_rep_path,
admb_par = admb_par_path,
objective = fit$objective,
convergence = fit$convergence,
max_gradient = max(abs(obj$gr(fit$par)), na.rm = TRUE)
)
} else {
saved <- readRDS(model_file)
rtmb_report <- saved$report
rtmb_metadata <- saved$metadata
}
legacy_saved <- if (file.exists(legacy_model_file)) readRDS(legacy_model_file) else NULL
legacy_report <- legacy_saved$report %||% NULL
rtmb_bridge_comparison <- if (exists("saved") && !is.null(saved$bridge_comparison)) {
as_tibble(saved$bridge_comparison)
} else {
as_tibble(compare_max_pct(rtmb_report, pm, tolerance = 1e-5))
}
only_bts_saved <- NULL
only_bts_report <- NULL
only_bts_metadata <- NULL
if (file.exists(only_bts_file)) {
only_bts_saved <- readRDS(only_bts_file)
only_bts_report <- only_bts_saved$report
only_bts_metadata <- only_bts_saved$metadata
}
retro_saved <- NULL
retro_diagnostics <- tibble()
retro_series <- tibble()
retro_mohn <- tibble()
retro_mohn_comparisons <- tibble()
if (file.exists(retro_file)) {
retro_saved <- readRDS(retro_file)
retro_diagnostics <- as_tibble(retro_saved$diagnostics)
retro_series <- as_tibble(retro_saved$series %||% data.frame())
retro_mohn <- as_tibble(retro_saved$mohn$rho %||% data.frame())
retro_mohn_comparisons <- as_tibble(
retro_saved$mohn$comparisons %||% data.frame()
)
}
years <- data$styr:data$endyr
ages <- seq_len(data$nages)
terminal_year <- max(years)
first_year <- min(years)
as_year_age_df <- function(x, row_years, fleet_name, value_col, age_values = ages) {
out <- as_tibble(x, .name_repair = "minimal")
names(out) <- age_values
out |>
mutate(year = row_years, .before = 1) |>
pivot_longer(-year, names_to = "age", values_to = "value") |>
rename(!!value_col := value) |>
mutate(age = as.integer(age), fleet = fleet_name)
}
normalize_agecomp <- function(data, value_col) {
value_col <- rlang::ensym(value_col)
data |>
group_by(fleet, year) |>
mutate(
.total = sum(!!value_col, na.rm = TRUE),
!!value_col := ifelse(is.finite(.total) & .total > 0, !!value_col / .total, NA_real_)
) |>
ungroup() |>
select(-.total)
}
make_agecomp_fit <- function(obs, pred, row_years, fleet_name, age_values = ages) {
observed <- as_year_age_df(obs, row_years, fleet_name, "observed", age_values = age_values) |>
normalize_agecomp(observed)
predicted <- as_year_age_df(pred, row_years, fleet_name, "predicted", age_values = age_values) |>
normalize_agecomp(predicted)
full_join(observed, predicted, by = c("fleet", "year", "age")) |>
filter(is.finite(observed) | is.finite(predicted))
}
plot_agecomp_fit <- function(data, fleet_name, ncol = 4) {
plot_data <- data |>
filter(fleet == fleet_name, is.finite(observed) | is.finite(predicted))
ggplot(plot_data, aes(x = age)) +
geom_line(aes(y = predicted), linewidth = 0.5, color = "#4daf4a", na.rm = TRUE) +
geom_point(aes(y = observed), color = "#1f78b4", size = 0.9, alpha = 0.8, na.rm = TRUE) +
facet_wrap(~year, ncol = ncol, dir = "v") +
scale_y_continuous(limits = c(0, NA)) +
labs(x = "Age", y = "Proportion", title = paste(fleet_name, "Age Composition Fits"))
}
make_comp_residuals <- function(data, sample_sizes) {
data |>
left_join(sample_sizes, by = c("fleet", "year")) |>
filter(is.finite(observed), is.finite(predicted), is.finite(n_eff), n_eff > 0) |>
mutate(
observed_count = n_eff * observed,
expected_count = n_eff * predicted,
residual = (observed_count - expected_count) /
sqrt(pmax(expected_count, .Machine$double.eps)),
sign = ifelse(residual < 0, "Negative", "Positive"),
outlier = ifelse(abs(residual) > 3, "|residual| > 3", "|residual| <= 3")
)
}
plot_comp_residual_bubbles <- function(data, fleet_name) {
plot_data <- data |> filter(fleet == fleet_name)
ggplot(
plot_data,
aes(x = year, y = age, color = sign, size = abs(residual),
shape = outlier, alpha = abs(residual))
) +
geom_point() +
scale_color_manual(values = c(Negative = "#1f78b4", Positive = "#d95f02")) +
scale_size(range = c(0.3, 4)) +
scale_y_continuous(breaks = sort(unique(plot_data$age))) +
labs(
x = "Year",
y = "Age",
color = "Sign",
size = "Absolute residual",
shape = NULL,
alpha = "Absolute residual"
) +
theme(legend.position = "top")
}
make_weighted_aggregate_agecomp <- function(data, sample_sizes) {
data |>
left_join(sample_sizes, by = c("fleet", "year")) |>
filter(
is.finite(observed),
is.finite(predicted),
is.finite(n_eff),
n_eff > 0
) |>
group_by(fleet, age) |>
summarize(
observed = sum(n_eff * observed, na.rm = TRUE) / sum(n_eff, na.rm = TRUE),
expected = sum(n_eff * predicted, na.rm = TRUE) / sum(n_eff, na.rm = TRUE),
.groups = "drop"
)
}
plot_weighted_aggregate_agecomp <- function(data) {
ggplot(data, aes(x = age)) +
geom_col(aes(y = observed), fill = "#9ecae1", color = "#2b8cbe", alpha = 0.65, width = 0.85) +
geom_line(aes(y = expected), color = "#e41a1c", linewidth = 0.8) +
geom_point(aes(y = expected), color = "#e41a1c", size = 1.4) +
facet_wrap(~fleet, nrow = 1, scales = "free_x") +
scale_x_continuous(breaks = sort(unique(data$age))) +
scale_y_continuous(limits = c(0, NA)) +
labs(x = "Age", y = "Proportion", title = "Sample-Size Weighted Aggregate Age-Composition Fits")
}
plot_residual_qq <- function(data) {
plot_data <- data |>
filter(is.finite(residual))
label_data <- plot_data |>
group_by(fleet) |>
summarize(
sdnr = sd(residual, na.rm = TRUE),
.groups = "drop"
)
ggplot(plot_data, aes(sample = residual)) +
stat_qq(size = 0.7, alpha = 0.7) +
stat_qq_line(color = "#d95f02") +
geom_text(
data = label_data,
aes(x = -Inf, y = Inf, label = paste0("SDNR = ", round(sdnr, 2))),
inherit.aes = FALSE,
hjust = -0.05,
vjust = 1.2,
size = 3
) +
facet_wrap(~fleet, scales = "free") +
labs(x = "Theoretical quantiles", y = "Sample quantiles", title = "OSA Residual QQ Diagnostics")
}
plot_osa_aggregate_panel <- function(residual_data, aggregate_data, osa_output = NULL) {
qq_plot <- plot_residual_qq(residual_data)
cowplot::plot_grid(
qq_plot,
plot_weighted_aggregate_agecomp(aggregate_data),
ncol = 1,
rel_heights = c(1, 1)
)
}
osa_helper_file <- pollock_file("R", "plot_osa_comps.R")
osa_plot_file <- file.path(dirname(osa_output_file), "osa_age_diagnostics.png")
osa_env <- new.env(parent = globalenv())
osa_helper_loaded <- FALSE
osa_res_multi_loaded <- FALSE
osa_output <- NULL
osa_precomputed_available <- file.exists(osa_output_file)
if (isTRUE(osa_precomputed_available)) {
osa_output <- readRDS(osa_output_file)
}
if (file.exists(osa_helper_file)) {
tryCatch({
source(osa_helper_file, local = osa_env)
osa_helper_loaded <- exists("plot_osa_comps", envir = osa_env, inherits = FALSE)
}, error = function(e) {
osa_helper_loaded <<- FALSE
})
}
if (requireNamespace("afscOSA", quietly = TRUE)) {
tryCatch({
osa_env$resMulti <- get("resMulti", envir = asNamespace("afscOSA"))
osa_res_multi_loaded <- TRUE
}, error = function(e) {
osa_res_multi_loaded <<- FALSE
})
}
osa_helper_ready <- osa_helper_loaded &&
osa_res_multi_loaded &&
requireNamespace("reshape2", quietly = TRUE) &&
requireNamespace("cowplot", quietly = TRUE)
osa_residual_method <- if (isTRUE(osa_precomputed_available)) {
paste0(
"afscOSA ", osa_output$afscOSA_version %||% "version not recorded",
" output generated from the corrected full-age BTS RTMB bridge"
)
} else if (isTRUE(osa_helper_ready)) {
"R/plot_osa_comps.R with afscOSA::resMulti"
} else {
"Pearson residual fallback for composition data"
}
osa_residual_df <- if (isTRUE(osa_precomputed_available)) {
bind_rows(lapply(osa_output$runs, `[[`, "res")) |>
as_tibble() |>
mutate(
age = as.integer(index),
residual = as.numeric(resid),
sign = ifelse(residual < 0, "Negative", "Positive")
) |>
filter(!(fleet %in% c("BTS", "ATS") & age == 1))
} else {
NULL
}
make_osa_composition_inputs <- function(data, sample_sizes, fleet_name) {
plot_data <- data |>
filter(fleet == fleet_name) |>
arrange(year, age)
observed <- plot_data |>
select(year, age, observed) |>
pivot_wider(names_from = age, values_from = observed) |>
arrange(year)
predicted <- plot_data |>
select(year, age, predicted) |>
pivot_wider(names_from = age, values_from = predicted) |>
arrange(year)
pearson <- plot_data |>
select(year, age, residual) |>
pivot_wider(names_from = age, values_from = residual) |>
arrange(year)
input_years <- observed$year
input_ages <- as.integer(names(observed)[-1])
input_neff <- sample_sizes |>
filter(fleet == fleet_name) |>
arrange(match(year, input_years)) |>
filter(year %in% input_years) |>
pull(n_eff)
list(
obs = as.matrix(select(observed, -year)),
exp = as.matrix(select(predicted, -year)),
pearson = as.matrix(select(pearson, -year)),
index = input_ages,
years = input_years,
neff = input_neff
)
}
plot_osa_comps_for_fleet <- function(fleet_name) {
if (isTRUE(osa_precomputed_available)) {
plot_data <- osa_residual_df |> filter(fleet == fleet_name)
return(
ggplot(
plot_data,
aes(x = year, y = age, color = sign, size = abs(residual),
shape = outlier, alpha = abs(residual))
) +
geom_point() +
scale_color_manual(values = c(Negative = "#1f78b4", Positive = "#d95f02")) +
scale_size(range = c(0.3, 4)) +
scale_y_continuous(breaks = sort(unique(plot_data$age))) +
labs(
x = "Year",
y = "Age",
color = "Sign",
size = "Absolute OSA residual",
shape = NULL,
alpha = "Absolute OSA residual"
) +
theme(legend.position = "top")
)
}
if (!isTRUE(osa_helper_ready)) {
return(plot_comp_residual_bubbles(composition_residual_df, fleet_name))
}
input <- make_osa_composition_inputs(agecomp_df, sample_size_df, fleet_name)
osa_env$plot_osa_comps(
obs = input$obs,
exp = input$exp,
pearson = input$pearson,
index = input$index,
years = input$years,
index_label = "Age",
Neff = input$neff,
stock = "RTMB_ADMB",
survey = fleet_name,
do_pdf = FALSE
)
}
```
# Executive Summary
::: {.content-visible when-format="html"}
[Download a PDF version of this report](ebs_pollock_rtmb_ebswp_assessment.pdf){.btn .btn-primary download="ebs_pollock_rtmb_ebswp_assessment.pdf"}
:::
The custom ADMB pollock model has been translated into RTMB and evaluated at
the same parameter estimates as the ADMB model. The corrected comparison
normalizes observed and predicted bottom trawl survey (BTS) age compositions
across ages 1--15 and applies the nominal integer sample sizes. The
fixed-parameter results isolate differences between implementations from
differences caused by estimation. The same corrected specification was used
for model-fit summaries, projections, retrospective peels, and sensitivities.
The principal developments are:
- an RTMB implementation of the ADMB population dynamics and likelihood;
- comparisons of state variables, predictions, and likelihood components;
- selectable fishery-selectivity forms, including hierarchical
time-varying and two-dimensional autoregressive alternatives;
- RTMB-based retrospective and uncertainty analyses.
The fixed-parameter comparison showed negligible differences between ADMB and
RTMB for the tested configuration. Alternative selectivity formulations and
diagnostic analyses are presented for review and do not alter current
management advice, which remains based on the accepted ADMB assessment model.
This document is the primary model-development report for the September 2026
Plan Team meeting. Companion SPoRC and Rceattle analyses provide comparisons
with more general modeling frameworks. Among these alternatives, Rceattle is
the leading candidate for future operational assessment development, subject
to resolution of the remaining diagnostics and the established review process.
# Purpose and Scope
This document evaluates an RTMB translation of the EBS pollock ADMB assessment
model. It follows the assessment-reporting framework used for the FIMS, SPoRC,
and Rceattle comparisons and emphasizes agreement with ADMB, model fit,
diagnostics, and candidate refinements.
The analyses use a corrected comparison in which observed and predicted BTS
age compositions span ages 1--15 and nominal integer sample sizes enter the
likelihood. A historical configuration is retained only to quantify the effect
of that correction.
## September 2026 Plan Team review context
Three model-development reports are intended to be presented and discussed
together. They address different questions and should not be interpreted as
three competing operational assessments.
| Report | Role in the September 2026 review | Current interpretation |
|---|---|---|
| **RTMB** (this report) | Primary report and detailed reference for the corrected ADMB translation, diagnostics, retrospectives, selectivity alternatives, and projections | Establishes the common implementation baseline and identifies issues requiring further evaluation |
| [**SPoRC**](https://jimianelli.github.io/sporc_ebswp/) | Companion comparison using the SPoRC single-region framework | Demonstrates close reproduction of the corrected ADMB candidate and supports continued methods development |
| [**Rceattle**](rceattle_ebswp.html) | Companion comparison using a more general and extensible assessment framework | Leading candidate for future operational assessment development; advancement depends on resolving selectivity identification, retrospective bias, posterior mixing, and completing formal review |
The accepted ADMB model continues to provide management advice during this
evaluation. The near-term review question is therefore how the three analyses
inform future development priorities, with particular attention to whether the
remaining Rceattle diagnostics can be satisfactorily resolved.
# Initial RTMB Developments
## Data Inputs
The RTMB input series include annual fishery catch, fishery age compositions,
BTS and ATS age compositions, the BTS biomass index, the ATS survey index,
acoustic vessels of opportunity, and fishery CPUE. The input data and bridge
ADMB results correspond to the corrected base configuration described above.
```{r}
#| label: tbl-input-summary
#| tbl-cap: "Summary of the EBS pollock RTMB-ADMB input data."
summary_tbl <- tibble(
item = c(
"Years",
"Ages",
"Fishery age-composition years",
"BTS index years",
"ATS index years",
"CPUE years",
"AVO years",
"Saved RTMB output"
),
value = c(
paste0(first_year, "-", terminal_year, " (", length(years), ")"),
paste0(min(ages), "-", max(ages), " (", length(ages), ")"),
paste0(min(data$yrs_fsh_data), "-", max(data$yrs_fsh_data), " (", length(data$yrs_fsh_data), ")"),
paste0(min(data$yrs_bts_data), "-", max(data$yrs_bts_data), " (", length(data$yrs_bts_data), ")"),
paste0(min(data$yrs_ats_data), "-", max(data$yrs_ats_data), " (", length(data$yrs_ats_data), ")"),
paste0(min(data$yrs_cpue), "-", max(data$yrs_cpue), " (", length(data$yrs_cpue), ")"),
paste0(min(data$yrs_avo), "-", max(data$yrs_avo), " (", length(data$yrs_avo), ")"),
params$model_file
)
)
summary_tbl |>
gt_report() |>
tab_header(title = "RTMB-ADMB Input Summary")
```
The corrected bridge applies one coherent BTS composition likelihood. Observed
proportions and multinomial predictions each span ages 1--15 and sum to one.
Age-1 selectivity retains its dedicated parameterization, while the ages 2--15
curve retains its existing form. The likelihood uses the nominal sample sizes
recorded by `pm.tpl`, with integer truncation preserved because the ADMB data
object stores those sample sizes as integers. Separately, the BTS total-numbers
quantity used to scale the age composition continues to represent ages 2--15.
This quantity is not the fitted BTS survey index, which is defined in biomass.
```{r}
#| label: tbl-corrected-bts-treatment
#| tbl-cap: "BTS age-composition treatment in the corrected ADMB and RTMB bridge. Observed and predicted compositions cover ages 1--15; the total-numbers quantity used for composition scaling retains its ages 2--15 definition."
tibble(
component = c(
"Observed composition ages", "Predicted composition ages",
"Maximum observed row-sum error", "Maximum predicted row-sum error",
"Sample-size treatment", "BTS total-numbers ages"
),
corrected_treatment = c(
"1--15", "1--15",
format(max(abs(rowSums(data$oac_bts) - 1)), scientific = TRUE, digits = 3),
format(max(abs(rowSums(rtmb_report$phat_bts) - 1)), scientific = TRUE, digits = 3),
"Nominal integer values from pm.tpl", "2--15"
)
) |>
gt_report() |>
tab_header(title = "Corrected BTS Composition Definition")
```
```{r}
#| label: tbl-data-availability
#| tbl-cap: "Available observations by fleet and data type."
availability <- bind_rows(
tibble(name = "Fishery", type = "catch", year = years),
tibble(name = "Fishery", type = "age_comp", year = data$yrs_fsh_data),
tibble(name = "BTS", type = "index", year = data$yrs_bts_data),
tibble(name = "BTS", type = "age_comp", year = data$yrs_bts_data),
tibble(name = "ATS", type = "index", year = data$yrs_ats_data),
tibble(name = "ATS", type = "age_comp", year = data$yrs_ats_data),
tibble(name = "CPUE", type = "index", year = data$yrs_cpue),
tibble(name = "AVO", type = "index", year = data$yrs_avo)
) |>
group_by(name, type) |>
summarize(
n_obs = n(),
years = paste0(min(year, na.rm = TRUE), "-", max(year, na.rm = TRUE)),
.groups = "drop"
) |>
arrange(type, name)
availability |>
gt_report() |>
tab_header(title = "Data Availability by Fleet")
```
```{r}
#| label: tbl-bridge-files
#| tbl-cap: "ADMB bridge files used by the RTMB implementation."
bridge_file_paths <- c(rtmb_metadata$admb_rep, rtmb_metadata$admb_par, pollock_file("admb", "runs", "for_rtmb", "pm.tpl"))
bridge_files <- tibble(
file = display_path(bridge_file_paths),
role = c("ADMB report used for comparison", "ADMB parameter file used for initialization", "ADMB bridge template"),
exists = file.exists(bridge_file_paths),
size_kb = round(file.info(bridge_file_paths)$size / 1024, 1),
modified = as.POSIXct(file.info(bridge_file_paths)$mtime)
)
bridge_files |>
gt_report() |>
fmt_number(columns = size_kb, decimals = 1) |>
tab_header(title = "ADMB Bridge Files")
```
## Model Implementation
### Structure
- **Population**: single EBS pollock stock.
- **Model engine**: RTMB with the negative log-likelihood written in R.
- **Reference model**: ADMB bridge run in `admb/runs/for_rtmb/`.
- **Fleets and indices**: fishery catch, fishery CPUE, BTS, ATS, and AVO.
- **Age compositions**: fishery, BTS, and ATS age-composition likelihoods.
- **Recruitment**: ADMB-port recruitment likelihood and deviations.
- **Natural mortality**: age-specific input vector from the ADMB bridge data.
- **Selectivity**: fishery, BTS, and ATS selectivity blocks ported from the ADMB bridge configuration.
### Model assumptions
```{r}
#| label: tbl-model-assumptions
#| tbl-cap: "Key model assumptions and fixed settings in the current RTMB-ADMB implementation."
assumptions_tbl <- tibble(
topic = c(
"Bridge source",
"Template",
"Natural mortality",
"BTS start year",
"ATS start year",
"Recruitment age",
"Age-1 ATS index",
"BTS biology likelihood",
"ATS biology likelihood"
),
setting = c(
"ADMB bridge run in admb/runs/for_rtmb",
"Physical bridge pm.tpl copy that intentionally differs from admb/source/pm.tpl",
paste(round(data$natmort, 4), collapse = ", "),
as.character(data$styr_bts),
as.character(data$styr_ats),
as.character(data$recage),
as.character(data$use_age1_ats),
as.character(data$do_bts_bio),
as.character(data$do_ats_bio)
)
)
assumptions_tbl |>
gt_report() |>
tab_header(title = "RTMB-ADMB Model Assumptions")
```
### BTS Selectivity Variation and Penalties
The bottom trawl survey (BTS) selectivity in the RTMB bridge is represented as a time-varying logistic curve for ages 2 and older, with a separate age-1 term. For BTS year \(t\) and model age \(a\), the code uses the age midpoint \(x_a = a + 0.5\) and computes
$$
\log s_{t,a}^{\mathrm{BTS}}
= -\log\left[
1 + \exp\left\{-\exp(\gamma_t)\left(x_a - \exp(\alpha_t)\right)\right\}
\right],
$$
where $\gamma_t$ is the annual log-slope parameter (`sel_slp_bts_dev`) and $\alpha_t$ is the annual log-age-at-50% parameter (`sel_a50_bts_dev`). Thus the realized slope is $\exp(\gamma_t)$, and the realized age-at-50% is $\exp(\alpha_t)$. Age 1 is then overwritten by its own annual log-selectivity term:
$$
\log s_{t,1}^{\mathrm{BTS}} = \eta_t,
$$
where $\eta_t$ is `sel_age_one_bts_dev`.
The current RTMB call treats `sel_slp_bts_dev`, `sel_a50_bts_dev`, and `sel_age_one_bts_dev` as estimated annual vectors. The base logistic BTS terms `sel_slp_bts`, `sel_a50_bts`, `sel_age_one_bts`, and `sel_devs_bts` are fixed in `R/config.R`; the time variation is carried by the annual deviation vectors above.
The regularization targets the implied annual log-selectivity curves instead of $\alpha_t$ or $\gamma_t$ directly. In `selectivity_like_bts()`, an extended matrix $\tilde{\ell}_{t,a}$ is formed by prepending a zero row for the year before the BTS time series. Let $\Delta_t z_t = z_t - z_{t-1}$. The BTS time-variation penalty for ages $a = q_{\min}, \ldots, q_{\max}-1$ is
$$
P_{\mathrm{BTS,time}}
= \lambda_{\mathrm{BTS}}
\sum_{a=q_{\min}}^{q_{\max}-1}
\sum_t
\left(\Delta_t \tilde{\ell}_{t,a}\right)^2,
$$
where $\lambda_{\mathrm{BTS}}$ is `selVarbts`. In this configuration, `q_amin = 3`, `q_amax` defaults to `nages`, and `nages = 15`, so this penalty applies to ages 3 through 14. Age 2 lies below this time-smoothness range, and age 15 lies above the final loop index of `q_amax - 1`.
The age-1 BTS term has a separate first-difference penalty:
$$
P_{\mathrm{BTS,age1}}
= 8
\sum_t
\left[
\Delta_t\left(\eta_t - \bar{\eta}\right)
\right]^2,
$$
where $\bar{\eta}$ is the mean of the age-1 deviation vector. The total BTS selectivity regularization returned by `selectivity_like_bts()` is
$$
P_{\mathrm{BTS}}
= P_{\mathrm{BTS,time}} + P_{\mathrm{BTS,age1}},
$$
with no additional BTS curvature penalty active under the current logistic-deviation parameterization.
```{r}
#| label: tbl-bts-selectivity-regularization
#| tbl-cap: "BTS selectivity variation and regularization settings in the current RTMB-ADMB configuration."
bts_sel_tbl <- tibble(
item = c(
"BTS selectivity start year",
"Terminal year",
"Number of annual BTS selectivity years",
"Estimated annual slope vector",
"Estimated annual age-at-50 vector",
"Estimated annual age-1 vector",
"Time-smoothness weight (`selVarbts`)",
"Time-smoothness age range",
"Age-1 first-difference weight",
"Inactive base BTS terms fixed in config"
),
value = c(
as.character(data$styr_bts),
as.character(data$endyr),
as.character(data$endyr - data$styr_bts + 1),
"sel_slp_bts_dev",
"sel_a50_bts_dev",
"sel_age_one_bts_dev",
as.character(data$selVarbts),
paste0(data$q_amin, "-", data$nages - 1),
"8",
"sel_devs_bts, sel_slp_bts, sel_a50_bts, sel_age_one_bts"
)
)
bts_sel_tbl |>
gt_report() |>
tab_header(title = "BTS Selectivity Regularization")
```
### Fishery Selectivity Specifications
The base bridge retains the assessment's age coefficients and deviations at
configured change years. Two additional fishery-selectivity forms were
implemented to evaluate how a more continuous representation of change
affects fit, biological patterns, and assessment scale. These runs differ in
fishery selectivity while retaining the common data and likelihood framework.
| Form | Specification | Development status |
|---|---|---|
| Base coefficients | Age coefficients with deviations at configured change years; ages 11 and older share the age-11 value | Bridge reference |
| Time-age varying double logistic | Shared ascending and descending curve with annual random effects at a fixed 30% process CV; the tested formulation evaluates ages through 15 separately | Converged staged development fit |
| Two-dimensional AR1 | Year-by-age latent field with separable AR1 correlation across years and ages; ages 11 and older share the age-11 value | Sensitivity fit |
The initial double-logistic experiment estimated 183 annual fixed effects and
failed the convergence criteria. A two-stage hierarchical formulation replaced
that experiment: stage 1 estimated a shared three-parameter curve, and stage 2
estimated zero-centered annual random effects using the RTMB Laplace
approximation. The staged fit passed the optimizer, gradient, positive-Hessian,
and finite-standard-error checks recorded in the selectivity analysis.
These alternatives should be evaluated using likelihood components,
age-composition residuals, selectivity surfaces, convergence, and effects on
spawning biomass. Objective value alone provides an incomplete basis for
choosing a selectivity specification. The detailed equations, fitted
comparisons, and implementation references remain available in the companion
[fishery-selectivity supporting analysis](appendix_fishery_selectivity.html),
with a [PDF version](appendix_fishery_selectivity.pdf) and
[referenceable summary data](data-output/fishery_selectivity_summary.csv).
### Run Definitions
Results are presented for one base RTMB configuration corresponding to the
corrected ADMB comparison. Candidate fishery-selectivity formulations are
identified separately from this base configuration.
```{r}
#| label: tbl-run-definitions
#| tbl-cap: "Configured RTMB-ADMB run definitions."
run_tbl <- tibble(
run = "base",
source = params$model_file,
refit_default = params$refit,
output_available = file.exists(model_file),
report_elements = length(names(rtmb_report)),
created = as.character(rtmb_metadata$created %||% NA_character_)
)
run_tbl |>
gt_report() |>
tab_header(title = "RTMB-ADMB Run Definitions")
```
The base output writer follows this pattern.
```{r}
#| label: lst-base-run
#| eval: false
#| echo: true
#| code-fold: true
#| code-summary: "Show RTMB output-generation call"
source("R/config.R")
data$return_nll_only <- 0
rtmb_result <- rpm(parms)
saveRDS(
list(report = rtmb_result$rtmb, metadata = list(model = "rtmb_ebswp")),
"analysis/output/corrected_full_age_bts/rtmb_base.rds"
)
```
# ADMB Comparison Results {#sec-admb-rtmb-bridge}
This fixed-parameter comparison follows the bridge method demonstrated in the
September 2025 [EBS pollock development report](https://noaa-afsc.github.io/EBS_pollock/doc/Sept_2025.html#bridging-admb-to-rtmb).
The corrected ADMB model's maximum-likelihood parameter estimates are injected
into RTMB, and both implementations are evaluated at that identical parameter
point. This isolates code translation from optimization behavior and later
model alternatives.
The OSA diagnostics, Only-BTS sensitivity, retrospectives, and projections use
the same corrected base configuration. The SparseNUTS appendix instead
evaluates the hierarchical Form-2 selectivity model and is identified
separately throughout.
```{r}
#| label: tbl-bridge-summary
#| tbl-cap: "Summary of the corrected full-age BTS fixed-parameter ADMB-to-RTMB bridge. The absolute NLL difference is on the negative-log-likelihood scale; the key-output difference is the largest absolute percentage difference among state, prediction, selectivity, composition, and likelihood quantities."
bridge_metrics <- rtmb_metadata$bridge_metrics
tibble(
measure = c(
"ADMB total negative log-likelihood",
"RTMB total negative log-likelihood",
"Absolute total NLL difference",
"Maximum key-output difference (%)",
"Maximum absolute RTMB gradient"
),
value = c(
bridge_metrics$admb_total_nll,
bridge_metrics$rtmb_total_nll,
bridge_metrics$absolute_total_nll_difference,
bridge_metrics$maximum_key_percent_difference,
bridge_metrics$maximum_absolute_gradient
)
) |>
gt_report() |>
fmt_number(columns = value, decimals = 9) |>
tab_header(title = "Corrected Full-Age BTS ADMB–RTMB Bridge")
```
The total negative log-likelihoods differ by
`r sprintf("%.9f", bridge_metrics$absolute_total_nll_difference)`. The maximum
difference among key outputs is
`r sprintf("%.9f%%", bridge_metrics$maximum_key_percent_difference)`, and the
largest absolute RTMB gradient at the ADMB estimates is
`r format(bridge_metrics$maximum_absolute_gradient, scientific = TRUE, digits = 7)`.
These values satisfy the prespecified corrected-comparison tolerances.
```{r}
#| label: tbl-correction-effect
#| tbl-cap: "Effect of replacing the historical RTMB-adjusted BTS composition treatment with the corrected full-age treatment. Percent differences summarize paired annual values from the two RTMB configurations."
correction_effect <- if (!is.null(legacy_report)) {
bind_rows(
lapply(
list(
`Spawning biomass` = cbind(rtmb_report$SSB, legacy_report$SSB),
Recruitment = cbind(rtmb_report$N[, 1], legacy_report$N[, 1]),
`Numbers at age` = cbind(as.vector(rtmb_report$N), as.vector(legacy_report$N))
),
function(values) {
relative <- abs(values[, 1] - values[, 2]) /
pmax(abs(values[, 2]), .Machine$double.eps) * 100
tibble(
`Median absolute difference (%)` = median(relative, na.rm = TRUE),
`Maximum absolute difference (%)` = max(relative, na.rm = TRUE)
)
}
),
.id = "Quantity"
)
} else {
tibble(Quantity = "Historical bridge artifact unavailable")
}
correction_effect |>
gt_report() |>
fmt_number(columns = where(is.numeric), decimals = 4) |>
tab_header(title = "Effect of Correcting the BTS Composition Likelihood")
```
```{r}
#| label: tbl-downstream-lineage
#| tbl-cap: "Corrected-base lineage for primary downstream analyses. Matching checksums confirm that each product was regenerated from the corrected full-age BTS RTMB bridge output."
current_base_md5 <- unname(tools::md5sum(model_file))
projection_lineage <- readr::read_csv(
file.path(projection_dir, "base_lineage.csv"), show_col_types = FALSE
)
alt2_lineage <- readr::read_csv(
file.path(projection_alt2_dir, "base_lineage.csv"), show_col_types = FALSE
)
lineage_tbl <- tibble(
analysis = c(
"Corrected base bridge", "Only-BTS sensitivity", "OSA diagnostics",
"Nine-peel retrospective", "Seven-scenario Tier 3 projections",
"Alternative 2 fixed-catch projections"
),
base_md5 = c(
current_base_md5,
only_bts_metadata$base_md5 %||% NA_character_,
osa_output$lineage$base_md5 %||% NA_character_,
retro_saved$base_lineage$md5 %||% NA_character_,
projection_lineage$model_md5[1] %||% NA_character_,
alt2_lineage$model_md5[1] %||% NA_character_
)
) |>
mutate(matches_authoritative_base = base_md5 == current_base_md5)
lineage_tbl |>
gt_report() |>
tab_header(title = "Corrected Full-Age Bridge Lineage")
```
```{r}
#| label: tbl-bridge-comparison
#| tbl-cap: "Object-by-object comparison of RTMB and ADMB results at the shared ADMB maximum-likelihood parameter point. `Equal` is the result of the numerical comparison at tolerance 1e-5; correlation is shown for compatible nonconstant vectors."
rtmb_bridge_comparison |>
filter(is.finite(max_abs_diff) | !is.na(equal)) |>
arrange(desc(max_abs_pct_diff)) |>
rename(
Quantity = variable,
Equal = equal,
Elements = length,
`Maximum absolute difference` = max_abs_diff,
`Maximum absolute difference (%)` = max_abs_pct_diff,
Correlation = cor
) |>
gt_report() |>
fmt_number(
columns = c(
`Maximum absolute difference`,
`Maximum absolute difference (%)`, Correlation
),
decimals = 7
) |>
tab_header(title = "RTMB and ADMB Object Comparison")
```
```{r}
#| label: tbl-bridge-gradients
#| tbl-cap: "Twenty largest RTMB gradients at the ADMB maximum-likelihood parameter estimates. Values close to zero confirm that the injected ADMB solution is also stationary in RTMB."
tibble(
parameter = names(obj$par),
gradient = as.numeric(obj$gr())
) |>
mutate(absolute_gradient = abs(gradient)) |>
arrange(desc(absolute_gradient)) |>
slice_head(n = 20) |>
select(parameter, gradient, absolute_gradient) |>
gt_report() |>
fmt_scientific(columns = c(gradient, absolute_gradient), decimals = 4) |>
tab_header(title = "Largest RTMB Gradients at ADMB Estimates")
```
```{r}
#| label: fig-bridge-ssb-recruitment
#| fig-cap: "Spawning biomass and age-1 recruitment from RTMB and ADMB at the same ADMB maximum-likelihood parameter estimates. The two implementations are visually indistinguishable at the plotted scale. Select the figure to open it in the lightbox."
#| fig-alt: "Two-panel line chart comparing RTMB and ADMB spawning biomass and age-1 recruitment from 1964 through 2024. The paired implementation lines overlap across both panels."
bridge_years <- data$styr:data$endyr
bridge_series <- bind_rows(
tibble(
year = bridge_years,
quantity = "Spawning biomass",
model = "RTMB",
value = as.numeric(rtmb_report$SSB)
),
tibble(
year = bridge_years,
quantity = "Spawning biomass",
model = "ADMB",
value = as.numeric(pm$SSB)
),
tibble(
year = bridge_years,
quantity = "Age-1 recruitment",
model = "RTMB",
value = as.numeric(rtmb_report$N[, 1])
),
tibble(
year = bridge_years,
quantity = "Age-1 recruitment",
model = "ADMB",
value = as.numeric(pm$N[, 1])
)
)
ggplot(bridge_series, aes(year, value, color = model, linetype = model)) +
geom_line(linewidth = 0.9) +
facet_wrap(~quantity, scales = "free_y", ncol = 1) +
scale_color_manual(values = c(ADMB = "#1f78b4", RTMB = "#d95f02")) +
scale_linetype_manual(values = c(ADMB = "22", RTMB = "solid")) +
scale_y_continuous(labels = scales::label_comma()) +
labs(x = "Year", y = "Estimate", color = "Implementation", linetype = "Implementation")
```
```{r}
#| label: fig-bridge-relative-differences
#| fig-cap: "Absolute relative differences between RTMB and ADMB spawning biomass and age-1 recruitment at the shared ADMB estimates. Values are percentages; the very small vertical scale is intentional. Select the figure to open it in the lightbox."
#| fig-alt: "Two-panel line chart of absolute percentage differences between RTMB and ADMB spawning biomass and recruitment. Values remain close to zero throughout the modeled period."
bridge_difference <- bridge_series |>
pivot_wider(names_from = model, values_from = value) |>
mutate(
absolute_relative_difference =
100 * abs(RTMB - ADMB) / pmax(abs(ADMB), .Machine$double.eps)
)
ggplot(bridge_difference, aes(year, absolute_relative_difference)) +
geom_line(color = "#4d4d4d", linewidth = 0.8) +
facet_wrap(~quantity, scales = "free_y", ncol = 1) +
scale_y_continuous(labels = scales::label_number(accuracy = 0.00001)) +
labs(x = "Year", y = "Absolute relative difference (%)")
```
# RTMB Model Results
## Fit to Base RTMB-ADMB Run
The fitted results below are for the base RTMB-ADMB configuration. The spawning
biomass trajectory is shown in @fig-ssb. Fishery observed and predicted catch
are compared in @fig-catch-fit, while survey, CPUE, and AVO index fits are
summarized in @fig-fits-by-fleet and residual patterns in @fig-residuals.
Expected age compositions and fleet selectivity curves are shown in
@fig-agecomp-fishery, @fig-agecomp-bts, @fig-agecomp-ats, and
@fig-selectivity-curves.
```{r}
#| label: rtmb-result-data
#| include: false
ts_df <- tibble(
year = years,
biomass = rowSums(rtmb_report$N * data$wt_ssb, na.rm = TRUE),
ssb = as.numeric(rtmb_report$SSB),
recruitment = as.numeric(rtmb_report$N[, 1]),
total_f = rowSums(rtmb_report$F, na.rm = TRUE),
mean_f = rowMeans(rtmb_report$F, na.rm = TRUE)
)
only_bts_ts <- tibble()
if (!is.null(only_bts_report)) {
only_bts_ts <- tibble(
model = "Only BTS",
source = "RTMB",
year = years,
quantity = "SSB",
value = as.numeric(only_bts_report$SSB)
) |>
bind_rows(
tibble(
model = "Only BTS",
source = "RTMB",
year = years,
quantity = "Recruitment",
value = as.numeric(only_bts_report$N[, 1])
)
)
}
admb_ts <- tibble()
if (exists("pm") && !is.null(pm)) {
admb_ts <- bind_rows(
if (!is.null(pm$SSB)) tibble(model = "ADMB bridge", source = "ADMB", year = years[seq_along(pm$SSB)], quantity = "SSB", value = as.numeric(pm$SSB)) else tibble(),
if (!is.null(pm$pred_rec)) tibble(model = "ADMB bridge", source = "ADMB", year = years[seq_along(pm$pred_rec)], quantity = "Recruitment", value = as.numeric(pm$pred_rec)) else tibble()
)
}
catch_df <- tibble(
year = years,
observed = as.numeric(rtmb_report$obs_catch),
expected = as.numeric(rtmb_report$pred_catch)
)
index_df <- bind_rows(
tibble(series = "BTS", year = data$yrs_bts_data, observed = data$ob_bts, expected = rtmb_report$eb_bts, sd = data$ob_bts_std),
tibble(series = "ATS", year = data$yrs_ats_data, observed = data$ob_ats, expected = rtmb_report$eb_ats, sd = data$ob_ats_std),
tibble(series = "CPUE", year = data$yrs_cpue, observed = data$obs_cpue, expected = rtmb_report$pred_cpue, sd = data$obs_cpue_std),
tibble(series = "AVO", year = data$yrs_avo, observed = data$ob_avo, expected = rtmb_report$pred_avo, sd = data$ob_avo_std)
) |>
mutate(
std_residual = ifelse(
observed > 0 & expected > 0 & is.finite(sd) & sd > 0,
(log(observed) - log(expected)) / sd,
NA_real_
)
)
agecomp_df <- bind_rows(
make_agecomp_fit(data$oac_fsh, rtmb_report$phat_fsh, data$yrs_fsh_data, "Fishery"),
make_agecomp_fit(data$oac_bts, rtmb_report$phat_bts, data$yrs_bts_data, "BTS"),
make_agecomp_fit(
data$oac_ats[, data$mina_ats:data$nages, drop = FALSE],
rtmb_report$phat_ats[, data$mina_ats:data$nages, drop = FALSE],
data$yrs_ats_data,
"ATS",
age_values = data$mina_ats:data$nages
)
) |>
filter(!(fleet %in% c("BTS", "ATS") & age == 1))
sample_size_df <- bind_rows(
tibble(fleet = "Fishery", year = data$yrs_fsh_data, n_eff = as.numeric(data$sam_fsh)),
tibble(fleet = "BTS", year = data$yrs_bts_data, n_eff = as.numeric(data$sam_bts)),
tibble(fleet = "ATS", year = data$yrs_ats_data, n_eff = as.numeric(data$sam_ats))
)
weighted_aggregate_agecomp_df <- make_weighted_aggregate_agecomp(agecomp_df, sample_size_df)
composition_residual_df <- make_comp_residuals(agecomp_df, sample_size_df)
composition_sdnr_df <- composition_residual_df |>
group_by(fleet) |>
summarize(
sdnr = sd(residual, na.rm = TRUE),
n = sum(is.finite(residual)),
.groups = "drop"
)
diagnostic_residual_df <- if (isTRUE(osa_precomputed_available)) {
osa_residual_df
} else {
composition_residual_df
}
diagnostic_sdnr_df <- diagnostic_residual_df |>
group_by(fleet) |>
summarize(
mean_residual = mean(residual, na.rm = TRUE),
sdnr = sd(residual, na.rm = TRUE),
min_residual = min(residual, na.rm = TRUE),
max_residual = max(residual, na.rm = TRUE),
n = sum(is.finite(residual)),
.groups = "drop"
)
```
```{r}
#| label: fig-ssb
#| fig-cap: "Estimated spawning biomass from the saved EBS pollock RTMB-ADMB base model, with the ADMB bridge output overlaid when available."
#| fig-alt: "Time-series line chart of spawning biomass from 1964 through 2024. RTMB and ADMB bridge trajectories overlap closely."
ssb_overlay <- bind_rows(
ts_df |>
transmute(model = "RTMB-ADMB base", source = "RTMB", year, value = ssb),
admb_ts |>
filter(quantity == "SSB") |>
transmute(model, source, year, value)
)
ggplot(ssb_overlay, aes(x = year, y = value, color = model, linetype = source)) +
geom_line(linewidth = 0.8) +
scale_y_continuous(limits = c(0, NA), labels = scales::label_comma()) +
scale_color_manual(values = c("RTMB-ADMB base" = "#1b9e77", "ADMB bridge" = "#1f78b4")) +
scale_linetype_manual(values = c("RTMB" = "solid", "ADMB" = "22")) +
labs(x = "Year", y = "SSB", color = "Model", linetype = "Source", title = "Spawning Biomass")
```
### Catch Fit
```{r}
#| label: fig-catch-fit
#| fig-cap: "Observed fishery catch and predicted catch from the base RTMB-ADMB model."
#| fig-alt: "Time-series chart with observed catch points and a predicted catch line across model years, showing close correspondence."
ggplot(catch_df, aes(x = year)) +
geom_line(aes(y = expected), color = "#377eb8", linewidth = 0.8) +
geom_point(aes(y = observed), color = "#377eb8", size = 1.2, alpha = 0.7) +
scale_y_continuous(limits = c(0, NA), labels = scales::label_comma()) +
labs(x = "Year", y = "Catch", title = "Fishery Catch: Observed vs Expected")
```
### Fits by Fleet
```{r}
#| label: fig-fits-by-fleet
#| fig-cap: "Observed and predicted index series from the base RTMB-ADMB model, shown on arithmetic scales with separate facet axes."
#| fig-alt: "Faceted time-series chart of observed points and predicted lines for BTS, ATS, CPUE, and AVO indices, with a separate vertical scale for each series."
ggplot(index_df, aes(x = year)) +
geom_line(aes(y = expected), color = "#377eb8", linewidth = 0.8) +
geom_point(aes(y = observed), color = "#377eb8", size = 1.1, alpha = 0.7, na.rm = TRUE) +
facet_wrap(~series, scales = "free_y") +
scale_y_continuous(limits = c(0, NA), labels = scales::label_comma()) +
labs(x = "Year", y = "Index", title = "Survey, CPUE, and AVO Fits on Arithmetic Scale")
```
### Residuals
```{r}
#| label: fig-residuals
#| fig-cap: "Approximate standardized log residuals for RTMB-ADMB index observations. Residuals are divided by the input log standard deviation."
#| fig-alt: "Faceted residual chart by index series and year. Points appear above and below a horizontal zero line, revealing temporal clusters of positive and negative residuals."
ggplot(index_df, aes(x = year, y = std_residual)) +
geom_hline(yintercept = 0, color = "gray50", linewidth = 0.4) +
geom_point(size = 1.1, alpha = 0.7) +
facet_wrap(~series, scales = "free_y") +
labs(x = "Year", y = "Standardized residual", title = "Survey, CPUE, and AVO Standardized Residuals")
```
### Age Composition Fits
```{r}
#| label: fig-agecomp-fishery
#| fig-cap: "Observed and expected fishery age-composition patterns from the base RTMB-ADMB model, faceted by year."
#| fig-alt: "Small-multiple fishery age-composition plots by year, with observed proportions shown as points and expected proportions shown as lines across ages 1 through 15."
#| fig-width: 8
#| fig-height: 11
#| out-width: "100%"
plot_agecomp_fit(agecomp_df, "Fishery", ncol = 5)
```
```{r}
#| label: fig-agecomp-bts
#| fig-cap: "Observed and expected BTS age-composition patterns from the base RTMB-ADMB model, faceted by year."
#| fig-alt: "Small-multiple bottom trawl survey age-composition plots by year, with observed points and expected lines across ages 1 through 15."
#| fig-width: 8
#| fig-height: 11
#| out-width: "100%"
plot_agecomp_fit(agecomp_df, "BTS", ncol = 4)
```
```{r}
#| label: fig-agecomp-ats
#| fig-cap: "Observed and expected ATS age-composition patterns from the base RTMB-ADMB model, faceted by year."
#| fig-alt: "Small-multiple acoustic-trawl survey age-composition plots by year, with observed points and expected lines across modeled ages."
#| fig-width: 8
#| fig-height: 11
#| out-width: "100%"
plot_agecomp_fit(agecomp_df, "ATS", ncol = 3)
```
### OSA Residual Diagnostics
The age-composition diagnostics follow the updated [afscOSA guidance](https://noaa-afsc.github.io/afscOSA/) incorporated through [afscOSA pull request 10](https://github.com/noaa-afsc/afscOSA/pull/10). The diagnostics were regenerated from the corrected full-age BTS bridge. In this render, the method is `r osa_residual_method`.
The four rows in @fig-osa-age-diagnostics provide a joint interpretation. The aggregate composition first identifies systematic fit patterns, such as selectivity that consistently misses particular ages. The Q-Q plot assesses whether OSA residuals behave approximately as standard normal values and reports the SDNR and lower and upper 2.5% quantiles with their expected intervals. The OSA and Pearson bubble plots then locate temporal, age-specific, or cohort patterns. A statistic outside its interval signals an area for investigation and provides one element of the broader assessment evaluation.
```{r}
#| label: tbl-osa-residual-status
#| tbl-cap: "Source and software checks for the updated OSA diagnostics. The base-model checksum ties these diagnostics to the corrected RTMB object used elsewhere in this report. The ATS 2020 placeholder was excluded because it has zero rounded multinomial observations and supplies zero information to an OSA calculation."
tibble(
item = c(
"afscOSA version",
"R version used for OSA calculations",
"Accepted base-model checksum (MD5)",
"OSA input checksum (MD5)",
"Excluded zero-information composition row",
"Fleets",
"OSA residuals"
),
value = c(
if (isTRUE(osa_precomputed_available)) osa_output$afscOSA_version else NA_character_,
if (isTRUE(osa_precomputed_available)) osa_output$r_version else NA_character_,
if (isTRUE(osa_precomputed_available)) osa_output$lineage$base_md5 else NA_character_,
if (isTRUE(osa_precomputed_available)) osa_output$input_md5 else NA_character_,
if (isTRUE(osa_precomputed_available)) "ATS 2020" else NA_character_,
paste(sort(unique(diagnostic_residual_df$fleet)), collapse = ", "),
as.character(nrow(diagnostic_residual_df))
)
) |>
gt_report() |>
tab_header(title = "OSA Diagnostic Source Check")
```
```{r}
#| label: tbl-osa-sdnr-summary
#| tbl-cap: "Summary of one-step-ahead residual distributions. Under a correctly specified composition model, OSA residuals are expected to be approximately standard normal: mean near zero, SDNR near one, and 2.5% tail quantiles near -1.96 and 1.96. Formal expected intervals are shown in the Q-Q panels of Figure @fig-osa-age-diagnostics; these summaries are diagnostic context rather than model-selection tests."
osa_output$summary |>
arrange(fleet) |>
select(
Fleet = fleet,
`OSA residuals` = residuals,
`Mean residual` = mean,
SDNR = sdnr,
`Lower 2.5% quantile` = lower_2.5_pct,
`Upper 97.5% quantile` = upper_97.5_pct
) |>
gt_report() |>
fmt_number(
columns = c(`Mean residual`, SDNR, `Lower 2.5% quantile`, `Upper 97.5% quantile`),
decimals = 2
) |>
fmt_number(columns = `OSA residuals`, decimals = 0) |>
tab_header(title = "OSA Residual Distribution Summary")
```
```{r}
#| label: fig-osa-age-diagnostics
#| fig-cap: "Age-composition diagnostics produced with afscOSA for the fishery, bottom trawl survey (BTS), and acoustic-trawl survey (ATS). Top row: observed aggregate proportions (blue bars), expected proportions (red points and line), and 95% conditional intervals for data expected from the fitted model (red vertical lines). ISS and ESS are the aggregate input and effective sample sizes. Second row: OSA residual Q-Q plots with SDNR and 2.5% tail quantiles; parentheses give their expected 95% intervals. Third and fourth rows: OSA and Pearson residual bubbles by year and age, with red positive and blue negative residuals and bubble area increasing with absolute magnitude. Bubble sizes are standardized across fleets; two Pearson residuals greater than 6 were truncated to 6 for display only. Joint interpretation of all panels supports the broader model evaluation."
#| fig-alt: "Four-row diagnostic figure with columns for Fishery, BTS, and ATS. Aggregate fits are generally close, with localized age-bin discrepancies. Q-Q plots show SDNR values of 0.87 for Fishery, 0.96 for BTS, and 0.82 for ATS. OSA and Pearson bubble plots show residual sign and magnitude across years and ages, providing checks for temporal, age-specific, and cohort patterns."
#| fig-width: 12
#| fig-height: 9
#| out-width: "100%"
knitr::include_graphics(osa_plot_file)
```
The aggregate panels show generally close observed and expected patterns, with localized departures that deserve attention. The BTS SDNR lies within its displayed expected interval. Fishery and ATS have narrower OSA residual distributions than standard normal expectations; this can reflect composition weighting, residual dependence, or other model structure and should be considered alongside the aggregate and bubble patterns. The fishery upper tail is also lighter than expected, while the other tail estimates are close to or within their displayed intervals. These results identify focused follow-up work and provide one component of model evaluation.
### Selectivity Curves
```{r}
#| label: fig-selectivity-curves
#| fig-cap: "Estimated RTMB-ADMB selectivity-at-age curves by fleet in selected years."
#| fig-alt: "Faceted line chart of fishery, bottom trawl survey, and acoustic-trawl survey selectivity across ages for early, middle, and terminal model years."
selected_years <- c(first_year, years[ceiling(length(years) / 2)], terminal_year)
sel_df <- bind_rows(
as_year_age_df(rtmb_report$sel_fsh, years, "Fishery", "selectivity"),
as_year_age_df(rtmb_report$sel_bts, data$styr_bts:data$endyr, "BTS", "selectivity"),
as_year_age_df(rtmb_report$sel_ats, data$styr_ats:data$endyr, "ATS", "selectivity")
) |>
filter(year %in% selected_years | year == min(year) | year == max(year)) |>
group_by(fleet, year) |>
mutate(selectivity = selectivity / max(selectivity, na.rm = TRUE)) |>
ungroup()
ggplot(sel_df, aes(x = age, y = selectivity, color = factor(year))) +
geom_line(linewidth = 0.8) +
facet_wrap(~fleet, ncol = 1) +
scale_y_continuous(limits = c(0, NA)) +
labs(x = "Age", y = "Relative selectivity", color = "Year", title = "Selectivity at Age")
```
The selected-year curves illustrate differences in both shape and temporal
change among fleets. Fishery selectivity changes from a pronounced peak near
ages 4--5 in the earliest year to a broader pattern that retains relatively
high selectivity across older ages in 1994 and 2024. BTS selectivity is low at
young ages and increases toward full selection at older ages; the 1994 curve
rises more rapidly across the intermediate ages than the 2024 curve. ATS
selectivity also increases toward an older-age plateau, with the largest
differences between the selected years occurring among the youngest ages.
These curves are normalized within fleet and year, so they describe relative
age patterns rather than absolute catchability. [Appendix A-2](#sec-bts-availability)
evaluates the consequence of the fitted annual BTS selectivity patterns by
holding numbers and weight at age fixed and translating selectivity changes
into a relative vulnerable-biomass index.
### Selectivity Ridge Plots
```{r}
#| label: fig-selectivity-ridge-fishery
#| fig-cap: "Relative fishery selectivity over time from the RTMB-ADMB model. Ridge heights are normalized within year."
#| fig-alt: "Ridgeline display of normalized fishery selectivity across ages for successive model years, showing changes in the age pattern through time."
#| fig-width: 8
#| fig-height: 10
#| out-width: "100%"
ridge_df <- bind_rows(
as_year_age_df(rtmb_report$sel_fsh, years, "Fishery", "selectivity"),
as_year_age_df(rtmb_report$sel_bts, data$styr_bts:data$endyr, "BTS", "selectivity"),
as_year_age_df(rtmb_report$sel_ats, data$styr_ats:data$endyr, "ATS", "selectivity")
) |>
filter(age >= 2, age <= 10) |>
group_by(fleet, year) |>
mutate(relative_selectivity = selectivity / max(selectivity, na.rm = TRUE)) |>
ungroup() |>
mutate(year_factor = factor(year, levels = rev(sort(unique(year)))))
ggplot(ridge_df |> filter(fleet == "Fishery"), aes(x = age, y = year_factor, height = relative_selectivity)) +
ggridges::geom_density_ridges(
stat = "identity",
scale = 3.8,
alpha = 0.22,
fill = "#7b3294",
color = "black",
linewidth = 0.25
) +
scale_x_continuous(limits = c(2, 10), breaks = 2:10) +
labs(x = "Age", y = "Year", title = "Fishery Selectivity")
```
```{r}
#| label: fig-selectivity-ridge-bts
#| fig-cap: "Relative BTS selectivity over time from the RTMB-ADMB model. Ridge heights are normalized within year."
#| fig-alt: "Ridgeline display of normalized bottom trawl survey selectivity across ages for successive survey years, showing time variation in the age pattern."
#| fig-width: 8
#| fig-height: 10
#| out-width: "100%"
ggplot(ridge_df |> filter(fleet == "BTS"), aes(x = age, y = year_factor, height = relative_selectivity)) +
ggridges::geom_density_ridges(
stat = "identity",
scale = 3.8,
alpha = 0.22,
fill = "#1b9e77",
color = "black",
linewidth = 0.25
) +
scale_x_continuous(limits = c(2, 10), breaks = 2:10) +
labs(x = "Age", y = "Year", title = "BTS Selectivity")
```
```{r}
#| label: fig-selectivity-ridge-ats
#| fig-cap: "Relative ATS selectivity over time from the RTMB-ADMB model. Ridge heights are normalized within year."
#| fig-alt: "Ridgeline display of normalized acoustic-trawl survey selectivity across ages for successive survey years, showing time variation in the age pattern."
#| fig-width: 8
#| fig-height: 10
#| out-width: "100%"
ggplot(ridge_df |> filter(fleet == "ATS"), aes(x = age, y = year_factor, height = relative_selectivity)) +
ggridges::geom_density_ridges(
stat = "identity",
scale = 3.8,
alpha = 0.22,
fill = "#d95f02",
color = "black",
linewidth = 0.25
) +
scale_x_continuous(limits = c(2, 10), breaks = 2:10) +
labs(x = "Age", y = "Year", title = "ATS Selectivity")
```
# Projections
The projection analysis is also available as a self-contained attachment:
[RTMB EBS pollock: standalone spmR projection attachment](reporting/appendix_spmr_projections.html).
The RTMB estimates were converted to Standard Projection Model inputs and
evaluated with `spmR` [@ianelli2026spmR]. The projection configuration matches
the ADMB assessment setup, with population quantities supplied by the RTMB
model.
```{r}
#| label: spmr-projection-inputs
#| include: false
spmr_writer_env <- new.env(parent = globalenv())
sys.source(rtmb_file("R", "write_spmr_projection_inputs.R"), envir = spmr_writer_env)
spmr_projection <- spmr_writer_env$write_spmr_projection_inputs(
model_file = params$model_file,
output_dir = params$projection_dir,
config_path = rtmb_file("R", "config.R")
)
spmr_manifest <- as_tibble(spmr_projection$manifest)
spmr_detail_file <- file.path(spmr_projection$output_dir, "spm_detail.csv")
spmr_summary_file <- file.path(spmr_projection$output_dir, "spm_summary.csv")
spmr_detail <- if (file.exists(spmr_detail_file)) {
as_tibble(utils::read.csv(spmr_detail_file, check.names = FALSE))
} else {
tibble()
}
spmr_summary <- if (file.exists(spmr_summary_file)) {
as_tibble(utils::read.csv(spmr_summary_file, check.names = FALSE))
} else {
tibble()
}
spmr_version <- if (requireNamespace("spmR", quietly = TRUE)) {
as.character(utils::packageVersion("spmR"))
} else {
NA_character_
}
spmr_input <- if (file.exists(file.path(display_path(spmr_projection$output_dir), "spm.dat")) &&
requireNamespace("spmR", quietly = TRUE)) {
tryCatch(
spmR::dat2list(file.path(display_path(spmr_projection$output_dir), "spm.dat")),
error = function(e) NULL
)
} else {
NULL
}
```
```{r}
#| label: tbl-spmr-projection-files
#| tbl-cap: "Projection input files written for the spmR/SPM workflow."
spmr_manifest |>
mutate(
file = basename(file),
exists = as.character(exists)
) |>
gt_report() |>
tab_header(title = "spmR Projection Input Files")
```
```{r}
#| label: tbl-spmr-projection-settings
#| tbl-cap: "Key settings in the generated SPM projection setup file."
if (!is.null(spmr_input)) {
tibble(
item = c(
"Projection directory",
"Projection begin year",
"Projection years",
"Simulations",
"Alternatives",
"Species input file"
),
value = c(
display_path(spmr_projection$output_dir),
as.character(spmr_input$beg_yr %||% spmr_input$styr),
as.character(spmr_input$nprj_yrs %||% spmr_input$npro),
as.character(spmr_input$nsims),
paste(as.integer(spmr_input$alts %||% spmr_input$alt_list), collapse = ", "),
as.character(spmr_input$datafile %||% spmr_input$spp_file_name)
)
) |>
gt_report() |>
tab_header(title = "Generated SPM Setup")
} else {
tibble(
item = c("Projection directory", "spmR parser"),
value = c(display_path(spmr_projection$output_dir), "spmR is not installed in the render environment")
) |>
gt_report() |>
tab_header(title = "Generated SPM Setup")
}
```
```{r}
#| label: tbl-spmr-alternative-descriptions
#| tbl-cap: "Text descriptions of the SPM projection alternatives included in the generated setup file."
spmr_alt_desc <- tibble(
Alternative = 1:7,
Name = c(
"Maximum permissible ABC",
"Author-specified ABC",
"Average recent F",
"Alternative SPR rate",
"No fishing",
"OFL threshold determination",
"Status-determination ramp"
),
Description = c(
"Projects catch using the maximum permissible Tier 3 ABC harvest rate from the SPM harvest-control rule.",
"Projects catch using the author-specified adjustment to the Tier 3 ABC harvest rate. In this generated RTMB setup, the author-F adjustment and ABC multiplier are both 1.0, so this alternative is currently equivalent to Alternative 1 unless those inputs are changed.",
"Projects catch using the recent average fishing mortality read from the assessment input file, rather than recalculating catch from the ABC harvest-control rule.",
"Projects catch using the user-specified Alternative 4 SPR rate. The generated setup uses SPR = 0.60, matching the SPM input convention for this alternative.",
"Projects the stock forward with F = 0, so catch is zero after any fixed catch years specified in the setup file.",
"Projects catch at the OFL harvest rate. This alternative supports threshold and status-determination calculations and uses a rule distinct from the TAC-equals-ABC alternatives.",
"Applies maximum permissible ABC catch for the first three projection years in the SPM implementation, then switches to the OFL harvest-rate calculation used for status determination."
)
)
spmr_alt_desc |>
gt_report() |>
tab_header(title = "SPM Projection Alternatives")
```
## Seven Tier-3 Scenario Results
The projection procedure converted the RTMB fit to standard SPM inputs and
evaluated all seven alternatives with the ADMB projection engine in `spmR`
(version `r spmr_version`). The comparison begins with 2027 because catches for
2025 and 2026 are fixed at 1,350 thousand t in every alternative.
```{r}
#| label: tbl-spmr-tier3-seven-scenarios
#| tbl-cap: 'Tier-3 projection results for all seven FMP alternatives using inputs generated from the RTMB EBS pollock model. Values are simulation means; catch and biomass quantities are in thousand t. $B/B_{35\\%}$ is spawning biomass relative to the Tier-3 $B_{35\\%}$ proxy.'
#| echo: false
tier3_table_file <- file.path(
spmr_projection$output_dir,
"tier3_seven_scenario_table.csv"
)
tier3_required_columns <- c(
"Alt", "Scenario",
paste0(c("Catch_", "ABC_", "OFL_", "SSB_", "F_", "B_B35_"), "2027"),
paste0(c("Catch_", "ABC_", "OFL_", "SSB_", "F_", "B_B35_"), "2028")
)
tier3_results <- readr::read_csv(tier3_table_file, show_col_types = FALSE)
tier3_missing_columns <- setdiff(tier3_required_columns, names(tier3_results))
if (nrow(tier3_results) != 7L ||
!setequal(as.integer(tier3_results$Alt), 1:7) ||
length(tier3_missing_columns) > 0L ||
anyNA(tier3_results[tier3_required_columns])) {
stop(
"Incomplete seven-scenario Tier 3 projection table. Missing columns: ",
paste(tier3_missing_columns, collapse = ", ")
)
}
tier3_results |>
gt_report() |>
fmt_number(
columns = matches("^(Catch|ABC|OFL|SSB)_"),
decimals = 0,
use_seps = TRUE
) |>
fmt_number(columns = matches("^F_"), decimals = 3) |>
fmt_number(columns = matches("^B_B35_"), decimals = 2) |>
cols_label(
Alt = "Alternative",
Catch_2027 = "Catch", ABC_2027 = "ABC", OFL_2027 = "OFL",
SSB_2027 = md("$B$"), F_2027 = md("$F$"), B_B35_2027 = md("$B/B_{35\\%}$"),
Catch_2028 = "Catch", ABC_2028 = "ABC", OFL_2028 = "OFL",
SSB_2028 = md("$B$"), F_2028 = md("$F$"), B_B35_2028 = md("$B/B_{35\\%}$")
) |>
tab_spanner(label = "2027", columns = ends_with("_2027")) |>
tab_spanner(label = "2028", columns = ends_with("_2028")) |>
tab_header(title = "Seven Tier-3 Projection Alternatives")
```
```{r}
#| label: tbl-spmr-projection-age-schedules
#| tbl-cap: "Key age-specific schedules used in the generated SPM projection input files."
projection_age_schedules <- tibble(
Age = ages,
`Spawning wt-at-age` = as.numeric(data$wt_ssb[length(years), ]),
`Fishery wt-at-age` = as.numeric(data$wt_fut %||% data$wt_fsh[length(years), ]),
Maturity = as.numeric(data$p_mature / max(data$p_mature, na.rm = TRUE)),
Selectivity = as.numeric(rtmb_report$sel_fsh[length(years), ])
)
projection_age_schedules |>
gt_report() |>
fmt_number(
columns = c(`Spawning wt-at-age`, `Fishery wt-at-age`, Maturity, Selectivity),
decimals = 3
) |>
tab_header(title = "Projection Age-Specific Schedules")
```
## Alternative 2 Fixed-Catch Projection
This additional projection run uses only Alternative 2 and fixes catch at 1,300 thousand t for each year from 2025 through 2032. The projection horizon is set to 2025--2032 so the generated run includes every requested fixed-catch year.
```{r}
#| label: spmr-alt2-fixed-inputs
#| include: false
alt2_fixed_catches <- stats::setNames(rep(1300, length(2025:2032)), 2025:2032)
spmr_alt2_projection <- spmr_writer_env$write_spmr_projection_inputs(
model_file = params$model_file,
output_dir = params$projection_alt2_dir,
config_path = rtmb_file("R", "config.R"),
alt_list = 2,
fixed_catches = alt2_fixed_catches,
nproj_years = length(alt2_fixed_catches),
run_name = "rtmb_alt2_fixed1300"
)
spmr_alt2_detail_file <- file.path(spmr_alt2_projection$output_dir, "spm_detail.csv")
spmr_alt2_detail <- if (file.exists(spmr_alt2_detail_file)) {
as_tibble(utils::read.csv(spmr_alt2_detail_file, check.names = FALSE))
} else {
tibble()
}
```
```{r}
#| label: tbl-spmr-alt2-fixed-results
#| tbl-cap: 'Candidate ABC projection given assumed future catches. Catch represents the estimate or expectation. $B/B_{35\\%}$ is mean biomass divided by $B_{35\\%}$, where $B_{35\\%}$ is the proxy for $B_{MSY}$. ABC is the maximum permissible ABC from the SPM Alternative 2 projection.'
if (nrow(spmr_alt2_detail) > 0) {
spmr_alt2_detail |>
filter(Alt == 2) |>
group_by(Year) |>
summarize(
Catch = mean(Catch, na.rm = TRUE),
ABC = mean(ABC, na.rm = TRUE),
OFL = mean(OFL, na.rm = TRUE),
`Mean B` = mean(SSB, na.rm = TRUE),
`B/B35%` = 100 * mean(SSB / B35, na.rm = TRUE),
.groups = "drop"
) |>
gt_report() |>
fmt_number(columns = c(Catch, ABC, OFL, `Mean B`), decimals = 0) |>
fmt_number(
columns = `B/B35%`, decimals = 0,
pattern = if (knitr::is_latex_output()) "{x}\\%" else "{x}%"
) |>
cols_label(
`Mean B` = md("Mean $B$"),
`B/B35%` = md("$B/B_{35\\%}$")
) |>
tab_header(title = "Candidate ABC Projection Given Assumed Future Catches")
} else {
tibble(note = paste("No Alternative 2 fixed-catch SPM output found at", display_path(spmr_alt2_detail_file))) |>
gt_report()
}
```
```{r}
#| label: tbl-spmr-projection-results
#| tbl-cap: 'Mean SPM projection results by alternative and year, read from spm_detail.csv when available. The table initially filters to Alternative 1 and includes all projection years; use the column filters to show other alternatives. $B/B_{35\\%}$ is mean biomass divided by $B_{35\\%}$, where $B_{35\\%}$ is the proxy for $B_{MSY}$.'
if (nrow(spmr_detail) > 0) {
spmr_projection_means <- spmr_detail |>
group_by(Alt, Year) |>
summarize(
B = mean(SSB, na.rm = TRUE),
Catch = mean(Catch, na.rm = TRUE),
ABC = mean(ABC, na.rm = TRUE),
OFL = mean(OFL, na.rm = TRUE),
F = mean(F, na.rm = TRUE),
`B/B35%` = 100 * mean(SSB / B35, na.rm = TRUE),
.groups = "drop"
) |>
mutate(Alt = as.character(Alt)) |>
arrange(as.integer(Alt), Year)
if (knitr::is_html_output() && requireNamespace("reactable", quietly = TRUE)) {
alt_filter_options <- paste(
sprintf(
"React.createElement('option', { value: '%s' }, '%s')",
sort(unique(spmr_projection_means$Alt)),
sort(unique(spmr_projection_means$Alt))
),
collapse = ", "
)
year_filter_options <- paste(
sprintf(
"React.createElement('option', { value: '%s' }, '%s')",
sort(unique(spmr_projection_means$Year)),
sort(unique(spmr_projection_means$Year))
),
collapse = ", "
)
exact_filter_method <- reactable::JS(
"function(rows, columnId, filterValue) {
if (!filterValue) return rows;
return rows.filter(function(row) {
return String(row.values[columnId]) === String(filterValue);
});
}"
)
spmr_projection_table <- reactable::reactable(
spmr_projection_means,
filterable = FALSE,
searchable = TRUE,
defaultPageSize = 14,
elementId = "spmr-projection-results-table",
columns = list(
Alt = reactable::colDef(
name = "Alt",
filterable = TRUE,
filterMethod = exact_filter_method,
filterInput = reactable::JS(paste0(
"function(column) {
return React.createElement('select', {
value: column.filterValue || '',
onChange: function(event) { column.setFilter(event.target.value || undefined); },
style: { width: '100%' }
}, [
React.createElement('option', { value: '' }, 'All'),
", alt_filter_options, "
]);
}"
))
),
Year = reactable::colDef(
filterable = TRUE,
filterMethod = exact_filter_method,
filterInput = reactable::JS(paste0(
"function(column) {
return React.createElement('select', {
value: column.filterValue || '',
onChange: function(event) { column.setFilter(event.target.value || undefined); },
style: { width: '100%' }
}, [
React.createElement('option', { value: '' }, 'All'),
", year_filter_options, "
]);
}"
)),
format = reactable::colFormat(digits = 0, separators = FALSE)
),
B = reactable::colDef(name = "B", filterable = FALSE, format = reactable::colFormat(digits = 0, separators = TRUE)),
Catch = reactable::colDef(filterable = FALSE, format = reactable::colFormat(digits = 0, separators = TRUE)),
ABC = reactable::colDef(filterable = FALSE, format = reactable::colFormat(digits = 0, separators = TRUE)),
OFL = reactable::colDef(filterable = FALSE, format = reactable::colFormat(digits = 0, separators = TRUE)),
F = reactable::colDef(filterable = FALSE, format = reactable::colFormat(digits = 3)),
`B/B35%` = reactable::colDef(
name = "B/B35%",
filterable = FALSE,
format = reactable::colFormat(digits = 0, suffix = "%")
)
)
)
if (requireNamespace("htmlwidgets", quietly = TRUE)) {
htmlwidgets::onRender(
spmr_projection_table,
"function(el, x) {
setTimeout(function() {
if (window.Reactable && Reactable.setFilter) {
Reactable.setFilter(el.id, 'Alt', '1');
}
}, 0);
}"
)
} else {
spmr_projection_table
}
} else {
spmr_projection_means |>
filter(Alt == "1") |>
gt_report() |>
fmt_number(columns = c(B, Catch, ABC, OFL), decimals = 0) |>
fmt_number(
columns = `B/B35%`, decimals = 0,
pattern = if (knitr::is_latex_output()) "{x}\\%" else "{x}%"
) |>
fmt_number(columns = F, decimals = 3) |>
cols_label(`B/B35%` = md("$B/B_{35\\%}$")) |>
tab_header(title = "SPM Projection Means")
}
} else {
tibble(note = paste("No SPM projection detail output found at", display_path(spmr_detail_file))) |>
gt_report()
}
```
## Projection Figures
The following figures summarize all 1,000 simulations in `spm_detail.csv` for
each of the seven Tier 3 alternatives. The lines show simulation medians and
the shaded intervals show the central 90% of the simulated outcomes. Figure
@fig-spmr-projection-stock-status also shows the same 10 reproducibly selected
simulation iterations in every alternative: 242, 278, 361, 495, 507, 510,
598, 837, 937, and 989.
```{r}
#| label: fig-spmr-projection-stock-status
#| fig-cap: "Projected spawning biomass under all seven Tier 3 alternatives. The dark line is the simulation median, shaded bands span the 5th to 95th percentiles of the 1,000 SPM simulations, and colored lines show the same 10 randomly selected simulation iterations in every panel. Spawning biomass is in thousand metric tons; the dashed horizontal line marks B35%."
#| fig-alt: "Seven vertically arranged spawning-biomass panels, one for each Tier 3 alternative. Each panel shows a dark median line, a blue 5th-to-95th-percentile ribbon, 10 colored individual simulation trajectories identified by iteration number, and a dashed horizontal B35-percent reference line at 2,092 thousand metric tons."
#| fig-width: 11
#| fig-height: 12
if (nrow(spmr_detail) > 0) {
spmr_alt_names <- setNames(
paste0("Alt ", spmr_alt_desc$Alternative, ": ", spmr_alt_desc$Name),
spmr_alt_desc$Alternative
)
set.seed(202508)
spmr_selected_sims <- sort(sample(unique(spmr_detail$Sim), 10))
spmr_stock_data <- spmr_detail |>
mutate(
scenario = factor(
spmr_alt_names[as.character(Alt)],
levels = unname(spmr_alt_names)
)
)
spmr_stock_plot <- spmr_stock_data |>
group_by(scenario, Year) |>
summarize(
lower = quantile(SSB, 0.05, na.rm = TRUE),
median = median(SSB, na.rm = TRUE),
upper = quantile(SSB, 0.95, na.rm = TRUE),
B35 = first(B35),
.groups = "drop"
) |>
mutate(reference = "B35%")
spmr_selected_paths <- spmr_stock_data |>
filter(Sim %in% spmr_selected_sims) |>
mutate(
iteration = factor(
Sim,
levels = spmr_selected_sims,
labels = paste("Iteration", spmr_selected_sims)
)
)
ggplot(spmr_stock_plot, aes(x = Year, y = median)) +
geom_ribbon(aes(ymin = lower, ymax = upper), fill = "#2b7a9b", alpha = 0.22) +
geom_line(
data = spmr_selected_paths,
aes(x = Year, y = SSB, color = iteration, group = iteration),
linewidth = 0.45,
alpha = 0.75,
inherit.aes = FALSE
) +
geom_line(color = "#102f3d", linewidth = 0.95) +
geom_line(
aes(x = Year, y = B35, linetype = reference),
color = "#4d4d4d",
linewidth = 0.6
) +
facet_wrap(vars(scenario), ncol = 1) +
scale_y_continuous(labels = scales::label_comma()) +
scale_linetype_manual(values = c("B35%" = "dashed")) +
labs(
x = "Year",
y = "Spawning biomass (thousand t)",
color = "Selected simulation",
linetype = "Reference"
) +
guides(
color = guide_legend(nrow = 2, byrow = TRUE),
linetype = guide_legend(order = 2)
) +
ggthemes::theme_few() +
theme(legend.position = "bottom")
} else {
plot.new()
text(0.5, 0.5, "SPM projection results are unavailable.", cex = 0.9)
}
```
```{r}
#| label: fig-spmr-projection-removals
#| fig-cap: "Projected catch and calculated ABC and OFL under all seven Tier 3 alternatives. Black lines show simulation medians, with line type distinguishing catch, ABC, and OFL; catch ribbons span the 5th to 95th percentiles of the 1,000 simulations. Colored lines show catch for the same 10 selected simulation iterations used in Figure 15. All quantities are thousand metric tons. ABC and OFL are reference quantities and can differ from realized catch under some alternatives."
#| fig-alt: "Seven-panel projection chart of catch, ABC, and OFL by Tier 3 alternative. Each panel shows black median lines distinguished by line type, a green 5th-to-95th-percentile catch ribbon, and 10 colored individual catch trajectories corresponding to iterations 242, 278, 361, 495, 507, 510, 598, 837, 937, and 989."
#| fig-width: 11
#| fig-height: 11
if (nrow(spmr_detail) > 0) {
spmr_removal_data <- spmr_detail |>
mutate(
scenario = factor(
spmr_alt_names[as.character(Alt)],
levels = unname(spmr_alt_names)
)
)
spmr_removal_plot <- spmr_removal_data |>
select(scenario, Year, Catch, ABC, OFL) |>
pivot_longer(c(Catch, ABC, OFL), names_to = "quantity", values_to = "value") |>
group_by(scenario, Year, quantity) |>
summarize(
lower = quantile(value, 0.05, na.rm = TRUE),
median = median(value, na.rm = TRUE),
upper = quantile(value, 0.95, na.rm = TRUE),
.groups = "drop"
)
spmr_selected_catch <- spmr_removal_data |>
filter(Sim %in% spmr_selected_sims) |>
mutate(
iteration = factor(
Sim,
levels = spmr_selected_sims,
labels = paste("Iteration", spmr_selected_sims)
)
)
removal_plot_max <- max(
spmr_removal_plot$upper,
spmr_selected_catch$Catch,
na.rm = TRUE
) * 1.03
ggplot(spmr_removal_plot, aes(x = Year, y = median)) +
geom_ribbon(
data = filter(spmr_removal_plot, quantity == "Catch"),
aes(ymin = lower, ymax = upper),
fill = "#5b8c5a",
color = NA,
alpha = 0.2
) +
geom_line(
data = spmr_selected_catch,
aes(x = Year, y = Catch, color = iteration, group = iteration),
linewidth = 0.45,
alpha = 0.75,
inherit.aes = FALSE
) +
geom_line(aes(linetype = quantity), color = "#102f3d", linewidth = 0.85) +
facet_wrap(~scenario, ncol = 2) +
scale_linetype_manual(values = c(Catch = "solid", ABC = "dashed", OFL = "dotdash")) +
scale_y_continuous(labels = scales::label_comma()) +
coord_cartesian(ylim = c(0, removal_plot_max)) +
labs(
x = "Year",
y = "Thousand metric tons",
color = "Selected simulation",
linetype = "Median quantity"
) +
guides(
linetype = guide_legend(order = 1),
color = guide_legend(nrow = 2, byrow = TRUE, order = 2)
) +
ggthemes::theme_few() +
theme(
legend.position = "bottom",
legend.box = "vertical"
)
} else {
plot.new()
text(0.5, 0.5, "SPM projection results are unavailable.", cex = 0.9)
}
```
```{r}
#| label: fig-spmr-projection-fishing-mortality
#| fig-cap: "Projected fishing mortality under all seven Tier 3 alternatives. The dark line is the simulation median, shaded bands span the 5th to 95th percentiles of the 1,000 simulations, and colored lines show the same 10 selected simulation iterations used in Figures 15 and 16."
#| fig-alt: "Seven-panel fishing-mortality projection chart by Tier 3 alternative. Each panel shows a dark median line, an orange 5th-to-95th-percentile ribbon, and 10 colored individual trajectories corresponding to iterations 242, 278, 361, 495, 507, 510, 598, 837, 937, and 989."
#| fig-width: 11
#| fig-height: 10
if (nrow(spmr_detail) > 0) {
spmr_f_plot <- spmr_detail |>
mutate(
scenario = factor(
spmr_alt_names[as.character(Alt)],
levels = unname(spmr_alt_names)
)
) |>
group_by(scenario, Year) |>
summarize(
lower = quantile(F, 0.05, na.rm = TRUE),
median = median(F, na.rm = TRUE),
upper = quantile(F, 0.95, na.rm = TRUE),
.groups = "drop"
)
spmr_selected_f <- spmr_stock_data |>
filter(Sim %in% spmr_selected_sims) |>
mutate(
iteration = factor(
Sim,
levels = spmr_selected_sims,
labels = paste("Iteration", spmr_selected_sims)
)
)
f_plot_max <- max(spmr_f_plot$upper, spmr_selected_f$F, na.rm = TRUE) * 1.03
ggplot(spmr_f_plot, aes(x = Year, y = median)) +
geom_ribbon(aes(ymin = lower, ymax = upper), fill = "#d18b2c", alpha = 0.24) +
geom_line(
data = spmr_selected_f,
aes(x = Year, y = F, color = iteration, group = iteration),
linewidth = 0.45,
alpha = 0.75,
inherit.aes = FALSE
) +
geom_line(color = "#4d3210", linewidth = 0.95) +
facet_wrap(~scenario, ncol = 2) +
scale_y_continuous(labels = scales::label_number(accuracy = 0.01)) +
coord_cartesian(ylim = c(0, f_plot_max)) +
labs(
x = "Year",
y = "Fishing mortality",
color = "Selected simulation"
) +
guides(color = guide_legend(nrow = 2, byrow = TRUE)) +
ggthemes::theme_few() +
theme(legend.position = "bottom")
} else {
plot.new()
text(0.5, 0.5, "SPM projection results are unavailable.", cex = 0.9)
}
```
The projections use the production ADMB projection engine through
`spmR::runSPM()`. This preserves the accepted projection calculations while
isolating the effect of using population estimates from the RTMB model.
# Diagnostics
```{r}
#| label: bridge-series-data
#| include: false
rtmb_diag_series <- ts_df |>
transmute(model = "RTMB-ADMB base", source = "RTMB", year, SSB = ssb, Recruitment = recruitment) |>
pivot_longer(c(SSB, Recruitment), names_to = "quantity", values_to = "value")
diag_series <- bind_rows(
rtmb_diag_series,
only_bts_ts,
admb_ts |>
filter(quantity %in% c("SSB", "Recruitment")) |>
select(model, source, year, quantity, value)
)
```
## Retrospective Peels
The retrospective procedure included peel 0 (the full model terminating in
2024) and nine peels terminating in 2023 through 2015. Each peel retained the
full model's stream-specific observation lag. Thus, because fishery age
compositions ended in 2023 in the full model, they ended in 2022 in the first
peel. Terminal-year fishery, BTS, and ATS selectivity was fixed at the
corresponding penultimate-year value within each peel. Annual inputs and
parameter vectors were truncated to the applicable terminal year, and each
fit was initialized from the preceding fitted peel. The established 2020 gap
in the BTS biomass index was retained.
```{r}
#| label: tbl-retrospective-availability
#| tbl-cap: "Maximum observation year retained for each data stream in the full model and nine retrospective peels. Stream-specific lags remain constant across peels."
if (!is.null(retro_saved$availability)) {
retrospective_availability <- readr::read_csv(
rtmb_file(
"analysis", "output", "corrected_full_age_bts",
"retrospective_data_availability.csv"
),
show_col_types = FALSE
)
retrospective_availability |>
gt_report() |>
tab_header(title = "Retrospective Data-Availability Audit") |>
tab_options(
table.font.size = px(8),
data_row.padding = px(1)
)
}
```
The observations underlying @tbl-retrospective-availability are available as
a [machine-readable CSV file](data-output/retrospective_data_availability.csv).
```{r}
#| label: tbl-retrospective-selectivity
#| tbl-cap: "Maximum absolute difference between terminal-year and penultimate-year selectivity by fleet for each retrospective peel. Values at numerical zero verify the terminal-year equality constraint."
if (!is.null(retro_saved$terminal_selectivity)) {
as_tibble(retro_saved$terminal_selectivity) |>
filter(peel > 0) |>
select(peel, terminal_year, fleet, maximum_absolute_difference) |>
arrange(peel, fleet) |>
gt_report() |>
fmt_number(columns = maximum_absolute_difference, decimals = 10) |>
tab_header(title = "Retrospective Terminal-Selectivity Audit")
}
```
```{r}
#| label: tbl-retrospective-status
#| tbl-cap: "RTMB retrospective run status for the full model (peel 0) and nine terminal-year peels. A convergence code of 0 indicates normal optimizer completion. Peels with an initial maximum gradient above 0.001 received one tighter restart; optimization passes records whether that restart was used."
if (nrow(retro_diagnostics) > 0) {
retro_diagnostics |>
mutate(
status = case_when(
is.na(convergence) ~ "failed",
convergence == 0 ~ "converged",
TRUE ~ paste0("optimizer code ", convergence)
),
error = coalesce(error, "")
) |>
select(
peel, terminal_year, status, optimization_passes,
objective, max_gradient, error
) |>
gt_report() |>
fmt_number(columns = any_of(c("objective", "max_gradient")), decimals = 3) |>
tab_header(title = "RTMB Retrospective Peel Status")
} else {
tibble(note = paste("No retrospective output found at", display_path(retro_file))) |>
gt_report()
}
```
```{r}
#| label: tbl-retrospective-mohn
#| tbl-cap: "Mohn's rho for spawning biomass and recruitment across nine retrospective peels. For each peel, the terminal-year estimate is compared with the estimate for the same year from the full model; rho is the mean relative difference. Positive values indicate that the truncated assessments estimate the quantity above the corresponding full-model estimate."
if (nrow(retro_mohn) > 0) {
retro_mohn |>
mutate(quantity = recode(quantity, SSB = "Spawning biomass")) |>
gt_report() |>
fmt_number(columns = rho, decimals = 3) |>
cols_label(quantity = "Quantity", rho = "Mohn's rho", n_peels = "Peels") |>
tab_header(title = "Nine-Peel Retrospective Summary")
}
```
```{r}
#| label: fig-retrospective-ssb-recruitment
#| fig-cap: "RTMB spawning-biomass and recruitment trajectories for the full model and nine retrospective peels. Each trajectory ends in its peel-specific terminal year."
#| fig-alt: "Two-panel retrospective line chart for spawning biomass and recruitment. The full model ends in 2024 and nine peel trajectories end in 2023 through 2015."
if (nrow(retro_series) > 0) {
retro_series |>
pivot_longer(c(SSB, Recruitment), names_to = "quantity", values_to = "value") |>
mutate(peel = paste0("Peel ", peel)) |>
ggplot(aes(x = year, y = value, color = peel, group = peel)) +
geom_line(linewidth = 0.85) +
facet_wrap(~quantity, scales = "free_y", ncol = 1) +
scale_y_continuous(limits = c(0, NA), labels = scales::label_comma()) +
labs(x = "Year", y = "Value", color = "Run", title = "RTMB Retrospective Peels")
} else {
plot.new()
text(
0.5, 0.5,
"No retrospective trajectory series was extractable from the current RTMB peel run.",
cex = 0.9
)
}
```
All `r sum(retro_diagnostics$peel > 0 & is.na(retro_diagnostics$error))` peels completed and produced trajectory estimates. `r sum(retro_diagnostics$convergence == 0, na.rm = TRUE)` of the `r nrow(retro_diagnostics)` fits ended with convergence code 0. The largest maximum gradient across all fits was `r scales::number(max(retro_diagnostics$max_gradient, na.rm = TRUE), accuracy = 0.0001)`. Mohn's rho was `r scales::number(retro_mohn$rho[retro_mohn$quantity == "SSB"], accuracy = 0.001)` for spawning biomass and `r scales::number(retro_mohn$rho[retro_mohn$quantity == "Recruitment"], accuracy = 0.001)` for recruitment. Positive values indicate that truncated assessments estimate these quantities above their corresponding full-model estimates. The retrospective pattern forms an important component of the stability and uncertainty evaluation.
## Additional Bridge Diagnostics and Only-BTS Sensitivity
The `Only BTS` curve is a separate RTMB sensitivity from the same base
configuration with the ATS biomass index, ATS age-1 index, and AVO index
likelihood components excluded. BTS, CPUE, catch, composition, recruitment,
selectivity, and weight-at-age components remain active. This sensitivity
illustrates the influence of the excluded indices and is not an alternative
assessment model.
```{r}
#| label: tbl-only-bts-status
#| tbl-cap: "Status for the Only BTS RTMB sensitivity model used in the bridge-comparison plot."
tibble(
item = c("Only BTS output", "Excluded likelihoods", "Convergence", "Objective", "Maximum gradient"),
value = c(
display_path(only_bts_file),
if (!is.null(only_bts_metadata$excluded_likelihoods)) paste(only_bts_metadata$excluded_likelihoods, collapse = ", ") else NA_character_,
if (!is.null(only_bts_saved$fit$convergence)) as.character(only_bts_saved$fit$convergence) else NA_character_,
if (!is.null(only_bts_saved$fit$objective)) sprintf("%.3f", only_bts_saved$fit$objective) else NA_character_,
if (!is.null(only_bts_metadata$max_gradient)) sprintf("%.6f", only_bts_metadata$max_gradient) else NA_character_
)
) |>
gt_report() |>
tab_header(title = "Only BTS Sensitivity Run")
```
```{r}
#| label: tbl-admb-bridge
#| tbl-cap: "Maximum absolute percent difference between the RTMB-ADMB base model and the ADMB bridge report for shared quantities."
if (exists("pm") && !is.null(pm)) {
bridge_tbl <- compare_max_pct(rtmb_report, pm, tolerance = 1e-6) |>
arrange(desc(max_abs_pct_diff))
} else {
bridge_tbl <- tibble(note = "ADMB bridge report was not available.")
}
bridge_tbl |>
gt_report() |>
fmt_number(columns = any_of(c("max_abs_diff", "max_abs_pct_diff", "cor")), decimals = 6) |>
tab_header(title = "RTMB vs ADMB Bridge Comparison")
```
```{r}
#| label: fig-admb-bridge
#| fig-cap: "Shared RTMB and ADMB bridge time series for spawning biomass and recruitment, including the Only BTS RTMB sensitivity model with ATS and AVO survey index likelihoods excluded."
#| fig-alt: "Two-panel line chart of spawning biomass and recruitment for the corrected RTMB bridge, corrected ADMB bridge, and Only-BTS RTMB sensitivity. The corrected bridge lines overlap closely."
if (nrow(admb_ts) > 0) {
ggplot(diag_series, aes(x = year, y = value, color = model, linetype = source, group = model)) +
geom_line(linewidth = 0.9) +
facet_wrap(~quantity, scales = "free_y", ncol = 1) +
scale_y_continuous(limits = c(0, NA), labels = scales::label_comma()) +
scale_color_manual(values = c("RTMB-ADMB base" = "#1b9e77", "Only BTS" = "#d95f02", "ADMB bridge" = "#1f78b4")) +
scale_linetype_manual(values = c("RTMB" = "solid", "ADMB" = "22")) +
labs(x = "Year", y = "Value", color = "Model", linetype = "Source", title = "RTMB and ADMB Bridge Time Series")
} else {
plot.new()
text(0.5, 0.5, "ADMB bridge report not available.", cex = 1)
}
```
# Summary
The RTMB implementation reproduces the corrected full-age BTS ADMB bridge at
the shared ADMB maximum-likelihood estimates. Observed and predicted BTS
compositions each span ages 1--15 and sum to one, nominal integer sample sizes
enter the multinomial likelihood, and the BTS total-numbers quantity used for
composition scaling retains its ages 2--15 definition. The fitted BTS survey
index is a biomass index. Comparison with the historical configuration shows
the effect of correcting the BTS likelihood treatment.
The OSA diagnostics, Only-BTS sensitivity, nine retrospective peels, and SPM
projections use the same corrected base specification. The retrospective
procedure preserves stream-specific data lags and fixes terminal-year
selectivity at the penultimate-year curve. Positive Mohn's rho values identify
a stability concern requiring continued evaluation. Candidate refinements
require simulation testing and review before operational use. Current
management advice remains based on the accepted ADMB assessment model; the
hierarchical Form-2 SparseNUTS results characterize a separate candidate
selectivity formulation.
# Reproducibility
```{r}
#| label: tbl-reproducibility
#| tbl-cap: "Files and commands supporting reproducibility of the RTMB-ADMB results."
repro_tbl <- tibble(
item = c(
"Working directory",
"Complete corrected rebuild command",
"Render command",
"Default SparseNUTS command",
"RTMB report object",
"Default SparseNUTS output",
"ADMB bridge run",
"RTMB source"
),
value = c(
display_path(pollock_root),
"Rscript R/rebuild_corrected_full_age_bts_products.R",
"quarto render reporting/ebs_pollock_rtmb_ebswp_assessment.qmd",
"quarto render -P run_sparsenuts:true",
display_path(model_file),
display_path(sparsenuts_file),
display_path(rtmb_file(params$admb_run_dir)),
display_path(rtmb_root)
)
)
repro_tbl |>
gt_report() |>
tab_header(title = "Reproducibility Checklist")
```
# Supporting Tables
```{r}
#| label: tbl-key-results
#| tbl-cap: "Key terminal-year values from the saved base RTMB-ADMB model."
terminal_tbl <- tibble(
metric = c("Total biomass", "Spawning biomass", "Recruitment", "Mean F", "Total F"),
year = terminal_year,
value = c(
tail(ts_df$biomass, 1),
tail(ts_df$ssb, 1),
tail(ts_df$recruitment, 1),
tail(ts_df$mean_f, 1),
tail(ts_df$total_f, 1)
)
)
terminal_tbl |>
gt_report() |>
fmt_number(columns = value, decimals = 3) |>
tab_header(title = "Terminal-Year RTMB-ADMB Estimates")
```
```{r}
#| label: tbl-q
#| tbl-cap: "Index catchability and stock-recruitment scalars reported by the RTMB-ADMB model."
scalar_tbl <- tibble(
quantity = c("Bzero", "phizero", "steepness"),
value = c(rtmb_report$Bzero, rtmb_report$phizero, rtmb_report$steepness)
)
scalar_tbl |>
gt_report() |>
fmt_number(columns = value, decimals = 6) |>
tab_header(title = "Reported Scalar Quantities")
```
```{r}
#| label: tbl-naa-comparison
#| tbl-cap: "Initial and terminal estimated numbers-at-age from the base RTMB-ADMB model."
naa_tbl <- bind_rows(
tibble(year = first_year, age = ages, numbers = as.numeric(rtmb_report$N[1, ])),
tibble(year = terminal_year, age = ages, numbers = as.numeric(rtmb_report$N[nrow(rtmb_report$N), ]))
)
naa_tbl |>
gt_report() |>
fmt_number(columns = numbers, decimals = 3) |>
tab_header(title = "Numbers at Age")
```
```{r}
#| label: tbl-f-at-age
#| tbl-cap: "Estimated terminal-year fishery F-at-age from the base RTMB-ADMB model."
f_at_age_tbl <- tibble(
year = terminal_year,
age = ages,
f_at_age = as.numeric(rtmb_report$F[nrow(rtmb_report$F), ])
)
f_at_age_tbl |>
gt_report() |>
fmt_number(columns = f_at_age, decimals = 6) |>
tab_header(title = "Terminal-Year Fishery F at Age")
```
# References {.unnumbered}
::: {#refs}
:::
# Appendices {.unnumbered}
## A-1 Data issues and revisions since the 2024 assessment {.unnumbered #sec-age-data-issues}
This appendix documents two distinct age-data issues considered after the 2024
assessment: the method used to assign ages to individual otoliths and the
spatio-temporal method used to expand BTS age samples into annual proportions
at age. The first concerns traditional microscope ages (TMA) versus ages
predicted by Fourier-transform near-infrared spectroscopy (FT-NIRS). The
second concerns replacement of the prior BTS age-composition estimator with a
tinyVAST implementation. These changes occur at different stages of the data
workflow and should be evaluated separately.
### FTNIRS age-data {.unnumbered #sec-ftnirs-age-data}
TMA assigns age by preparing an otolith and visually counting annual growth
zones under a microscope. FT-NIRS instead measures the wavelengths and amount
of near-infrared light absorbed by an otolith and predicts age from its
spectral and chemical signal using a calibration model. FT-NIRS can process
otoliths substantially faster, but its predicted ages are methodologically
different from direct microscope readings ([NOAA Fisheries age-method
overview](https://www.fisheries.noaa.gov/feature-story/age-and-growth-homework-determining-how-old-fish-are)).
The 2025 CIE discussion paper compared the two methods using pollock data. For
the same design-based BTS abundance-at-age inputs, TMA estimates showed a high
degree of cohort consistency, whereas FT-NIRS estimates showed lower cohort
consistency; the assessment authors described the consequence of that
difference as unresolved. The comparison also identified differences between
TMA- and FT-NIRS-based proportions at age for the fishery, BTS, and ATS. Model
tests therefore treated FT-NIRS ages as a separate data source and considered
both global and fleet-specific FT-NIRS age-error matrices. See the official
[FT-NIRS data consistency
comparisons](https://noaa-afsc.github.io/EBS_pollock/doc/CIE.html#ft-nirs-data-consistency-comparisons)
for the cohort plots, composition comparisons, data coverage, and alternative
age-error treatments.
The FT-NIRS issue concerns age assignment and associated ageing error. The BTS
bridge below concerns the subsequent expansion of age observations across
space and time. Consequently, the controlled BTS bridge should not be
interpreted as a test of TMA against FT-NIRS.
### Impact of revised BTS age-data {.unnumbered #sec-bts-age-data-bridge}
This appendix isolates the effect of replacing the original bottom-trawl
survey (BTS) proportions at age in `BTSProp.csv` with the revised proportions
in `tinyVAST_props_new.csv`. Both ADMB runs use the complete 2025 input set and
the same model specification, executable, starting parameter file, and
tinyVAST 2025 BTS age observation. The sensitivity restores the original
1982-2024 BTS proportions while holding the 2025 tinyVAST row constant. The
comparison therefore addresses the historical estimator change.
The 2024 assessment used the previous spatio-temporal expansion of BTS age
samples. The revised series uses an improved implementation in `tinyVAST`, a
multivariate spatio-temporal generalized linear mixed-model framework that can
model age groups jointly, share information across locations and years, and
area-expand predictions to annual abundance and proportions at age
[@thorson2019spatiotemporalcomposition; @thorson2025tinyvast]. The
[tinyVAST age-composition expansion
example](https://vast-lib.github.io/tinyVAST/articles/web_only/age_composition_expansion.html)
documents this workflow for EBS pollock age data. This methodological update
changes the estimated BTS proportions at age supplied to the assessment; the
controlled runs below quantify the resulting assessment-model effect while
holding the other inputs and model configuration fixed.
```{r}
#| label: bts-age-data-bridge-load
#| include: false
bts_age_bridge_file <- rtmb_file(
"analysis", "output", "bts_age_data_bridge", "bts_age_data_bridge.rds"
)
if (!file.exists(bts_age_bridge_file)) {
stop(
"Missing BTS age-data bridge output. Run: ",
"Rscript scripts/run_bts_age_data_bridge.R"
)
}
bts_age_bridge <- readRDS(bts_age_bridge_file)
bts_age_comparison <- as_tibble(bts_age_bridge$comparison)
bts_age_diagnostics <- as_tibble(bts_age_bridge$diagnostics)
bts_age_input_summary <- as_tibble(bts_age_bridge$input_summary)
bts_age_input_comparison <- as_tibble(bts_age_bridge$age_data_comparison)
bts_age_input_extremes <- bts_age_input_comparison |>
summarise(
maximum_increase = max(percent_change),
maximum_decrease = min(percent_change),
maximum_percentage_point_change = max(
abs(100 * (tinyvast_proportion - original_proportion))
)
)
tinyvast_retro_file <- rtmb_file(
"analysis", "output", "bts_age_data_bridge",
"tinyvast_rtmb_retro_9_peel.rds"
)
if (!file.exists(tinyvast_retro_file)) {
stop(
"Missing tinyVAST retrospective output. Run: ",
"RTMB_RETRO_BTS_PROPS=/path/to/tinyVAST_props_new.csv ",
"RTMB_RETRO_OUTPUT=analysis/output/bts_age_data_bridge/",
"tinyvast_rtmb_retro_9_peel.rds Rscript R/run_retrospective.R"
)
}
tinyvast_retro <- readRDS(tinyvast_retro_file)
tinyvast_retro_diagnostics <- as_tibble(tinyvast_retro$diagnostics)
tinyvast_retro_mohn <- as_tibble(tinyvast_retro$mohn$rho)
tinyvast_retro_series <- as_tibble(tinyvast_retro$series) |>
pivot_longer(
cols = c(SSB, Recruitment),
names_to = "quantity",
values_to = "value"
) |>
mutate(
quantity = recode(
quantity,
SSB = "Spawning biomass",
Recruitment = "Age-1 recruitment"
),
run = if_else(peel == 0, "Full model", "Retrospective peel")
)
bts_age_result_summary <- bts_age_comparison |>
group_by(quantity) |>
summarise(
terminal_year = max(year),
terminal_percent_difference = percent_difference[which.max(year)],
maximum_absolute_percent_difference = max(abs(percent_difference)),
year_of_maximum_difference = year[which.max(abs(percent_difference))],
.groups = "drop"
) |>
mutate(
quantity = recode(
quantity,
spawning_biomass = "Spawning biomass",
recruitment_age1 = "Age-1 recruitment",
predicted_catch = "Predicted catch"
)
)
```
```{r}
#| label: tbl-bts-age-data-contrast
#| tbl-cap: "Controlled input contrast for the revised BTS age-data bridge. The 2025 BTS age observation and all non-BTS-age inputs are identical between runs."
bts_age_input_summary |>
gt_report() |>
tab_header(title = "BTS Age-Data Contrast")
```
The source-data comparison uses the `both` region from `BTSProp.csv` as the
original series and `tinyVAST_props_new.csv` as the revised series
(@fig-bts-age-input-change). Across the 42 matched survey years, relative
changes range from
`r sprintf("%.1f%%", bts_age_input_extremes$maximum_decrease)` to
`r sprintf("%+.1f%%", bts_age_input_extremes$maximum_increase)`; the largest
absolute change is
`r sprintf("%.2f percentage points", bts_age_input_extremes$maximum_percentage_point_change)`.
The calculation uses the original proportion as the denominator and describes
the input revision rather than its influence on model results. The revised
2025 row is excluded because the original file ends in 2024.
```{r}
#| label: fig-bts-age-input-change
#| fig-cap: "Percent change in BTS proportions at age from the original BTSProp.csv series to the revised tinyVAST_props_new.csv series for each matched historical survey year. Positive bars indicate a larger tinyVAST proportion and negative bars indicate a smaller tinyVAST proportion. Age 15 is the plus group; no BTS survey occurred in 2020."
#| fig-alt: "Small-multiple bar chart for 42 matched BTS survey years from 1982 through 2024, excluding 2020. Each panel shows relative percent change from the original series to the tinyVAST series for ages 1 through 15. Bars above zero indicate increases and bars below zero indicate decreases. Changes range from about minus 12 percent to plus 55 percent, with the largest increase at age 12 in 2023."
#| fig-width: 13
#| fig-height: 10
bts_age_input_comparison |>
ggplot(aes(age, percent_change, fill = direction)) +
geom_hline(yintercept = 0, color = "grey35", linewidth = 0.3) +
geom_col(width = 0.82) +
facet_wrap(vars(year), ncol = 7) +
scale_x_continuous(breaks = c(1, 5, 10, 15)) +
scale_y_continuous(labels = scales::label_number(suffix = "%")) +
scale_fill_manual(
values = c("Decrease" = "#2166AC", "Increase" = "#B2182B")
) +
labs(
x = "Age (15 is plus group)",
y = "Change from prior proportion at age",
fill = "Direction"
) +
theme(
legend.position = "top",
panel.grid.minor = element_blank(),
strip.text = element_text(face = "bold")
)
```
Both runs reached maximum absolute gradients below 0.001. The likelihood
components in @tbl-bts-age-data-diagnostics document the fits and support a
structured contrast between scenarios with different observed BTS age values.
```{r}
#| label: tbl-bts-age-data-diagnostics
#| tbl-cap: "ADMB fit diagnostics for the matched 2025 model with tinyVAST BTS proportions and with original BTSProp proportions for 1982-2024. Negative-log-likelihood values diagnose each data version; cross-data model selection requires a common observation set and likelihood definition."
bts_age_diagnostics |>
gt_report() |>
fmt_number(
columns = c(total_nll, bts_index_nll, bts_age_nll),
decimals = 3
) |>
fmt_scientific(columns = maximum_gradient, decimals = 2) |>
cols_label(
scenario = "Data version",
total_nll = "Total NLL",
bts_index_nll = "BTS index NLL",
bts_age_nll = "BTS age NLL",
maximum_gradient = "Maximum |gradient|"
) |>
tab_header(title = "BTS Age-Data Bridge Diagnostics")
```
The revision changes terminal spawning biomass by
`r sprintf("%+.3f%%", bts_age_result_summary$terminal_percent_difference[bts_age_result_summary$quantity == "Spawning biomass"])`.
The largest spawning-biomass difference is
`r sprintf("%.3f%%", bts_age_result_summary$maximum_absolute_percent_difference[bts_age_result_summary$quantity == "Spawning biomass"])`
in `r bts_age_result_summary$year_of_maximum_difference[bts_age_result_summary$quantity == "Spawning biomass"]`.
Terminal age-1 recruitment changes by
`r sprintf("%+.3f%%", bts_age_result_summary$terminal_percent_difference[bts_age_result_summary$quantity == "Age-1 recruitment"])`,
which is the largest recruitment difference in the series. Terminal predicted
catch changes by
`r sprintf("%+.3f%%", bts_age_result_summary$terminal_percent_difference[bts_age_result_summary$quantity == "Predicted catch"])`.
```{r}
#| label: tbl-bts-age-data-results
#| tbl-cap: "Relative effects of replacing the original historical BTS proportions with tinyVAST proportions. Percent differences are tinyVAST minus original, divided by the absolute original estimate."
bts_age_result_summary |>
gt_report() |>
fmt_number(
columns = c(
terminal_percent_difference,
maximum_absolute_percent_difference
),
decimals = 3
) |>
cols_label(
quantity = "Quantity",
terminal_year = "Terminal year",
terminal_percent_difference = "Terminal difference (%)",
maximum_absolute_percent_difference = "Maximum absolute difference (%)",
year_of_maximum_difference = "Year of maximum"
) |>
tab_header(title = "Effects of tinyVAST Historical BTS Proportions")
```
```{r}
#| label: fig-bts-age-data-bridge
#| fig-cap: "Percent differences in spawning biomass, age-1 recruitment, and predicted catch between the 2025 model using tinyVAST BTS proportions and the sensitivity using original BTSProp proportions for 1982-2024. The horizontal line marks no difference."
#| fig-alt: "Three-panel line graph of percent differences from 1964 through 2025. Spawning-biomass differences remain within one percent and equal minus 0.4 percent in 2025. Recruitment differences remain within four percent and equal minus 2.0 percent in 2025. Predicted-catch differences remain within 0.1 percent."
#| fig-width: 10
#| fig-height: 7
bts_age_comparison |>
mutate(
quantity = recode(
quantity,
spawning_biomass = "Spawning biomass",
recruitment_age1 = "Age-1 recruitment",
predicted_catch = "Predicted catch"
)
) |>
ggplot(aes(year, percent_difference)) +
geom_hline(yintercept = 0, color = "grey50", linewidth = 0.4) +
geom_line(color = "#1f4e79", linewidth = 0.7) +
geom_point(color = "#1f4e79", size = 1.1) +
facet_wrap(vars(quantity), scales = "free_y", ncol = 1) +
labs(x = "Year", y = "Difference from prior-age sensitivity (%)") +
theme(legend.position = "none")
```
#### Nine-peel tinyVAST retrospective {.unnumbered}
The RTMB retrospective uses the exact 1982-2024 `both`-region proportions from
`tinyVAST_props_new.csv`. Peel 0 terminates in 2024 and nine successive peels
terminate in 2023 through 2015. Each peel removes observations after its
terminal year and initializes from the preceding fitted peel.
```{r}
#| label: tbl-tinyvast-retro-diagnostics
#| tbl-cap: "RTMB convergence diagnostics for the full tinyVAST model and nine retrospective peels. Optimizer code 0 indicates normal completion; maximum absolute gradient is the primary convergence criterion."
tinyvast_retro_diagnostics |>
select(-error) |>
gt_report() |>
fmt_number(columns = objective, decimals = 3) |>
fmt_scientific(columns = max_gradient, decimals = 2) |>
cols_label(
peel = "Peel",
terminal_year = "Terminal year",
convergence = "Optimizer code",
objective = "Objective",
max_gradient = "Maximum |gradient|",
optimization_passes = "Optimization passes"
) |>
tab_header(title = "tinyVAST Nine-peel Retrospective Diagnostics")
```
```{r}
#| label: tbl-tinyvast-retro-mohn
#| tbl-cap: "Mohn's rho for spawning biomass and age-1 recruitment across nine RTMB retrospective peels using the tinyVAST BTS proportions."
tinyvast_retro_mohn |>
mutate(
quantity = recode(
quantity,
SSB = "Spawning biomass",
Recruitment = "Age-1 recruitment"
)
) |>
gt_report() |>
fmt_number(columns = rho, decimals = 3) |>
cols_label(quantity = "Quantity", rho = "Mohn's rho", n_peels = "Peels") |>
tab_header(title = "tinyVAST Retrospective Mohn's Rho")
```
```{r}
#| label: fig-tinyvast-retrospective
#| fig-cap: "RTMB spawning-biomass and age-1 recruitment trajectories for the full 2024 model and nine retrospective peels using tinyVAST BTS proportions. Points mark the terminal year of each trajectory."
#| fig-alt: "Two-panel retrospective line graph for spawning biomass and age-1 recruitment. The full model ends in 2024 and nine peels end in 2023 through 2015. Most truncated trajectories lie above the full-model trajectory near their terminal years, corresponding to positive Mohn's rho values of 0.283 for spawning biomass and 0.311 for recruitment."
#| fig-width: 10
#| fig-height: 7
tinyvast_retro_series |>
ggplot(aes(year, value, group = peel, color = factor(peel))) +
geom_line(aes(linewidth = run)) +
geom_point(
data = \(x) filter(x, year == terminal_year),
aes(shape = run),
size = 2
) +
facet_wrap(vars(quantity), scales = "free_y", ncol = 1) +
scale_linewidth_manual(values = c("Full model" = 1.1, "Retrospective peel" = 0.55)) +
labs(
x = "Year",
y = "Estimate",
color = "Peel",
shape = "Run",
linewidth = "Run"
) +
theme(legend.position = "bottom")
```
All ten RTMB fits have maximum absolute gradients below 0.001. Peels 2, 4,
and 8 ended with optimizer code 1 after tighter restarts, but their gradients
were below the reporting criterion. Mohn's rho is
`r scales::number(tinyvast_retro_mohn$rho[tinyvast_retro_mohn$quantity == "SSB"], accuracy = 0.001)`
for spawning biomass and
`r scales::number(tinyvast_retro_mohn$rho[tinyvast_retro_mohn$quantity == "Recruitment"], accuracy = 0.001)`
for age-1 recruitment. Both values indicate a positive retrospective pattern.
Replacing the historical BTS proportions with tinyVAST has a small effect on
terminal spawning biomass and predicted catch in the controlled ADMB bridge,
and a somewhat larger effect on recruitment. The positive retrospective
pattern remains an important stability caveat when considering adoption.
## A-2 Evaluation of time-varying BTS availability {.unnumbered #sec-bts-availability}
This diagnostic isolates the biomass variation induced by the fitted
time-varying bottom-trawl survey (BTS) selectivity. It holds population
abundance and weight at age constant across years. The fixed abundance vector
for ages 1--15 is the arithmetic mean of the model-estimated numbers at each
age across 1982--2024. The fixed weight vector is the mean BTS weight at each
age across the survey observations. This centers the controlled calculation
on the estimated population age structure over the analysis period while
removing annual changes in population abundance.
For year $t$, the selectivity-only vulnerable biomass is
$$
B^{\mathrm{sel}}_t = \sum_{a=1}^{15} \bar{N}_a\,\bar{w}_a\,s_{t,a},
$$
where $\bar{N}_a$ is mean estimated numbers at age across 1982--2024,
$\bar{w}_a$ is mean BTS weight at age, and only BTS selectivity $s_{t,a}$
varies. This is an availability index rather than an estimated stock biomass
trajectory.
```{r}
#| label: fig-bts-selectivity-only-biomass
#| fig-cap: "Relative BTS-vulnerable biomass attributable only to fitted annual BTS selectivity. Mean estimated numbers at ages 1–15 across 1982–2024 and mean BTS weight at age are held fixed. Values are divided by the 1982–2024 mean; the dashed horizontal line marks that mean."
#| fig-alt: "Line plot from 1982 through 2024 showing the BTS vulnerable-biomass variation attributable to fitted annual selectivity when mean estimated numbers and mean weight at age are held fixed."
#| fig-width: 10
#| fig-height: 5.5
bts_mean_weight_at_age <- colMeans(data$wt_bts, na.rm = TRUE)
bts_selectivity_years <- data$styr_bts:data$endyr
bts_numbers_years <- data$styr_bts:data$endyr
bts_numbers_rows <- match(bts_numbers_years, years)
bts_mean_numbers_at_age <- colMeans(
as.matrix(rtmb_report$N[bts_numbers_rows, , drop = FALSE]),
na.rm = TRUE
)
stopifnot(
!anyNA(bts_numbers_rows),
nrow(rtmb_report$N) == length(years),
ncol(rtmb_report$N) == length(ages),
ncol(rtmb_report$sel_bts) == length(ages),
nrow(rtmb_report$sel_bts) == length(bts_selectivity_years),
length(bts_mean_weight_at_age) == length(ages),
length(bts_mean_numbers_at_age) == length(ages)
)
bts_availability <- tibble(
year = bts_selectivity_years,
vulnerable_biomass = as.numeric(
as.matrix(rtmb_report$sel_bts) %*%
(bts_mean_numbers_at_age * bts_mean_weight_at_age)
)
) |>
mutate(relative_biomass = vulnerable_biomass / mean(vulnerable_biomass))
bts_availability_min <- min(bts_availability$relative_biomass)
bts_availability_max <- max(bts_availability$relative_biomass)
ggplot(bts_availability, aes(x = year, y = relative_biomass)) +
geom_hline(yintercept = 1, linetype = "dashed", color = "#555555") +
geom_line(color = "#1f5673", linewidth = 0.8) +
geom_point(color = "#1f5673", size = 1.5) +
scale_x_continuous(breaks = seq(1985, 2025, by = 5)) +
scale_y_continuous(labels = scales::label_percent(accuracy = 1)) +
labs(
x = "BTS selectivity year",
y = "Relative vulnerable biomass (period mean = 100%)"
) +
ggthemes::theme_few()
```
With numbers and weights fixed, the selectivity-only index ranges from
`r scales::percent(bts_availability_min, accuracy = 0.1)` to
`r scales::percent(bts_availability_max, accuracy = 0.1)` of its period mean.
Thus, fitted BTS selectivity alone produces deviations of approximately
`r scales::percent(bts_availability_min - 1, accuracy = 0.1)` to
`r scales::percent(bts_availability_max - 1, accuracy = 0.1)` around mean
vulnerable biomass. This range describes changes in modeled survey
availability caused by selectivity and should not be interpreted as population
biomass change.
An analogous weight-only calculation holds mean estimated numbers at age and
BTS selectivity fixed. Selectivity is averaged at each age over 1982--2024,
while the observed BTS weight-at-age vector varies among the 42 survey years.
There is no BTS weight observation for 2020, so the plotted series moves
directly from 2019 to 2021.
```{r}
#| label: fig-bts-weight-only-biomass
#| fig-cap: "Relative BTS-vulnerable biomass attributable only to annual BTS weight at age. Mean estimated numbers at ages 1–15 across 1982–2024 and mean 1982–2024 BTS selectivity at age are held fixed. Values are divided by the mean across the 42 BTS observation years; the dashed horizontal line marks that mean."
#| fig-alt: "Line plot over the 42 BTS observation years from 1982 through 2024 showing the vulnerable-biomass variation attributable to annual weight at age when mean estimated numbers and mean selectivity at age are held fixed; 2020 has no observation."
#| fig-width: 10
#| fig-height: 5.5
bts_mean_selectivity_at_age <- colMeans(
as.matrix(rtmb_report$sel_bts), na.rm = TRUE
)
stopifnot(
nrow(data$wt_bts) == length(data$yrs_bts_data),
ncol(data$wt_bts) == length(ages),
length(bts_mean_selectivity_at_age) == length(ages)
)
bts_weight_availability <- tibble(
year = data$yrs_bts_data,
vulnerable_biomass = as.numeric(
as.matrix(data$wt_bts) %*%
(bts_mean_numbers_at_age * bts_mean_selectivity_at_age)
)
) |>
mutate(relative_biomass = vulnerable_biomass / mean(vulnerable_biomass))
bts_weight_availability_min <- min(bts_weight_availability$relative_biomass)
bts_weight_availability_max <- max(bts_weight_availability$relative_biomass)
ggplot(bts_weight_availability, aes(x = year, y = relative_biomass)) +
geom_hline(yintercept = 1, linetype = "dashed", color = "#555555") +
geom_line(color = "#8c510a", linewidth = 0.8) +
geom_point(color = "#8c510a", size = 1.5) +
scale_x_continuous(breaks = seq(1985, 2025, by = 5)) +
scale_y_continuous(labels = scales::label_percent(accuracy = 1)) +
labs(
x = "BTS observation year",
y = "Relative vulnerable biomass (period mean = 100%)"
) +
ggthemes::theme_few()
```
With mean estimated numbers at age and mean selectivity fixed, annual BTS
weights alone produce a relative vulnerable-biomass range of
`r scales::percent(bts_weight_availability_min, accuracy = 0.1)` to
`r scales::percent(bts_weight_availability_max, accuracy = 0.1)`, equivalent
to deviations of
`r scales::percent(bts_weight_availability_min - 1, accuracy = 0.1)` to
`r scales::percent(bts_weight_availability_max - 1, accuracy = 0.1)` around
the mean.
The third calculation holds both BTS selectivity and BTS weight at age at
their period means and varies only the model-estimated numbers at ages 1--15.
It therefore describes how the estimated population age structure and scale
would change BTS-vulnerable biomass under a constant observation process.
```{r}
#| label: fig-bts-numbers-only-biomass
#| fig-cap: "Relative BTS-vulnerable biomass attributable only to annual estimated numbers at ages 1–15. Mean BTS selectivity at age and mean BTS weight at age are held fixed. Values are divided by the 1982–2024 mean; the dashed horizontal line marks that mean."
#| fig-alt: "Line plot from 1982 through 2024 showing a numbers-at-age-only BTS vulnerable-biomass index ranging from about 0.48 to 1.53."
#| fig-width: 10
#| fig-height: 5.5
stopifnot(
nrow(rtmb_report$N[bts_numbers_rows, , drop = FALSE]) ==
length(bts_numbers_years)
)
bts_numbers_availability <- tibble(
year = bts_numbers_years,
vulnerable_biomass = as.numeric(
as.matrix(rtmb_report$N[bts_numbers_rows, , drop = FALSE]) %*%
(bts_mean_selectivity_at_age * bts_mean_weight_at_age)
)
) |>
mutate(relative_biomass = vulnerable_biomass / mean(vulnerable_biomass))
bts_numbers_availability_min <- min(bts_numbers_availability$relative_biomass)
bts_numbers_availability_max <- max(bts_numbers_availability$relative_biomass)
ggplot(bts_numbers_availability, aes(x = year, y = relative_biomass)) +
geom_hline(yintercept = 1, linetype = "dashed", color = "#555555") +
geom_line(color = "#4d7c0f", linewidth = 0.8) +
geom_point(color = "#4d7c0f", size = 1.5) +
scale_x_continuous(breaks = seq(1985, 2025, by = 5)) +
scale_y_continuous(labels = scales::label_percent(accuracy = 1)) +
labs(
x = "Model year",
y = "Relative vulnerable biomass (period mean = 100%)"
) +
ggthemes::theme_few()
```
With mean selectivity and mean weight fixed, estimated numbers at age alone
produce a relative vulnerable-biomass range of
`r scales::percent(bts_numbers_availability_min, accuracy = 0.1)` to
`r scales::percent(bts_numbers_availability_max, accuracy = 0.1)`, equivalent
to deviations of
`r scales::percent(bts_numbers_availability_min - 1, accuracy = 0.1)` to
`r scales::percent(bts_numbers_availability_max - 1, accuracy = 0.1)` around
the mean. Unlike the first two controlled calculations, this third series
reflects estimated population change rather than observation-process
variation.
The combined comparison in @fig-bts-biomass-components-overlay places the
three controlled series from @fig-bts-selectivity-only-biomass,
@fig-bts-weight-only-biomass, and @fig-bts-numbers-only-biomass on the same
scale as the observed BTS biomass index. Each series is divided by its own
period mean, so 100% represents the mean for that series rather than a common
biomass level. The BTS observation series retains the 2020 survey gap.
```{r}
#| label: fig-bts-biomass-components-overlay
#| fig-cap: "Relative BTS-vulnerable-biomass components and observed BTS biomass index. The selectivity-only, weight-only, numbers-at-age-only, and observed survey series are each normalized to their own 1982–2024 mean. The dashed horizontal line marks 100%; the observed BTS series has no 2020 value."
#| fig-alt: "Overlaid time-series plot from 1982 through 2024 comparing normalized BTS vulnerable biomass attributable separately to annual selectivity, annual weight at age, and annual numbers at age with the normalized observed BTS biomass index. Each series has a period mean of 100 percent, and the observed survey line has a gap in 2020."
#| fig-width: 11
#| fig-height: 6.5
bts_survey_biomass <- tibble(
year = data$yrs_bts_data,
biomass = as.numeric(data$ob_bts)
) |>
mutate(relative_biomass = biomass / mean(biomass, na.rm = TRUE)) |>
right_join(tibble(year = bts_numbers_years), by = "year") |>
arrange(year)
bts_component_overlay <- bind_rows(
bts_availability |>
transmute(year, series = "Selectivity only", relative_biomass),
bts_weight_availability |>
transmute(year, series = "Weight at age only", relative_biomass),
bts_numbers_availability |>
transmute(year, series = "Numbers at age only", relative_biomass),
bts_survey_biomass |>
transmute(year, series = "Observed BTS biomass", relative_biomass)
) |>
mutate(
series = factor(
series,
levels = c(
"Observed BTS biomass",
"Selectivity only",
"Weight at age only",
"Numbers at age only"
)
),
line_segment = if_else(
series == "Observed BTS biomass" & year > 2020,
"Observed BTS biomass after 2020",
as.character(series)
)
)
ggplot(
bts_component_overlay,
aes(
x = year,
y = relative_biomass,
color = series,
linetype = series,
shape = series,
group = line_segment
)
) +
geom_hline(yintercept = 1, linetype = "dashed", color = "#555555") +
geom_line(linewidth = 0.85, na.rm = TRUE) +
geom_point(size = 1.8, na.rm = TRUE) +
scale_x_continuous(breaks = seq(1985, 2025, by = 5)) +
scale_y_continuous(labels = scales::label_percent(accuracy = 1)) +
scale_color_manual(
values = c(
"Observed BTS biomass" = "#000000",
"Selectivity only" = "#1f5673",
"Weight at age only" = "#8c510a",
"Numbers at age only" = "#4d7c0f"
)
) +
scale_linetype_manual(
values = c(
"Observed BTS biomass" = "solid",
"Selectivity only" = "longdash",
"Weight at age only" = "dotdash",
"Numbers at age only" = "twodash"
)
) +
scale_shape_manual(values = c(16, 17, 15, 18)) +
labs(
x = "Year",
y = "Relative index (period mean = 100%)",
color = NULL,
linetype = NULL,
shape = NULL
) +
ggthemes::theme_few() +
theme(legend.position = "bottom")
```
The pairwise display in @fig-bts-biomass-components-pairs removes the time
axis and compares the four normalized series directly. Diagonal panels show
each marginal distribution, lower panels show paired annual values, and upper
panels report Pearson correlations based on the years available for each
pair. These correlations describe shared temporal variation among the
normalized indices; they do not identify causal contributions to observed
survey biomass.
```{r}
#| label: fig-bts-biomass-components-pairs
#| fig-cap: "Pairwise relationships among observed BTS biomass and the selectivity-only, weight-at-age-only, and numbers-at-age-only relative indices shown in Figure @fig-bts-biomass-components-overlay. Values are percentages of each series' 1982–2024 mean. Upper panels report Pearson correlations using available paired years."
#| fig-alt: "Pairs-plot matrix for four normalized annual series: observed BTS biomass, selectivity-only vulnerable biomass, weight-at-age-only vulnerable biomass, and numbers-at-age-only vulnerable biomass. Diagonal panels show distributions, lower panels show paired annual points, and upper panels give Pearson correlations."
#| fig-width: 11
#| fig-height: 10
bts_component_pairs <- bts_component_overlay |>
select(year, series, relative_biomass) |>
mutate(
series = recode(
as.character(series),
"Observed BTS biomass" = "BTS biomass",
"Selectivity only" = "Selectivity",
"Weight at age only" = "Weight at age",
"Numbers at age only" = "Numbers at age"
),
relative_biomass = 100 * relative_biomass
) |>
tidyr::pivot_wider(names_from = series, values_from = relative_biomass) |>
select(`BTS biomass`, Selectivity, `Weight at age`, `Numbers at age`)
GGally::ggpairs(
bts_component_pairs,
upper = list(
continuous = GGally::wrap("cor", method = "pearson", size = 4)
),
lower = list(
continuous = GGally::wrap("points", alpha = 0.7, size = 1.5)
),
diag = list(
continuous = GGally::wrap("densityDiag", alpha = 0.45)
),
progress = FALSE
) +
ggthemes::theme_few() +
theme(
strip.text = element_text(size = 10),
axis.text = element_text(size = 8)
)
```
```{r}
#| label: tbl-model-status
#| tbl-cap: "Summary diagnostics for the current RTMB-ADMB base model."
model_status_tbl <- tibble(
metric = c(
"RTMB output",
"Report elements",
"Parameters in taped object",
"Initial objective",
"Saved total likelihood",
"ADMB bridge report",
"ADMB bridge parameters",
"Interpretation"
),
value = c(
params$model_file,
as.character(length(names(rtmb_report))),
as.character(length(obj$par)),
sprintf("%.3f", obj$fn(obj$par)),
sprintf("%.3f", as.numeric(rtmb_report$tot_like)),
display_path(rtmb_metadata$admb_rep),
display_path(rtmb_metadata$admb_par),
"Saved report loads and the RTMB objective tapes successfully; full convergence diagnostics require a fitted optimizer object."
)
)
model_status_tbl |>
gt_report() |>
tab_header(title = "Model Status Diagnostics")
```
```{r}
#| label: tbl-diagnostics
#| tbl-cap: "RTMB-ADMB likelihood diagnostics by component."
nll_tbl <- tibble(
component = c(
"Catch",
"BTS index",
"ATS index",
"ATS age-1 index",
"CPUE",
"AVO",
"Fishery age composition",
"BTS age composition",
"ATS age composition",
"Recruitment",
"Fishing mortality penalty",
"Selectivity penalty",
"Weight-at-age",
"Priors",
"Total"
),
value = c(
rtmb_report$cat_like,
rtmb_report$bts_like,
rtmb_report$ats_like,
rtmb_report$ats_age1_like,
rtmb_report$cpue_like,
rtmb_report$avo_like,
rtmb_report$age_like[1],
rtmb_report$age_like[2],
rtmb_report$age_like[3],
sum(rtmb_report$rec_like, na.rm = TRUE),
rtmb_report$Fpen_like,
sum(rtmb_report$sel_like, na.rm = TRUE) + sum(rtmb_report$sel_like_dev, na.rm = TRUE),
rtmb_report$wt_like,
sum(rtmb_report$Priors, na.rm = TRUE),
rtmb_report$tot_like
)
)
nll_tbl |>
gt_report() |>
fmt_number(columns = value, decimals = 3) |>
tab_header(title = "Likelihood Diagnostics by Component")
```
## A-3 SparseNUTS MCMC {.unnumbered}
This analysis applies `SparseNUTS` to the **hierarchical Form-2 double-logistic
candidate model** (`fishery_sel_form = 2`). The Form-2
model declares annual selectivity deviations as random effects, which permits
SparseNUTS to construct the sparse precision metric. The sampler uses
`metric = "sparse"` and
`adapt_delta = 0.95`; chains, cores, sampling iterations, warmup, and
initialization remain at the package defaults. The model name and
`globals = list(data = model_data)` are also supplied. Exporting that RTMB data
object allows the chains to run concurrently. These results characterize
posterior sampling behavior for the candidate Form-2 model and do not replace
the accepted assessment configuration.
```{r}
#| label: sparsenuts-default-run
#| include: false
sparsenuts_available <- requireNamespace("SparseNUTS", quietly = TRUE)
sparsenuts_fit <- NULL
sparsenuts_error <- NULL
if (param_is_true(params$run_sparsenuts) &&
(param_is_true(params$force_sparsenuts) || !file.exists(sparsenuts_file))) {
if (!sparsenuts_available) {
sparsenuts_error <- "SparseNUTS is not installed."
} else {
run_status <- system2(
file.path(R.home("bin"), "Rscript"),
rtmb_file("R", "run_sparsenuts_fishery_sel_forms.R")
)
if (!identical(run_status, 0L)) {
sparsenuts_error <- paste("SparseNUTS runner exited with status", run_status)
}
}
}
if (file.exists(sparsenuts_file)) {
sparsenuts_fit <- readRDS(sparsenuts_file)
}
sparsenuts_diagnostics <- NULL
if (!is.null(sparsenuts_fit) && sparsenuts_available) {
sparsenuts_diagnostics <- tryCatch(
SparseNUTS::check_snuts_diagnostics(sparsenuts_fit, print = FALSE),
error = function(e) {
sparsenuts_error <<- conditionMessage(e)
NULL
}
)
}
```
```{r}
#| label: tbl-sparsenuts-status
#| tbl-cap: "SparseNUTS sparse-metric run status for the hierarchical Form-2 RTMB model."
sample_dims <- if (!is.null(sparsenuts_fit$samples)) dim(sparsenuts_fit$samples) else NULL
draws_per_chain <- if (!is.null(sample_dims) && length(sample_dims) >= 2) sample_dims[1] else NA_integer_
chains <- if (!is.null(sample_dims) && length(sample_dims) >= 2) sample_dims[2] else NA_integer_
warmup <- sparsenuts_fit$warmup %||% NA_integer_
post_warmup <- if (is.finite(draws_per_chain) && is.finite(warmup)) draws_per_chain - warmup else NA_integer_
sparsenuts_run_metadata <- attr(sparsenuts_fit, "rtmb_ebswp_sparsenuts") %||% list()
sparsenuts_status <- tibble(
metric = c(
"Model configuration",
"SparseNUTS installed",
"SparseNUTS version",
"SparseNUTS GitHub commit",
"Default call",
"Saved default output",
"Output path",
"Algorithm",
"Metric",
"Target acceptance probability",
"Chains",
"Parallel cores",
"Execution mode",
"Warmup iterations per chain",
"Post-warmup samples per chain",
"Elapsed time (minutes)",
"Diagnostic object available",
"Error"
),
value = c(
sparsenuts_run_metadata$model %||% "hierarchical Form-2 RTMB model",
as.character(sparsenuts_available),
sparsenuts_run_metadata$package_version %||% if (sparsenuts_available) as.character(packageVersion("SparseNUTS")) else NA_character_,
sparsenuts_run_metadata$package_remote_sha %||% NA_character_,
"SparseNUTS::sample_snuts(obj, metric = 'sparse', control = list(adapt_delta = 0.95), globals = list(data = model_data))",
as.character(file.exists(sparsenuts_file)),
display_path(sparsenuts_file),
as.character(sparsenuts_fit$algorithm %||% NA_character_),
as.character(sparsenuts_fit$metric %||% NA_character_),
as.character(sparsenuts_run_metadata$adapt_delta %||% 0.95),
as.character(chains),
as.character(chains),
sparsenuts_run_metadata$execution %||% "package-default parallel chains",
as.character(warmup),
as.character(post_warmup),
if (is.null(sparsenuts_run_metadata$elapsed_seconds)) NA_character_ else sprintf("%.1f", sparsenuts_run_metadata$elapsed_seconds / 60),
as.character(!is.null(sparsenuts_diagnostics)),
sparsenuts_error %||% ""
)
)
sparsenuts_status |>
gt_report() |>
tab_header(title = "SparseNUTS Hierarchical Form-2 Run Status")
```
```{r}
#| label: tbl-sparsenuts-diagnostics
#| tbl-cap: "Diagnostics for the SparseNUTS sparse-metric run of the base RTMB model with adapt_delta = 0.95. R-hat values near 1 and larger effective sample sizes indicate good between-chain mixing. Divergences identify inadequate exploration of posterior geometry and require resolution before final inference."
if (!is.null(sparsenuts_fit) && !is.null(sparsenuts_fit$monitor)) {
diag_values <- sparsenuts_diagnostics %||% data.frame(
perc_divergent = NA_real_, perc_treedepth = NA_real_,
num_below_threshold = NA_real_
)
post_warmup_total <- chains * post_warmup
divergence_percent <- diag_values$perc_divergent[1] %||% NA_real_
warmup_divergences <- sum(vapply(
sparsenuts_fit$sampler_params,
function(x) sum(x[seq_len(warmup), "divergent__"]),
numeric(1)
))
sampling_divergences <- round(post_warmup_total * divergence_percent / 100)
diag_tbl <- tibble(
diagnostic = c(
"Post-warmup draws", "Warmup divergences", "Post-warmup divergences",
"Post-warmup divergent transitions (%)",
"Maximum R-hat", "Minimum bulk ESS", "Median bulk ESS",
"Minimum tail ESS", "Maximum-treedepth transitions (%)"
),
value = c(
post_warmup_total,
warmup_divergences,
sampling_divergences,
divergence_percent,
max(sparsenuts_fit$monitor$rhat, na.rm = TRUE),
min(sparsenuts_fit$monitor$ess_bulk, na.rm = TRUE),
median(sparsenuts_fit$monitor$ess_bulk, na.rm = TRUE),
min(sparsenuts_fit$monitor$ess_tail, na.rm = TRUE),
diag_values$perc_treedepth[1] %||% NA_real_
)
)
} else {
diag_tbl <- tibble(
diagnostic = "status",
value = "No SparseNUTS diagnostics are available. Render with run_sparsenuts: true to create the default run."
)
}
diag_tbl |>
gt_report() |>
fmt_number(columns = value, decimals = 3) |>
tab_header(title = "SparseNUTS Hierarchical Form-2 Diagnostics")
```
With `metric = "sparse"` and `adapt_delta = 0.95`, the run produced
`r warmup_divergences` divergences during adaptation and **`r sampling_divergences`
divergences among the `r format(post_warmup_total, big.mark = ",")` retained
transitions**. Maximum R-hat was
`r sprintf("%.3f", max(sparsenuts_fit$monitor$rhat, na.rm = TRUE))`, and minimum
bulk effective sample size was
`r format(round(min(sparsenuts_fit$monitor$ess_bulk, na.rm = TRUE)), big.mark = ",")`.
`r if (sampling_divergences == 0) "The retained draws pass the reported divergence and chain-mixing checks." else paste0("The chain-mixing statistics are good, but ", sampling_divergences, " retained divergence", if (sampling_divergences == 1) " remains" else "s remain", "; its location should be checked before treating the posterior as final.")`
Substantive posterior checks and comparison with deterministic uncertainty
remain appropriate before using the draws in assessment decisions.
```{r}
#| label: sparsenuts-plot-data
#| include: false
sparsenuts_fig_dir <- rtmb_file("analysis", "output", "figures")
dir.create(sparsenuts_fig_dir, showWarnings = FALSE, recursive = TRUE)
slow_parameter_names <- character()
slow_parameter_indices <- integer()
if (!is.null(sparsenuts_fit) && !is.null(sparsenuts_fit$monitor)) {
slow_parameter_names <- sparsenuts_fit$monitor |>
arrange(desc(rhat), ess_bulk) |>
filter(is.finite(rhat)) |>
slice_head(n = 12) |>
pull(variable)
available_parameter_names <- dimnames(sparsenuts_fit$samples)[[3]]
slow_parameter_indices <- match(slow_parameter_names, available_parameter_names)
slow_parameter_indices <- slow_parameter_indices[is.finite(slow_parameter_indices)]
}
make_sparsenuts_pairs_plot <- function(fit, pars, file) {
if (length(pars) == 0 || is.null(fit$samples)) return(FALSE)
pars <- pars[seq_len(min(length(pars), 6))]
png(file, width = 1800, height = 1800, res = 180)
on.exit(dev.off(), add = TRUE)
pairs(
fit,
pars = pars,
order = "slow",
diag = "hist",
plot = TRUE
)
TRUE
}
sparsenuts_figures <- list(
pairs_slow = file.path(sparsenuts_fig_dir, "rtmb_ebswp_sparsenuts_pairs_slow.png"),
marginals_slow = file.path(sparsenuts_fig_dir, "rtmb_ebswp_sparsenuts_marginals_slow.png"),
sampler = file.path(sparsenuts_fig_dir, "rtmb_ebswp_sparsenuts_sampler_params.png"),
q = file.path(sparsenuts_fig_dir, "rtmb_ebswp_sparsenuts_Q.png"),
uncertainties = file.path(sparsenuts_fig_dir, "rtmb_ebswp_sparsenuts_uncertainties.png")
)
if (!is.null(sparsenuts_fit) && sparsenuts_available) {
# Remove any previous-run graphics before recreating the complete set.
unlink(unlist(sparsenuts_figures), force = TRUE)
make_sparsenuts_pairs_plot(sparsenuts_fit, slow_parameter_indices, sparsenuts_figures$pairs_slow)
png(sparsenuts_figures$marginals_slow, width = 1800, height = 1400, res = 180)
try(
SparseNUTS::plot_marginals(
sparsenuts_fit,
pars = slow_parameter_indices,
order = "slow",
mfrow = c(3, 4)
),
silent = TRUE
)
dev.off()
png(sparsenuts_figures$sampler, width = 1600, height = 1200, res = 180)
try(SparseNUTS::plot_sampler_params(sparsenuts_fit, plot = TRUE), silent = TRUE)
dev.off()
png(sparsenuts_figures$q, width = 1600, height = 1200, res = 180)
q_plot <- try(
{
if (!is.null(sparsenuts_fit$mle$Qinv)) {
SparseNUTS::plot_Q(sparsenuts_fit, Q = solve(sparsenuts_fit$mle$Qinv))
} else {
SparseNUTS::plot_Q(sparsenuts_fit)
}
},
silent = TRUE
)
if (inherits(q_plot, "try-error")) {
plot.new()
text(0.5, 0.5, paste("plot_Q unavailable:", conditionMessage(attr(q_plot, "condition"))), cex = 0.8)
}
dev.off()
png(sparsenuts_figures$uncertainties, width = 1600, height = 1200, res = 180)
try(SparseNUTS::plot_uncertainties(sparsenuts_fit, plot = TRUE), silent = TRUE)
dev.off()
}
```
```{r}
#| label: tbl-sparsenuts-slow-parameters
#| tbl-cap: "SparseNUTS parameters selected for slow-order MCMC diagnostic plots."
if (length(slow_parameter_names) > 0) {
sparsenuts_fit$monitor |>
filter(variable %in% slow_parameter_names) |>
mutate(variable = factor(variable, levels = slow_parameter_names)) |>
arrange(variable) |>
select(variable, mean, sd, rhat, ess_bulk, ess_tail) |>
gt_report() |>
fmt_number(columns = c(mean, sd, rhat, ess_bulk, ess_tail), decimals = 3) |>
tab_header(title = "Slow-Order Diagnostic Parameters")
} else {
tibble(note = "No SparseNUTS parameter diagnostics available.") |>
gt_report() |>
tab_header(title = "Slow-Order Diagnostic Parameters")
}
```
```{r}
#| label: fig-sparsenuts-pairs-slow
#| fig-cap: "SparseNUTS package pairs plot for the six slowest RTMB-ADMB parameters by Rhat/ESS ranking, generated through the package S3 method `pairs.tmbfit` via `pairs(sparsenuts_fit, order = 'slow')`."
#| fig-alt: "Matrix of pairwise scatterplots and marginal distributions for the six slowest-mixing SparseNUTS parameters, showing posterior associations and chain overlap."
if (file.exists(sparsenuts_figures$pairs_slow)) {
knitr::include_graphics(sparsenuts_figures$pairs_slow)
}
```
```{r}
#| label: fig-sparsenuts-marginals-slow
#| fig-cap: "SparseNUTS::plot_marginals output from the default RTMB-ADMB SparseNUTS run using `order = 'slow'` for the selected parameter set."
#| fig-alt: "Posterior marginal-density and chain display for the slowest-mixing SparseNUTS parameters."
if (file.exists(sparsenuts_figures$marginals_slow)) {
knitr::include_graphics(sparsenuts_figures$marginals_slow)
}
```
```{r}
#| label: fig-sparsenuts-sampler
#| fig-cap: "SparseNUTS sampler-parameter diagnostics from the default RTMB-ADMB run."
#| fig-alt: "SparseNUTS sampler diagnostic panels summarizing chain behavior and Hamiltonian Monte Carlo tuning quantities."
if (file.exists(sparsenuts_figures$sampler)) {
knitr::include_graphics(sparsenuts_figures$sampler)
}
```
```{r}
#| label: fig-sparsenuts-q
#| fig-cap: "SparseNUTS::plot_Q output from the default RTMB-ADMB run."
#| fig-alt: "Graphical display of the SparseNUTS sparse precision matrix, with colored cells indicating the magnitude and pattern of parameter dependence."
if (file.exists(sparsenuts_figures$q)) {
knitr::include_graphics(sparsenuts_figures$q)
}
```
```{r}
#| label: fig-sparsenuts-uncertainties
#| fig-cap: "SparseNUTS::plot_uncertainties output from the default RTMB-ADMB run."
#| fig-alt: "SparseNUTS uncertainty summary showing posterior estimates and intervals for monitored model quantities."
if (file.exists(sparsenuts_figures$uncertainties)) {
knitr::include_graphics(sparsenuts_figures$uncertainties)
}
```
## A-4 Data and output {.unnumbered}
### Downloadable CSV files {.unnumbered}
The following reader-facing files provide machine-readable versions of key
inputs, diagnostics, and results used in this report:
- [Model-level summary](data-output/model_glance.csv)
- [Tidy model parameters](data-output/model_parameters.csv)
- [Tidy model observations and predictions](data-output/model_observations.csv)
- [BTS age-data bridge comparison](data-output/bts_age_data_bridge_comparison.csv)
- [BTS age-data bridge diagnostics](data-output/bts_age_data_bridge_diagnostics.csv)
- [BTS age-data bridge time series](data-output/bts_age_data_bridge_timeseries.csv)
- [tinyVAST retrospective diagnostics](data-output/tinyvast_retro_diagnostics.csv)
- [tinyVAST retrospective Mohn's rho](data-output/tinyvast_retro_mohn.csv)
- [Corrected-run downstream lineage](data-output/downstream_lineage.csv)
- [Fishery-selectivity model summary](data-output/fishery_selectivity_summary.csv)
- [One-step-ahead residual summary](data-output/osa_summary.csv)
- [Retrospective data-availability audit](data-output/retrospective_data_availability.csv)
- [SPM projection summary](data-output/spmr_projection_summary.csv)
- [Tier-3 seven-scenario projection table](data-output/tier3_seven_scenario_table.csv)
- [Length-frequency summary counts](data-output/lf_length_frequency_summary.csv)
### Input schedules {.unnumbered}
```{r}
#| label: tbl-weight-at-age
#| tbl-cap: "Input spawning weight-at-age values used in the terminal model year."
waa_tbl <- tibble(
year = terminal_year,
age = ages,
weight = as.numeric(data$wt_ssb[nrow(data$wt_ssb), ])
)
waa_tbl |>
gt_report() |>
fmt_number(columns = weight, decimals = 5) |>
tab_header(title = "Terminal-Year Spawning Weight at Age")
```
```{r}
#| label: tbl-maturity
#| tbl-cap: "Input maturity-at-age schedule used in the RTMB-ADMB model."
maturity_tbl <- tibble(
age = ages,
maturity = as.numeric(data$p_mature)
)
maturity_tbl |>
gt_report() |>
fmt_number(columns = maturity, decimals = 5) |>
tab_header(title = "Maturity at Age")
```
### Report-object inventory {.unnumbered}
```{r}
#| label: tbl-report-inventory
#| tbl-cap: "Inventory of named elements in the saved RTMB report object."
report_inventory <- tibble(
element = names(rtmb_report),
class = vapply(rtmb_report, function(x) paste(class(x), collapse = "/"), character(1)),
length = vapply(rtmb_report, length, integer(1)),
dimensions = vapply(rtmb_report, function(x) {
d <- dim(x)
if (is.null(d)) "" else paste(d, collapse = " x ")
}, character(1))
)
report_inventory |>
gt_report() |>
tab_header(title = "Saved RTMB Report Inventory")
```
## A-5 Length-frequency patterns {.unnumbered #sec-length-frequency-patterns}
This appendix summarizes exploratory seasonal and spatial patterns in observed
pollock length-frequency samples. It is intended to identify patterns that may
warrant further investigation rather than to test an assessment-model
configuration. The source analysis includes pollock observations from 1991
onward, excludes observations below 20 cm, and accumulates fish 65 cm and
longer in a 65-cm-plus group. Length frequencies are normalized within each
displayed year and grouping. A season includes samples collected before June;
B season data are from June onward. Earlier years appear at the top of each
figure.
### Change from 2025 to 2026 {.unnumbered}
The observed length distribution shifted toward smaller fish from 2025 to
2026. Across seasons, mean sampled length declined from 46.17 to 44.81 cm,
while the median remained 46 cm. The percentage longer than 46 cm decreased
from 46.40% to 43.96%, and the percentage at or below 35 cm increased from
4.03% to 9.86%.
The shift occurred primarily in the B-season samples. B-season mean length
declined from 45.93 cm in 2025 to 42.55 cm in 2026, and the median declined
from 46 to 43 cm. The proportion longer than 46 cm decreased from 48.90% to
34.76%, while the proportion at or below 35 cm increased from 6.79% to 17.54%.
Both B-season area groups shifted toward smaller fish. In the western group
(`NMFS_AREA > 519`), mean length declined from 44.26 to 39.39 cm and the
percentage at or below 35 cm increased from 9.86% to 29.24%. In the eastern
group (`NMFS_AREA < 520`), mean length declined from 48.55 to 45.62 cm and the
percentage longer than 46 cm decreased from 70.13% to 49.88%.
The A-season change was smaller and differed in shape. Mean length declined
from 46.39 to 45.82 cm and the median remained 46 cm, while the percentages
longer than 46 cm and at or below 35 cm both increased. This indicates greater
representation in the tails of the sampled A-season distribution in 2026.
Sample coverage also changed: the A-season count increased from 91,912 to
101,038 observations, whereas the B-season count decreased from 80,749 to
45,057. These are unstandardized sample distributions, so the differences
describe the available observations and may reflect changes in sampling as
well as changes in the fish encountered by the fishery.
### A- and B-season distributions {.unnumbered}
{#fig-appendix-lf-seasons fig-alt="Two-panel ridge plot of annual pollock length-frequency proportions from 1991 onward. A-season distributions appear in the left panel and B-season distributions in the right. Each row represents one year; a dashed vertical line marks 46 cm and a blue pie wedge gives the percentage longer than 46 cm."}
### Combined-season distributions {.unnumbered}
{#fig-appendix-lf-combined fig-alt="Ridge plot of annual pollock length-frequency proportions across A and B seasons from 1991 onward. Each row represents one year; a dashed vertical line marks 46 cm and a blue pie wedge gives the percentage longer than 46 cm."}
### B-season distributions by NMFS area {.unnumbered}
{#fig-appendix-lf-b-season-area fig-alt="Two-panel ridge plot of annual B-season pollock length-frequency proportions from 1991 onward, divided into areas west and east of 170 degrees W. Each row represents one year; a dashed vertical line marks 46 cm and a blue pie wedge gives the percentage longer than 46 cm."}
## A-6 Sex-ratio patterns {.unnumbered #sec-sex-ratio-patterns}
This shortened BSAI-focused appendix summarizes exploratory patterns from
fishery age samples and Bering Sea summer acoustic-survey samples. The source
analysis covers 1986--2025, with catcher/processor A-season weekly summaries
updated through 2026. Sex ratio is the proportion female among samples with a
recorded female or male sex. Point sizes indicate sample size where shown.
These unadjusted summaries identify seasonal, size-related, and interannual
structure; they do not constitute a formal assessment-model test.
### Pooled fishery patterns by age and length {.unnumbered}
{#fig-appendix-sex-ratio-overall-bsai fig-alt="Two-panel BSAI fishery summary of the proportion female. The upper panel shows sex ratio by age and the lower panel shows sex ratio by 5-cm length group; boxplots summarize variation among grouped observations and a horizontal reference line marks equal female and male proportions."}
### A-season progression {.unnumbered}
{#fig-appendix-sex-ratio-week-a-bsai fig-alt="Line and point plot of pooled BSAI catcher-processor A-season proportion female for ISO weeks 4 through 14 during 2008 through 2026. Point size represents the number of sampled fish and a horizontal dashed line marks 50 percent female."}
### Length patterns by age and season {.unnumbered}
{#fig-appendix-sex-ratio-length-age-bsai fig-alt="Faceted BSAI fishery plots of proportion female against fish length for ages younger than 11. Separate colored series compare A and B seasons, point size represents sample size, smooth curves summarize each seasonal pattern, and dashed horizontal lines mark 50 percent female."}
The seasonal patterns vary with age and length. In particular, the unadjusted
age-4 panels suggest that A-season samples contain slightly larger fish than
B-season samples. The source analysis treats this as an exploratory visual
pattern; its adjusted growth model reverses that simple interpretation and
estimates a positive B-versus-A age-4 length contrast in the BSAI.
### Bering Sea summer acoustic survey {.unnumbered}
{#fig-appendix-acoustic-sex-ratio-overall-bsai fig-alt="Two-panel Bering Sea summer acoustic-survey summary of proportion female. The upper panel shows sex ratio by age and the lower panel shows sex ratio by 5-cm length group; boxplots summarize variation among grouped observations and a horizontal reference line marks equal female and male proportions."}
## A-7 Notes {.unnumbered}
Operational consideration of the RTMB model requires satisfactory convergence,
estimability, retrospective, sensitivity, and simulation results, followed by
the established review process. The results presented here address several of
these elements but do not constitute a recommendation to replace the accepted
assessment model.