# ==============================================================================
# ROBUST AND AUDITABLE FOREST-GROWTH MODELING PIPELINE
# Title: Dual-scope short-interval diameter models and conditional 5-90-year
#        sensitivity scenarios for Amazonian floodplain trees
# Frozen publication specification: FEM-10.3.1
#
# Reproducible execution: place this script and varzea_tree_diameter_growth.xlsx
# in the same directory and source the script in RStudio. The input workbook is
# never overwritten. The root output contains publication audit tables, logs,
# taxonomic reconciliation, and cross-scope summaries. Complete analytical
# outputs are stored separately under Community/ and
# Commercially_listed_species_group/.
#
# Publication release requires a complete and reconciled Data_curation_audit
# worksheet. Incomplete provenance does not prevent analytical execution, but
# the publication/freezing status remains blocked until the frozen curation
# requirements pass. Verification metadata must be based on documentary
# evidence.
#
# Primary estimand: short-interval out-of-sample prediction of final DBH (cm),
# equivalently diameter increment because initial DBH is shared by observation
# and prediction. Leave-one-plot-out (LOPO) is the primary internal spatially
# blocked validation; progressive temporal validation is complementary and
# leave-two-plots-out (L2PO) is a spatial stress test.
#
# The workflow is fitted independently to the eligible monitored community and
# the commercially listed species group reconciled against Commercial_registry.
# Protected status overrides permission when registry records conflict.
#
# Conditional survivor-DBH scenarios are exported at 5, 10, 25, 30, 35, 50,
# 70, and 90 years. These are deterministic structural-sensitivity trajectories,
# not empirically validated long-horizon forecasts. They do not represent
# recruitment, mortality, harvest, volume recovery, or cutting-cycle
# recommendations.
#
# Structural candidates fitted to the same analytical observations:
#   1. Richards without baseline plot basal area
#   2. Richards with baseline 2013 plot basal area
#   3. Lundqvist-Korf without baseline plot basal area
#   4. Lundqvist-Korf with baseline 2013 plot basal area
#
# OLS is the canonical estimator and the only estimator used for structural
# selection. Direct Huber M-estimation is a pre-specified robust-loss
# sensitivity.
# Feasible GLS and Student-t IRLS remain disabled exploratory options and are
# not
# reported unless their complete convergence criteria are satisfied.
#
# Baseline plot basal area is standardized from unique training plots within
# each
# validation fold. It is treated as a baseline structural predictor, not as a
# time-varying competition measure or causal effect.
# ==============================================================================

# 1. PACKAGE CHECK -------------------------------------------------------------

kRequiredPackages <- c(
  "readxl", "dplyr", "purrr", "tidyr", "writexl", "DEoptim",
  "ggplot2"
)
kMissingPackages <- kRequiredPackages[
  !vapply(kRequiredPackages, requireNamespace, logical(1), quietly = TRUE)
]
if (length(kMissingPackages) > 0L) {
  stop(
    "Missing required R packages: ", paste(kMissingPackages, collapse = ", "),
    ". Install them once with install.packages(c(",
    paste(sprintf('"%s"', kMissingPackages), collapse = ", "),
    ")) and run Source again."
  )
}

suppressPackageStartupMessages({
  library(readxl)
  library(dplyr)
  library(purrr)
  library(tidyr)
  library(writexl)
  library(DEoptim)
  library(ggplot2)
})

# 2. FIXED ANALYTICAL SPECIFICATION ------------------------------------------

kModelSpecVersion <- "2026-08-15-FEM-10.3.1-documented-curation-evidence-rstudio"
kDefaultDataFile <- "varzea_tree_diameter_growth.xlsx"
kDataSheet <- "Tree_growth_intervals"
kCommercialSpeciesSheet <- "Commercial_registry"
kCurationAuditSheet <- "Data_curation_audit"
kRequireDocumentedCurationAudit <- TRUE
kBlockModelFittingWhenCurationIncomplete <- FALSE
kDefaultOutputDirectory <- "Robust_Modeling_Results_FEM_Publication_v10_3_1"
kTargetClass <- "0"
kModelingPeriods <- c(
  "2013-2016", "2016-2017", "2017-2018", "2018-2021", "2021-2022"
)
kExcludedPlaceholderPeriods <- "2022-2023"
kTargetPlots <- 6:11
kMinimumIncrementCm <- 0
kHighAnnualIncrementAuditThreshold <- 5
kTemporalMinimumTrainingPeriods <- 1L

# Taxonomic scope is switched internally while the two predeclared analyses are
# run. These are runtime state variables, not user-editable alternatives.
# Commercial membership is stored in the growth table and must reconcile
# exactly with the embedded registry after documented binomial normalization.
kAnalysisScopeMode <- "eligible_community"
kTargetSpecies <- character(0)
kPlannedAnalysisScopes <- c("community", "commercial_group")
kProtectedStatusOverridesPermission <- TRUE
kMinimumSpeciesIntervalsForDiagnostics <- 30L
kMinimumSpeciesTreesForDiagnostics <- 10L
kMinimumSpeciesPlotsForDiagnostics <- 3L

# OLS is the canonical estimator for blocked prediction and plot-cluster
# resampling. Feasible GLS and Student-t IRLS remain disabled exploratory
# options; any re-enabled fit must satisfy the complete IRLS convergence rule.
kRunExploratoryErrorSensitivities <- FALSE

# Direct Huber M-estimation is a sensitivity analysis, not a replacement for
# the canonical OLS estimand or its structural-selection rules. Its scale is
# fixed from accepted OLS training residuals and the bounded Huber objective is
# optimized directly.
kRunHuberSensitivity <- TRUE
kHuberTuningConstant <- 1.345
kHuberMinimumScaleCm <- 1e-6

# Every observation remains in the analysis. These thresholds only quantify
# the influence of large out-of-sample residuals; they never trigger deletion.
kExtremeResidualThresholdsCm <- c(2, 5, 10)
kExtremeResidualRowsExportThresholdCm <- 5

# A 0.05-cm LOPO RMSE difference is the pre-specified threshold for practical
# separation of the Richards and Lundqvist families. Below it, both families
# are retained to represent structural uncertainty.
kMinimumPracticalFamilyRmseDifferenceCm <- 0.05

# Conditional horizon scenarios. Five and ten years are short extrapolation
# checkpoints; 25-35 years are management-cycle checkpoints; 50-90 years are
# explicitly long-term structural-sensitivity checkpoints. Fixed asymptotes are
# assumptions, not parameters identified by this short monitoring record.
kEnableConditionalManagementScenarios <- TRUE
kManagementHorizonYears <- c(5L, 10L, 25L, 30L, 35L, 50L, 70L, 90L)
kManagementTrajectoryYears <- 0:90
kManagementScenarioAsymptotesCm <- c(223, 250, 300, 400, 600, 1000, 2000, 5000)
kManagementScenarioInitialDbhCm <- c(10, 20, 30, 40, 50, 60, 80, 100, 150, 200)
kLargeDiameterThresholdsCm <- c(50, 80, 100, 150, 200)
kProjectionStepInvarianceToleranceCm <- 1e-6
kAsymptoteProfileSupportDeltaThreshold <- 2
kHighAsymptotePlateauThresholdCm <- 1000

# Empirical support for scenario starts is reported by initial-DBH class. The
# labels are descriptive audit categories, not validation of extrapolations.
# The underlying counts are always exported beside the category.
kDiameterSupportBreaksCm <- c(0, 20, 40, 60, 80, 100, 150, 200, Inf)
kDiameterSupportLabels <- c(
  "<20", "20-<40", "40-<60", "60-<80",
  "80-<100", "100-<150", "150-<200", "200+"
)
kBroadDiameterSupportMinimumTrees <- 30L
kBroadDiameterSupportMinimumSpecies <- 5L
kBroadDiameterSupportMinimumPlots <- 5L
kLimitedDiameterSupportMinimumTrees <- 10L
kLimitedDiameterSupportMinimumSpecies <- 3L
kLimitedDiameterSupportMinimumPlots <- 3L
kDbhClassMinimumIntervalsForComparativeDescription <- 30L
kDbhClassMinimumPlotsForComparativeDescription <- 3L

# Exact reconciliation controls for the supplied, audited analytical workbook.
# A changed workbook must trigger an explicit review, not silently reuse the
# previous methodological conclusions.
kExpectedInputRows <- 9031L
kExpectedRowsInModelingPeriods <- 7201L
kExpectedAnalyticalIntervals <- 6487L
kExpectedUniqueTrees <- 1602L
kExpectedZeroIncrements <- 569L
kExpectedHighAnnualIncrements <- 46L
kExpectedMaximumObservedDbhCm <- 222

# Exact registry-to-inventory controls for the embedded Commercial_registry
# sheet. They
# prevent a revised list or a changed taxonomic reconciliation from silently
# redefining the commercially listed species group used in the manuscript.
kExpectedCommercialRegistryRows <- 47L
kExpectedCommercialUniqueTaxa <- 46L
kExpectedCommercialPermittedTaxa <- 36L
kExpectedCommercialProtectedTaxa <- 10L
kExpectedCommercialStatusConflicts <- 1L
kExpectedCommercialMatchedTaxa <- 21L
kExpectedCommercialMatchedPermittedTaxa <- 17L
kExpectedCommercialMatchedProtectedTaxa <- 4L
kExpectedCommercialIntervals <- 1263L
kExpectedCommercialUniqueTrees <- 319L

# The values below were calculated once from the complete 2013 inventories,
# not from the filtered interval dataset: sum(pi * DBH_2013^2 / 40000) by 1-ha
# plot. Their control total is checked before any model is fitted.
kBasalArea2013ByPlot <- data.frame(
  plot_id = 6:11,
  inventory_trees_2013 = c(414L, 422L, 445L, 423L, 451L, 422L),
  basal_area_2013_m2_ha = c(
    27.254016452354122,
    26.872295273484287,
    26.991504577521081,
    28.115333165720980,
    30.926952561931785,
    28.955648724897667
  ),
  stringsAsFactors = FALSE
)
kBasalArea2013ControlTotal <- 169.115750755909914

# The asymptote bound is deliberately broad and common to every structural
# candidate. Fixed-asymptote profiles, rather
# than a point estimate alone, are used to diagnose weak identification.
kAsymptoteUpper <- 2000
kAsymptoteProfile <- kManagementScenarioAsymptotesCm
# Fixed before validation and above every supplied scenario starting diameter.
# This prevents a training-fold asymptote from entering the held-out prediction
# domain. The value is never computed from held-out observations.
kPredictionDomainAsymptoteFloorCm <- 223
kBoundaryRelativeTolerance <- 1e-4
kScaledConditionThreshold <- 1e6

# Parameters are on stable scales. For both families the positive rate is
# exp(log_rate + basal_area_log_rate_effect * basal_area_z). In Lundqvist-Korf,
# this rate is rho = k^(-1/m), avoiding the unstable raw k parameterization.
kLogRateBounds <- c(-14, 2)
kBasalAreaEffectBounds <- c(-4, 4)
kRichardsShapeBounds <- c(0.001, 0.999)
kLundqvistShapeBounds <- c(0.05, 10)

# Global optimization is repeated for the four full-data primary fits. Each CV
# fold uses one deterministic global seed followed by bound-aware local
# refinement. L-BFGS-B is primary and nlminb is the automatic fallback. Formal
# boundary convergence is retained as an explicit diagnostic because the weakly
# identified asymptote can reach its common upper limit. All settings enter the
# reproducibility signature.
kBaseSeed <- 42L
kFullGlobalSeeds <- c(42L, 1042L, 2042L)
kProfileGlobalSeeds <- c(42L, 1042L)
kFullDeIterMax <- 400L
kFullDeNp <- 80L
kCvDeIterMax <- 250L
kCvDeNp <- 60L
kProfileDeIterMax <- 160L
kProfileDeNp <- 50L
kDeF <- 0.8
kDeCr <- 0.9
kLocalOptimMaxIterations <- 3000L
kLocalOptimFactr <- 1e7
kLocalOptimProjectedGradientTolerance <- 1e-7
kLocalOptimRelativeTolerance <- 1e-10

# A boundary optimum may make derivative-based local optimizers report line-
# search, singular-convergence, or false-convergence codes even when they and
# the global DE solution return the same finite objective. Formal convergence
# and solution acceptance are therefore kept as distinct diagnostics. A
# non-converged OLS solution is accepted only when two independent bounded
# local methods are usable and their objectives agree with each other and with
# the DE optimum within this relative tolerance.
kOptimizerObjectiveAgreementTolerance <- 1e-8
kMinimumIndependentUsableLocalMethods <- 2L

kFglsMaxIterations <- 25L
kStudentTMaxIterations <- 50L
kIrlsConvergenceTolerance <- 1e-5
kStudentTDegreesFreedom <- 4

# Basal area is retained as the reporting structure only if LOPO RMSE improves
# by at least 0.05 cm and the BA candidate wins in at least four of six plot
# folds. This conservative rule is retained in the versioned FEM-10
# specification;
# it is an audited decision rule, not a prospective preregistration.
kMinimumPracticalBaGainCm <- 0.05
kMinimumBaWinningPlots <- 4L
kLopoClusterBootstrapReplicates <- 5000L
kLopoClusterBootstrapSeed <- 42042L

kStructuralSpecifications <- data.frame(
  structural_id = c(
    "Richards_noBA", "Richards_BA2013",
    "Lundqvist_noBA", "Lundqvist_BA2013"
  ),
  model_family = c("Richards", "Richards", "Lundqvist", "Lundqvist"),
  uses_basal_area = c(FALSE, TRUE, FALSE, TRUE),
  stringsAsFactors = FALSE
)

kModelColors <- c("Richards" = "#0072B2", "Lundqvist" = "#D55E00")
kEstimatorColors <- c(
  "OLS" = "#0072B2", "Huber" = "#CC79A7", "FGLS" = "#009E73",
  "Student_t" = "#D55E00",
  "Persistence" = "#777777"
)
kEnvelopeColors <- c(
  "OLS" = "#0072B2", "Huber" = "#CC79A7", "Combined" = "#000000"
)
# Elsevier's full-width artwork target is 190 mm; combination artwork requires
# at least 500 dpi and finished lettering should normally be at least 7 pt.
# FEM-10 exports at 600 dpi and retains an 11-pt base font at target size.
kPublicationDoubleColumnWidthIn <- 190 / 25.4
# A 230-mm practical height cap keeps full-page figures inside a conventional
# journal text block while leaving room for the manuscript caption.
kPublicationMaximumHeightIn <- 230 / 25.4
kPublicationFigureDpi <- 600L
kPublicationBaseFontSizePt <- 11
kPublicationMaximumFacetColumns <- 3L
kPublicationTheme <- ggplot2::theme_classic(
  base_size = kPublicationBaseFontSizePt, base_family = "sans"
) +
  ggplot2::theme(
    axis.text = ggplot2::element_text(color = "black"),
    strip.text = ggplot2::element_text(face = "bold"),
    legend.position = "bottom",
    plot.title = ggplot2::element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = ggplot2::element_text(
      hjust = 0, lineheight = 1.05, margin = ggplot2::margin(b = 8)
    ),
    plot.caption = ggplot2::element_text(
      hjust = 0, lineheight = 1.05, margin = ggplot2::margin(t = 8)
    ),
    axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 8)),
    axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 8)),
    legend.box = "vertical",
    legend.margin = ggplot2::margin(t = 5),
    plot.margin = ggplot2::margin(14, 20, 16, 16)
  )

# 3. EXECUTION, DIRECTORIES, LOGGING, AND REPRODUCIBILITY ---------------------

DetectCurrentScriptPath <- function() {
  frames <- sys.frames()
  if (length(frames) > 0L) {
    for (index in rev(seq_along(frames))) {
      path <- frames[[index]]$ofile
      if (!is.null(path) && length(path) == 1L && !is.na(path) && nzchar(path)) {
        return(normalizePath(path, winslash = "/", mustWork = FALSE))
      }
    }
  }

  if (requireNamespace("rstudioapi", quietly = TRUE) &&
      isTRUE(rstudioapi::isAvailable())) {
    path <- tryCatch(
      rstudioapi::getSourceEditorContext()$path,
      error = function(error) ""
    )
    if (length(path) == 1L && !is.na(path) && nzchar(path)) {
      return(normalizePath(path, winslash = "/", mustWork = FALSE))
    }
  }
  NA_character_
}

ResolveRStudioDataFile <- function(script_path) {
  script_directory <- if (!is.na(script_path)) dirname(script_path) else NA_character_
  candidates <- unique(c(
    if (!is.na(script_directory)) file.path(script_directory, kDefaultDataFile),
    file.path(getwd(), kDefaultDataFile)
  ))
  existing <- candidates[file.exists(candidates)]
  if (length(existing) > 0L) {
    return(normalizePath(existing[1], winslash = "/", mustWork = TRUE))
  }

  if (!interactive()) {
    stop(
      "varzea_tree_diameter_growth.xlsx was not found beside the script or in the working directory."
    )
  }
  message(
    "varzea_tree_diameter_growth.xlsx was not found beside the script. ",
    "Select the consolidated input workbook once."
  )
  selected <- file.choose()
  if (!tolower(tools::file_ext(selected)) %in% c("xlsx", "xls")) {
    stop("The selected input must be an Excel workbook (.xlsx or .xls).")
  }
  normalizePath(selected, winslash = "/", mustWork = TRUE)
}

# Execution controls. FALSE/FALSE performs the complete publication analysis;
# kForceRefit bypasses compatible caches and kValidateOnly omits model fitting.
kForceRefit <- FALSE
kValidateOnly <- FALSE

kScriptPath <- DetectCurrentScriptPath()
kDataFile <- ResolveRStudioDataFile(kScriptPath)
kProjectDirectory <- dirname(kDataFile)
kRootOutputDirectory <- file.path(kProjectDirectory, kDefaultOutputDirectory)
kOutputDirectory <- kRootOutputDirectory
kLogFile <- file.path(kOutputDirectory, "pipeline.log")
kUnitTestLogFile <- file.path(kOutputDirectory, "unit_tests.log")
kRootLogFile <- file.path(kRootOutputDirectory, "pipeline.log")
kRootUnitTestLogFile <- file.path(kRootOutputDirectory, "unit_tests.log")

message("Input workbook: ", kDataFile)
message("Growth-data sheet: ", kDataSheet)
message("Embedded commercial registry sheet: ", kCommercialSpeciesSheet)
message("Required publication curation-audit sheet: ", kCurationAuditSheet)
message("Output directory: ", kRootOutputDirectory)

SetOutputContext <- function(output_directory) {
  kOutputDirectory <<- output_directory
  kLogFile <<- file.path(kOutputDirectory, "pipeline.log")
  kUnitTestLogFile <<- file.path(kOutputDirectory, "unit_tests.log")
  invisible(kOutputDirectory)
}

SetRootOutputContext <- function() {
  SetOutputContext(kRootOutputDirectory)
}

SetAnalysisScope <- function(scope_id, target_species = character(0)) {
  if (!scope_id %in% kPlannedAnalysisScopes) {
    stop("Unknown analysis scope: ", scope_id)
  }
  if (identical(scope_id, "community")) {
    kAnalysisScopeMode <<- "eligible_community"
    kTargetSpecies <<- character(0)
  } else {
    target_species <- sort(unique(trimws(as.character(target_species))))
    target_species <- target_species[nzchar(target_species)]
    if (length(target_species) == 0L) {
      stop("The commercially listed species scope has no matched species.")
    }
    kAnalysisScopeMode <<- "explicit_species_group"
    kTargetSpecies <<- target_species
  }
  invisible(scope_id)
}

InitializeDirectories <- function(scope_output = TRUE) {
  directories <- c(
    kOutputDirectory,
    file.path(kOutputDirectory, "Tables")
  )
  if (isTRUE(scope_output)) {
    directories <- c(
      directories,
      file.path(kOutputDirectory, "Figures"),
      file.path(kOutputDirectory, "Models"),
      file.path(kOutputDirectory, "Cache"),
      file.path(kOutputDirectory, "Richards"),
      file.path(kOutputDirectory, "Lundqvist")
    )
  } else {
    legacy_root_directories <- file.path(
      kOutputDirectory, c("Figures", "Models", "Cache", "Richards", "Lundqvist")
    )
    for (legacy_directory in legacy_root_directories) {
      if (dir.exists(legacy_directory) &&
          length(list.files(legacy_directory, all.files = TRUE, no.. = TRUE)) == 0L) {
        invisible(unlink(legacy_directory, recursive = TRUE, force = TRUE))
      }
    }
  }
  invisible(lapply(directories, dir.create, recursive = TRUE, showWarnings = FALSE))
  run_timestamp <- format(Sys.time(), "%Y%m%d_%H%M%S")
  for (existing_log in c(kLogFile, kUnitTestLogFile)) {
    if (file.exists(existing_log)) {
      archived_log <- file.path(
        dirname(existing_log),
        paste0(
          tools::file_path_sans_ext(basename(existing_log)),
          "_previous_", run_timestamp, ".log"
        )
      )
      if (!file.rename(existing_log, archived_log)) {
        warning("Could not archive existing log: ", existing_log)
      }
    }
  }
  optional_stale_files <- character()
  if (!isTRUE(kRunHuberSensitivity) &&
      !isTRUE(kRunExploratoryErrorSensitivities)) {
    optional_stale_files <- c(
      optional_stale_files,
      file.path(kOutputDirectory, "Figures", "Error_structure_sensitivity.tiff")
    )
  }
  if (!isTRUE(kEnableConditionalManagementScenarios)) {
    optional_stale_files <- c(
      optional_stale_files,
      file.path(
        kOutputDirectory, "Figures",
        "Conditional_5_90_year_survivor_DBH_scenarios.tiff"
      ),
      file.path(
        kOutputDirectory, "Figures",
        "Conditional_projection_structural_divergence_5_90_years.tiff"
      )
    )
  }
  existing_optional_stale_files <- optional_stale_files[
    file.exists(optional_stale_files)
  ]
  if (length(existing_optional_stale_files) > 0L) {
    invisible(unlink(existing_optional_stale_files))
  }
}

LogMessage <- function(level = c("INFO", "WARN", "ERROR"), message, log_file = kLogFile) {
  level <- match.arg(level)
  formatted <- sprintf(
    "[%s] [%s] %s\n", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), level, message
  )
  cat(formatted)
  cat(formatted, file = log_file, append = TRUE)
  invisible(formatted)
}

`%||%` <- function(left, right) {
  if (is.null(left) || length(left) == 0L) right else left
}

GetScriptPath <- function() {
  kScriptPath
}

GetPackageManifest <- function() {
  packages <- sort(unique(kRequiredPackages))
  data.frame(
    package = packages,
    version = vapply(packages, function(package) {
      if (requireNamespace(package, quietly = TRUE)) {
        as.character(utils::packageVersion(package))
      } else {
        NA_character_
      }
    }, character(1)),
    stringsAsFactors = FALSE
  )
}

BuildAnalysisSignature <- function() {
  script_path <- GetScriptPath()
  script_md5 <- if (!is.na(script_path) && file.exists(script_path)) {
    unname(tools::md5sum(script_path))
  } else {
    "script-path-unavailable"
  }
  input_md5 <- if (file.exists(kDataFile)) unname(tools::md5sum(kDataFile)) else "missing"
  package_manifest <- GetPackageManifest()
  values <- c(
    kModelSpecVersion, script_md5, input_md5,
    kDataSheet, kCommercialSpeciesSheet, kCurationAuditSheet,
    kRequireDocumentedCurationAudit, kTargetClass,
    kModelingPeriods, kExcludedPlaceholderPeriods, kTargetPlots,
    kPlannedAnalysisScopes, kAnalysisScopeMode,
    kMinimumIncrementCm, kHighAnnualIncrementAuditThreshold,
    sort(kTargetSpecies),
    kMinimumSpeciesIntervalsForDiagnostics,
    kMinimumSpeciesTreesForDiagnostics,
    kMinimumSpeciesPlotsForDiagnostics,
    kRunExploratoryErrorSensitivities,
    kRunHuberSensitivity, kHuberTuningConstant, kHuberMinimumScaleCm,
    kExtremeResidualThresholdsCm, kExtremeResidualRowsExportThresholdCm,
    kMinimumPracticalFamilyRmseDifferenceCm,
    kEnableConditionalManagementScenarios,
    kManagementHorizonYears, kManagementTrajectoryYears,
    kManagementScenarioAsymptotesCm, kManagementScenarioInitialDbhCm,
    kLargeDiameterThresholdsCm,
    kProjectionStepInvarianceToleranceCm,
    kAsymptoteProfileSupportDeltaThreshold,
    kHighAsymptotePlateauThresholdCm,
    kDiameterSupportBreaksCm, kDiameterSupportLabels,
    kBroadDiameterSupportMinimumTrees,
    kBroadDiameterSupportMinimumSpecies,
    kBroadDiameterSupportMinimumPlots,
    kLimitedDiameterSupportMinimumTrees,
    kLimitedDiameterSupportMinimumSpecies,
    kLimitedDiameterSupportMinimumPlots,
    kDbhClassMinimumIntervalsForComparativeDescription,
    kDbhClassMinimumPlotsForComparativeDescription,
    kPublicationDoubleColumnWidthIn, kPublicationMaximumHeightIn,
    kPublicationFigureDpi, kPublicationBaseFontSizePt,
    kPublicationMaximumFacetColumns,
    kExpectedInputRows, kExpectedRowsInModelingPeriods,
    kExpectedAnalyticalIntervals, kExpectedUniqueTrees,
    kExpectedZeroIncrements, kExpectedHighAnnualIncrements,
    kExpectedMaximumObservedDbhCm,
    kExpectedCommercialRegistryRows, kExpectedCommercialUniqueTaxa,
    kExpectedCommercialPermittedTaxa, kExpectedCommercialProtectedTaxa,
    kExpectedCommercialStatusConflicts, kExpectedCommercialMatchedTaxa,
    kExpectedCommercialMatchedPermittedTaxa,
    kExpectedCommercialMatchedProtectedTaxa,
    kExpectedCommercialIntervals, kExpectedCommercialUniqueTrees,
    kBasalArea2013ByPlot$inventory_trees_2013,
    formatC(kBasalArea2013ByPlot$basal_area_2013_m2_ha, digits = 17, format = "fg"),
    formatC(kBasalArea2013ControlTotal, digits = 17, format = "fg"),
    kAsymptoteUpper, kAsymptoteProfile,
    kPredictionDomainAsymptoteFloorCm, kLogRateBounds,
    kBasalAreaEffectBounds, kRichardsShapeBounds, kLundqvistShapeBounds,
    kFullGlobalSeeds, kProfileGlobalSeeds, kFullDeIterMax, kFullDeNp,
    kCvDeIterMax, kCvDeNp, kProfileDeIterMax, kProfileDeNp,
    kLocalOptimMaxIterations, kLocalOptimFactr,
    kLocalOptimProjectedGradientTolerance, kLocalOptimRelativeTolerance,
    kOptimizerObjectiveAgreementTolerance,
    kMinimumIndependentUsableLocalMethods,
    kFglsMaxIterations, kStudentTMaxIterations, kIrlsConvergenceTolerance,
    kStudentTDegreesFreedom,
    kMinimumPracticalBaGainCm, kMinimumBaWinningPlots,
    kLopoClusterBootstrapReplicates, kLopoClusterBootstrapSeed,
    paste(package_manifest$package, package_manifest$version, sep = "="),
    paste(R.version$major, R.version$minor, sep = ".")
  )
  paste(values, collapse = "|")
}

DeterministicSeed <- function(...) {
  key <- paste(..., sep = "|")
  integers <- utf8ToInt(enc2utf8(key))
  offset <- sum(integers * seq_along(integers))
  as.integer((kBaseSeed + offset) %% (.Machine$integer.max - 1L) + 1L)
}

GetSpecification <- function(structural_id) {
  index <- match(structural_id, kStructuralSpecifications$structural_id)
  if (is.na(index)) {
    stop("Unknown structural candidate: ", structural_id)
  }
  as.list(kStructuralSpecifications[index, , drop = FALSE])
}

GetFamilyDirectory <- function(model_family) {
  if (!model_family %in% c("Richards", "Lundqvist")) {
    stop("Unknown model family: ", model_family)
  }
  file.path(kOutputDirectory, model_family)
}

# 4. INPUT VALIDATION, LINEAGE, AND PREPARATION -------------------------------

DataCurationAuditTemplate <- function() {
  data.frame(
    plot_id = integer(), tree_tag = character(), period = character(),
    initial_dbh_cm = numeric(), final_dbh_cm = numeric(),
    event_type = character(), decision = character(), affected_rows = integer(),
    justification = character(), verification_source = character(),
    reviewer = character(), verification_date = character(),
    stringsAsFactors = FALSE
  )
}

CurationEventSpecification <- function() {
  data.frame(
    event_type = c(
      "negative_increment_removed_upstream",
      "high_annual_increment_retained",
      "zero_increment_retained",
      "placeholder_period_exclusion"
    ),
    expected_decision = c(
      "excluded_upstream", "retained", "retained", "excluded_placeholder"
    ),
    freeze_required = c(TRUE, TRUE, FALSE, TRUE),
    audit_mode = c(
      "aggregate_upstream_count",
      "row_level_source_identity",
      "diagnostic_optional",
      "aggregate_period_count"
    ),
    row_level_reconciliation_required = c(FALSE, TRUE, FALSE, FALSE),
    period_level_reconciliation_required = c(FALSE, FALSE, FALSE, TRUE),
    stringsAsFactors = FALSE
  )
}

NormalizeCurationText <- function(values) {
  values <- trimws(as.character(values))
  values[is.na(values)] <- ""
  values
}

IsSubstantiveCurationJustification <- function(values) {
  normalized <- tolower(NormalizeCurationText(values))
  generic <- c(
    "", "verified", "verified and retained", "field verified", "checked",
    "ok", "n/a", "na", "unknown", "pending", "tbd", "not documented",
    "not available"
  )
  nzchar(normalized) & !normalized %in% generic
}

IsSpecificCurationVerificationSource <- function(values) {
  normalized <- tolower(NormalizeCurationText(values))
  generic <- c(
    "", "verified", "verified and retained", "field verified", "checked",
    "field check", "source verified", "n/a", "na", "unknown", "pending",
    "tbd", "not documented", "not available"
  )
  nzchar(normalized) & !normalized %in% generic
}

IsValidCurationVerificationDate <- function(values) {
  normalized <- NormalizeCurationText(values)
  normalized <- sub("[[:space:]].*$", "", normalized)
  iso <- suppressWarnings(as.Date(normalized, format = "%Y-%m-%d"))
  br <- suppressWarnings(as.Date(normalized, format = "%d/%m/%Y"))
  nzchar(normalized) & (!is.na(iso) | !is.na(br))
}

IsDocumentedUnavailableUpstreamNegativeCount <- function(justification, verification_source) {
  justification_norm <- tolower(NormalizeCurationText(justification))
  source_norm <- tolower(NormalizeCurationText(verification_source))
  unavailable_pattern <- paste(
    c(
      "cannot be reconstructed", "cannot be recovered", "not reconstructable",
      "unavailable from the analytical workbook", "original count is unavailable",
      "nao pode ser reconstru", "não pode ser reconstru", "indisponivel", "indisponível"
    ),
    collapse = "|"
  )
  protocol_pattern <- paste(
    c(
      "protocolo_metodologico", "protocolo metodologico", "protocolo metodológico",
      "methodological protocol", "closed methodological protocol"
    ),
    collapse = "|"
  )
  grepl(unavailable_pattern, justification_norm) &
    grepl(protocol_pattern, source_norm)
}

CurationRowKey <- function(plot_id, tree_tag, period, initial_dbh_cm,
                           final_dbh_cm) {
  ifelse(
    is.na(plot_id) | !nzchar(trimws(as.character(tree_tag))) |
      !nzchar(trimws(as.character(period))) | is.na(initial_dbh_cm) |
      is.na(final_dbh_cm),
    NA_character_,
    paste(
      as.integer(plot_id), trimws(as.character(tree_tag)),
      trimws(as.character(period)),
      sprintf("%.8f", as.numeric(initial_dbh_cm)),
      sprintf("%.8f", as.numeric(final_dbh_cm)),
      sep = "|"
    )
  )
}

BuildDataCurationAuditPrefill <- function(raw_data) {
  required <- c(
    "source_plot_id", "tree_tag", "period_pair", "status_code",
    "source_initial_dbh", "source_final_dbh", "source_interval_years"
  )
  missing <- setdiff(required, names(raw_data))
  if (length(missing) > 0L) {
    stop(
      "Cannot build the curation prefill because raw data are missing: ",
      paste(missing, collapse = ", ")
    )
  }
  modeling_survivors <- raw_data %>%
    dplyr::filter(
      as.character(period_pair) %in% kModelingPeriods,
      as.character(status_code) == kTargetClass
    ) %>%
    dplyr::mutate(
      increment_cm = source_final_dbh - source_initial_dbh,
      annual_increment_cm_yr = increment_cm / source_interval_years
    )
  placeholder_survivors <- raw_data %>%
    dplyr::filter(
      as.character(period_pair) %in% kExcludedPlaceholderPeriods,
      as.character(status_code) == kTargetClass
    )

  VisiblePrefill <- function(data, event_type, decision) {
    if (nrow(data) == 0L) {
      return(DataCurationAuditTemplate())
    }
    data.frame(
      plot_id = as.integer(data$source_plot_id),
      tree_tag = as.character(data$tree_tag),
      period = as.character(data$period_pair),
      initial_dbh_cm = as.numeric(data$source_initial_dbh),
      final_dbh_cm = as.numeric(data$source_final_dbh),
      event_type = event_type,
      decision = decision,
      affected_rows = 1L,
      justification = "",
      verification_source = "",
      reviewer = "",
      verification_date = "",
      stringsAsFactors = FALSE
    )
  }

  upstream <- data.frame(
    plot_id = NA_integer_, tree_tag = "", period = "",
    initial_dbh_cm = NA_real_, final_dbh_cm = NA_real_,
    event_type = "negative_increment_removed_upstream",
    decision = "excluded_upstream", affected_rows = NA_integer_,
    justification = "", verification_source = "", reviewer = "",
    verification_date = "", stringsAsFactors = FALSE
  )

  high <- modeling_survivors %>%
    dplyr::filter(annual_increment_cm_yr > kHighAnnualIncrementAuditThreshold)

  placeholder_summary <- placeholder_survivors %>%
    dplyr::count(period_pair, name = "affected_rows") %>%
    dplyr::arrange(period_pair)
  placeholder_prefill <- if (nrow(placeholder_summary) == 0L) {
    DataCurationAuditTemplate()
  } else {
    data.frame(
      plot_id = NA_integer_,
      tree_tag = "",
      period = as.character(placeholder_summary$period_pair),
      initial_dbh_cm = NA_real_,
      final_dbh_cm = NA_real_,
      event_type = "placeholder_period_exclusion",
      decision = "excluded_placeholder",
      affected_rows = as.integer(placeholder_summary$affected_rows),
      justification = "",
      verification_source = "",
      reviewer = "",
      verification_date = "",
      stringsAsFactors = FALSE
    )
  }

  dplyr::bind_rows(
    upstream,
    VisiblePrefill(high, "high_annual_increment_retained", "retained"),
    placeholder_prefill
  ) %>%
    dplyr::arrange(
      factor(event_type, levels = CurationEventSpecification()$event_type),
      period, plot_id, tree_tag, initial_dbh_cm, final_dbh_cm
    )
}

BuildZeroIncrementDiagnostic <- function(raw_data) {
  raw_data %>%
    dplyr::filter(
      as.character(period_pair) %in% kModelingPeriods,
      as.character(status_code) == kTargetClass
    ) %>%
    dplyr::mutate(
      increment_cm = source_final_dbh - source_initial_dbh,
      annual_increment_cm_yr = increment_cm / source_interval_years
    ) %>%
    dplyr::filter(increment_cm == 0) %>%
    dplyr::transmute(
      plot_id = as.integer(source_plot_id),
      tree_tag = as.character(tree_tag),
      period = as.character(period_pair),
      initial_dbh_cm = as.numeric(source_initial_dbh),
      final_dbh_cm = as.numeric(source_final_dbh),
      interval_years = as.numeric(source_interval_years),
      increment_cm = as.numeric(increment_cm),
      annual_increment_cm_yr = as.numeric(annual_increment_cm_yr),
      analytical_decision = "retained",
      freeze_requirement = "diagnostic_only_not_required_by_frozen_FEM10_criterion"
    ) %>%
    dplyr::arrange(plot_id, tree_tag, period, initial_dbh_cm, final_dbh_cm)
}

BuildCurationDocumentationRequirements <- function(raw_data) {
  high_count <- raw_data %>%
    dplyr::filter(
      as.character(period_pair) %in% kModelingPeriods,
      as.character(status_code) == kTargetClass
    ) %>%
    dplyr::mutate(
      annual_increment_cm_yr =
        (source_final_dbh - source_initial_dbh) / source_interval_years
    ) %>%
    dplyr::filter(annual_increment_cm_yr > kHighAnnualIncrementAuditThreshold) %>%
    nrow()
  placeholder_count <- raw_data %>%
    dplyr::filter(
      as.character(period_pair) %in% kExcludedPlaceholderPeriods,
      as.character(status_code) == kTargetClass
    ) %>%
    nrow()
  data.frame(
    frozen_requirement = c(
      "negative increments removed upstream",
      "high annual increments retained",
      "2022-2023 placeholder exclusion"
    ),
    required_event_type = c(
      "negative_increment_removed_upstream",
      "high_annual_increment_retained",
      "placeholder_period_exclusion"
    ),
    records_expected = c(
      "one aggregate record",
      paste0(high_count, " source-row record(s)"),
      paste0(length(kExcludedPlaceholderPeriods), " aggregate period record(s)")
    ),
    required_evidence = c(
      paste0(
        "Original number of negative increments removed before workbook delivery when ",
        "recoverable. If the original count cannot be reconstructed, explicitly document ",
        "that limitation and cite the closed methodological protocol; always document the ",
        "upstream exclusion rule."
      ),
      paste0(
        "Each extreme row must retain its prefilled plot/tree/period/DBH identity and ",
        "cite a specific documentary verification source. One source may legitimately ",
        "support multiple rows when that source explicitly covers them."
      ),
      paste0(
        "One documentary source per excluded period confirming that it was not a true ",
        "remeasurement (e.g., placeholder/provisional fill). The script reconciles the ",
        placeholder_count, " survivor rows automatically; individual duplicate evidence ",
        "for each survivor is not required."
      )
    ),
    publication_freeze_required = TRUE,
    stringsAsFactors = FALSE
  )
}

ReadDataCurationAudit <- function(path = kDataFile) {
  available_sheets <- readxl::excel_sheets(path)
  template <- DataCurationAuditTemplate()
  if (!kCurationAuditSheet %in% available_sheets) {
    return(list(
      sheet_present = FALSE, records = template,
      message = paste0(
        "Required sheet '", kCurationAuditSheet,
        "' is absent; publication/freezing is blocked until provenance is documented."
      )
    ))
  }
  records <- suppressMessages(readxl::read_excel(
    path, sheet = kCurationAuditSheet, .name_repair = "unique"
  ))
  required <- names(template)
  missing <- setdiff(required, names(records))
  if (length(missing) > 0L) {
    stop(
      "The data-curation audit sheet is missing required columns: ",
      paste(missing, collapse = ", ")
    )
  }
  records <- as.data.frame(records[, required, drop = FALSE])
  records$event_type <- tolower(NormalizeCurationText(records$event_type))
  records$decision <- tolower(NormalizeCurationText(records$decision))
  records$tree_tag <- NormalizeCurationText(records$tree_tag)
  records$period <- NormalizeCurationText(records$period)
  records$justification <- NormalizeCurationText(records$justification)
  records$verification_source <- NormalizeCurationText(records$verification_source)
  records$reviewer <- NormalizeCurationText(records$reviewer)
  records$verification_date <- NormalizeCurationText(records$verification_date)
  records$plot_id <- suppressWarnings(as.integer(records$plot_id))
  records$initial_dbh_cm <- suppressWarnings(as.numeric(records$initial_dbh_cm))
  records$final_dbh_cm <- suppressWarnings(as.numeric(records$final_dbh_cm))
  records$affected_rows <- suppressWarnings(as.integer(records$affected_rows))
  list(
    sheet_present = TRUE, records = records,
    message = paste(nrow(records), "data-curation audit record(s) loaded")
  )
}

BuildDataCurationProvenance <- function(raw_data, curation_audit) {
  modeling_survivors <- raw_data %>%
    dplyr::filter(
      as.character(period_pair) %in% kModelingPeriods,
      as.character(status_code) == kTargetClass
    ) %>%
    dplyr::mutate(
      increment_cm = source_final_dbh - source_initial_dbh,
      annual_increment_cm_yr = increment_cm / source_interval_years
    )
  placeholder_survivors <- raw_data %>%
    dplyr::filter(
      as.character(period_pair) %in% kExcludedPlaceholderPeriods,
      as.character(status_code) == kTargetClass
    )

  event_specification <- CurationEventSpecification()
  records <- curation_audit$records
  expected_events <- event_specification$event_type
  unexpected_events <- sort(unique(
    records$event_type[nzchar(records$event_type) &
      !records$event_type %in% expected_events]
  ))

  VisibleCandidates <- function(data, event_type) {
    if (nrow(data) == 0L) {
      return(data.frame(
        event_type = character(), row_key = character(), stringsAsFactors = FALSE
      ))
    }
    data.frame(
      event_type = event_type,
      row_key = CurationRowKey(
        data$source_plot_id, data$tree_tag, data$period_pair,
        data$source_initial_dbh, data$source_final_dbh
      ),
      stringsAsFactors = FALSE
    )
  }

  high_candidates <- modeling_survivors %>%
    dplyr::filter(annual_increment_cm_yr > kHighAnnualIncrementAuditThreshold)
  zero_candidates <- modeling_survivors %>%
    dplyr::filter(increment_cm == 0)
  visible_candidates <- VisibleCandidates(
    high_candidates, "high_annual_increment_retained"
  )
  if (anyNA(visible_candidates$row_key) || anyDuplicated(visible_candidates$row_key)) {
    stop(
      "High-increment curation candidates do not have unique row identities. ",
      "Resolve the analytical-workbook lineage before fitting."
    )
  }

  placeholder_expected <- placeholder_survivors %>%
    dplyr::count(period_pair, name = "expected_rows") %>%
    dplyr::mutate(period_pair = as.character(period_pair)) %>%
    dplyr::arrange(period_pair)

  component_specification <- data.frame(
    curation_component = c(
      "negative increments removed before analytical-workbook delivery",
      "high annual increments retained",
      "zero increments retained",
      "placeholder period excluded"
    ),
    event_type = event_specification$event_type,
    expected_decision = event_specification$expected_decision,
    freeze_required = event_specification$freeze_required,
    audit_mode = event_specification$audit_mode,
    row_level_reconciliation_required =
      event_specification$row_level_reconciliation_required,
    period_level_reconciliation_required =
      event_specification$period_level_reconciliation_required,
    observed_rows_in_supplied_workbook = c(
      NA_integer_, nrow(high_candidates), nrow(zero_candidates),
      nrow(placeholder_survivors)
    ),
    stringsAsFactors = FALSE
  )

  provenance <- lapply(seq_len(nrow(component_specification)), function(index) {
    component <- component_specification[index, , drop = FALSE]
    matching <- records[
      records$event_type == component$event_type, , drop = FALSE
    ]
    freeze_required <- isTRUE(component$freeze_required)

    documentation_flags <- if (nrow(matching) == 0L) {
      logical()
    } else {
      IsSubstantiveCurationJustification(matching$justification) &
        IsSpecificCurationVerificationSource(matching$verification_source) &
        nzchar(NormalizeCurationText(matching$reviewer)) &
        IsValidCurationVerificationDate(matching$verification_date)
    }
    documentation_complete <- nrow(matching) > 0L && all(documentation_flags)
    decision_reconciled <- if (nrow(matching) == 0L) {
      FALSE
    } else {
      all(matching$decision == component$expected_decision)
    }

    upstream_count_documented_unavailable <-
      identical(component$event_type, "negative_increment_removed_upstream") &&
      nrow(matching) == 1L && is.na(matching$affected_rows[1]) &&
      IsDocumentedUnavailableUpstreamNegativeCount(
        matching$justification[1], matching$verification_source[1]
      )

    affected_rows_valid <- if (nrow(matching) == 0L) {
      FALSE
    } else if (identical(
      component$event_type, "negative_increment_removed_upstream"
    )) {
      nrow(matching) == 1L &&
        ((!is.na(matching$affected_rows[1]) && matching$affected_rows[1] >= 0L) ||
           isTRUE(upstream_count_documented_unavailable))
    } else if (identical(
      component$event_type, "high_annual_increment_retained"
    )) {
      all(!is.na(matching$affected_rows) & matching$affected_rows == 1L)
    } else if (identical(
      component$event_type, "placeholder_period_exclusion"
    )) {
      all(!is.na(matching$affected_rows) & matching$affected_rows >= 0L)
    } else {
      # Zero-increment audit rows are optional. If supplied voluntarily, retain
      # the same one-row/one-observation convention, but never use this
      # component
      # as a publication-freeze gate.
      all(!is.na(matching$affected_rows) & matching$affected_rows == 1L)
    }

    affected_rows_reported <- if (
      nrow(matching) > 0L && all(!is.na(matching$affected_rows))
    ) {
      sum(matching$affected_rows)
    } else {
      NA_integer_
    }

    row_identity_reconciled <- NA
    if (isTRUE(component$row_level_reconciliation_required)) {
      audit_keys <- CurationRowKey(
        matching$plot_id, matching$tree_tag, matching$period,
        matching$initial_dbh_cm, matching$final_dbh_cm
      )
      candidate_keys <- visible_candidates$row_key[
        visible_candidates$event_type == component$event_type
      ]
      row_identity_reconciled <- nrow(matching) == length(candidate_keys) &&
        length(audit_keys) == length(candidate_keys) &&
        !anyNA(audit_keys) && !anyDuplicated(audit_keys) &&
        setequal(audit_keys, candidate_keys)
    }

    period_identity_reconciled <- NA
    period_counts_reconciled <- NA
    if (isTRUE(component$period_level_reconciliation_required)) {
      expected <- placeholder_expected
      supplied <- matching %>%
        dplyr::transmute(
          period_pair = as.character(period),
          supplied_rows = as.integer(affected_rows)
        )
      period_identity_reconciled <-
        nrow(supplied) == nrow(expected) &&
        !anyDuplicated(supplied$period_pair) &&
        setequal(supplied$period_pair, expected$period_pair)
      if (isTRUE(period_identity_reconciled)) {
        supplied <- supplied[match(expected$period_pair, supplied$period_pair), , drop = FALSE]
        period_counts_reconciled <- all(
          !is.na(supplied$supplied_rows) &
            supplied$supplied_rows == expected$expected_rows
        )
      } else {
        period_counts_reconciled <- FALSE
      }
    }

    count_reconciled <- if (identical(
      component$event_type, "negative_increment_removed_upstream"
    )) {
      affected_rows_valid &&
        (isTRUE(upstream_count_documented_unavailable) ||
           (is.finite(affected_rows_reported) && affected_rows_reported >= 0L))
    } else if (identical(
      component$event_type, "placeholder_period_exclusion"
    )) {
      affected_rows_valid && isTRUE(period_counts_reconciled) &&
        isTRUE(affected_rows_reported ==
          component$observed_rows_in_supplied_workbook)
    } else if (identical(
      component$event_type, "zero_increment_retained"
    ) && nrow(matching) == 0L) {
      NA
    } else {
      affected_rows_valid && isTRUE(
        affected_rows_reported == component$observed_rows_in_supplied_workbook
      )
    }

    audit_status <- if (!freeze_required && nrow(matching) == 0L) {
      "OPTIONAL_NOT_REQUIRED"
    } else if (!freeze_required && nrow(matching) > 0L &&
               documentation_complete && decision_reconciled &&
               affected_rows_valid && isTRUE(count_reconciled)) {
      "OPTIONAL_DOCUMENTED"
    } else if (!freeze_required) {
      "OPTIONAL_INCOMPLETE_NONBLOCKING"
    } else if (!isTRUE(curation_audit$sheet_present)) {
      "NOT_DOCUMENTED"
    } else if (nrow(matching) == 0L) {
      "MISSING_COMPONENT_RECORD"
    } else if (!documentation_complete) {
      "INCOMPLETE_DOCUMENTATION"
    } else if (!decision_reconciled) {
      "DECISION_MISMATCH"
    } else if (!affected_rows_valid) {
      "INVALID_AFFECTED_ROWS"
    } else if (isTRUE(component$row_level_reconciliation_required) &&
               !isTRUE(row_identity_reconciled)) {
      "ROW_IDENTITY_MISMATCH"
    } else if (isTRUE(component$period_level_reconciliation_required) &&
               !isTRUE(period_identity_reconciled)) {
      "PERIOD_IDENTITY_MISMATCH"
    } else if (!isTRUE(count_reconciled)) {
      "COUNT_MISMATCH"
    } else if (identical(
      component$event_type, "negative_increment_removed_upstream"
    ) && isTRUE(upstream_count_documented_unavailable)) {
      "DOCUMENTED_LIMITATION"
    } else {
      "DOCUMENTED"
    }

    data.frame(
      curation_component = component$curation_component,
      expected_event_type = component$event_type,
      expected_decision = component$expected_decision,
      publication_freeze_required = freeze_required,
      audit_mode = component$audit_mode,
      observed_rows_in_supplied_workbook =
        component$observed_rows_in_supplied_workbook,
      audit_records = nrow(matching),
      documented_records = sum(documentation_flags),
      affected_rows_reported_in_audit = affected_rows_reported,
      upstream_count_documented_unavailable =
        upstream_count_documented_unavailable,
      documentation_complete = documentation_complete,
      decision_reconciled = decision_reconciled,
      affected_rows_valid = affected_rows_valid,
      count_reconciled = count_reconciled,
      row_level_reconciliation_required =
        component$row_level_reconciliation_required,
      row_identity_reconciled = row_identity_reconciled,
      period_level_reconciliation_required =
        component$period_level_reconciliation_required,
      period_identity_reconciled = period_identity_reconciled,
      period_counts_reconciled = period_counts_reconciled,
      curation_status = audit_status,
      permissible_claim = if (audit_status %in% c(
        "DOCUMENTED", "DOCUMENTED_LIMITATION"
      )) {
        if (identical(
          component$event_type, "negative_increment_removed_upstream"
        ) && audit_status == "DOCUMENTED_LIMITATION") {
          paste0(
            "upstream negative-increment exclusion rule is documented; the original ",
            "excluded count is explicitly non-reconstructable from the analytical ",
            "workbook and this limitation is recorded in the closed methodological protocol"
          )
        } else if (identical(
          component$event_type, "negative_increment_removed_upstream"
        )) {
          paste0(
            "documented upstream exclusion count and rule; source evidence is ",
            "recorded in the supplied curation-audit sheet"
          )
        } else if (identical(
          component$event_type, "placeholder_period_exclusion"
        )) {
          paste0(
            "documented period-level placeholder exclusion with exact automatic ",
            "reconciliation to the supplied workbook"
          )
        } else {
          "documented and exactly reconciled to the supplied workbook"
        }
      } else if (!freeze_required) {
        paste0(
          "retained in the supplied analytical workbook and exported as a ",
          "diagnostic; this component is not part of the frozen FEM-10 ",
          "publication-freeze curation requirement"
        )
      } else {
        paste0(
          "retained or excluded according to the supplied analytical workbook; ",
          "verification is not publication-auditable until this required component passes"
        )
      },
      stringsAsFactors = FALSE
    )
  }) %>% dplyr::bind_rows()

  required_provenance <- provenance %>%
    dplyr::filter(publication_freeze_required)
  required_components_present <- all(required_provenance$audit_records > 0L)
  documentation_pass <- all(required_provenance$documentation_complete)
  decision_pass <- all(required_provenance$decision_reconciled)
  affected_rows_pass <- all(required_provenance$affected_rows_valid)
  count_pass <- all(required_provenance$count_reconciled %in% TRUE)
  row_level_pass <- all(
    !required_provenance$row_level_reconciliation_required |
      required_provenance$row_identity_reconciled %in% TRUE
  )
  period_level_pass <- all(
    !required_provenance$period_level_reconciliation_required |
      required_provenance$period_identity_reconciled %in% TRUE
  )
  no_unexpected_events <- length(unexpected_events) == 0L
  overall_pass <- isTRUE(curation_audit$sheet_present) &&
    no_unexpected_events && required_components_present &&
    documentation_pass && decision_pass && affected_rows_pass &&
    count_pass && row_level_pass && period_level_pass &&
    all(required_provenance$curation_status %in%
          c("DOCUMENTED", "DOCUMENTED_LIMITATION"))

  checkpoint <- data.frame(
    check = c(
      "curation audit sheet is present",
      "only predeclared curation event types are used",
      "all frozen FEM-10 curation components are present",
      "all frozen FEM-10 curation components have complete documentation",
      "required curation decisions match the frozen FEM-10 decisions",
      "required affected-row fields are valid for their audit mode",
      "required curation counts reconcile exactly",
      "high-increment source rows reconcile exactly",
      "placeholder periods and counts reconcile exactly",
      "zero increments are diagnostic and nonblocking",
      "publication curation provenance is complete"
    ),
    status = c(
      ifelse(curation_audit$sheet_present, "PASS", "FAIL"),
      ifelse(no_unexpected_events, "PASS", "FAIL"),
      ifelse(required_components_present, "PASS", "FAIL"),
      ifelse(documentation_pass, "PASS", "FAIL"),
      ifelse(decision_pass, "PASS", "FAIL"),
      ifelse(affected_rows_pass, "PASS", "FAIL"),
      ifelse(count_pass, "PASS", "FAIL"),
      ifelse(row_level_pass, "PASS", "FAIL"),
      ifelse(period_level_pass, "PASS", "FAIL"),
      "PASS",
      ifelse(overall_pass, "PASS", "FAIL")
    ),
    interpretation = c(
      curation_audit$message,
      ifelse(
        no_unexpected_events,
        "All audit event types match the predeclared FEM-10 curation vocabulary.",
        paste("Unexpected event type(s):", paste(unexpected_events, collapse = ", "))
      ),
      paste0(
        "Freeze-required components are: upstream negative exclusions, high annual ",
        "increments retained, and excluded placeholder period(s)."
      ),
      paste0(
        "Each required component needs a substantive justification, a specific ",
        "documentary verification source, reviewer, and a valid verification date ",
        "(YYYY-MM-DD or DD/MM/YYYY)."
      ),
      paste0(
        "Required decisions: negative_increment_removed_upstream=excluded_upstream; ",
        "high_annual_increment_retained=retained; ",
        "placeholder_period_exclusion=excluded_placeholder."
      ),
      paste0(
        "High increments use one audit row per source observation; upstream negatives ",
        "use one aggregate original count when recoverable, or an explicitly documented ",
        "closed-protocol non-reconstructability limitation; placeholders use one aggregate row per period."
      ),
      paste0(
        "High-increment and placeholder-period counts must reconcile exactly. For upstream ",
        "negative exclusions, the original count is used when recoverable; otherwise the ",
        "closed-protocol statement that the count cannot be reconstructed is retained as ",
        "an explicit, publication-auditable limitation."
      ),
      paste0(
        "For high increments, plot, tree tag, period, initial DBH and final DBH must ",
        "form exactly the same unique row set as the supplied workbook."
      ),
      paste0(
        "For each excluded placeholder period, one aggregate audit record must identify ",
        "the period and report exactly the survivor count found in the workbook."
      ),
      paste0(
        nrow(zero_candidates),
        " zero-increment survivor interval(s) are retained and exported separately as ",
        "a diagnostic. They do not create a new publication-freeze requirement."
      ),
      ifelse(
        overall_pass,
        "Curation provenance satisfies the frozen FEM-10 publication/freezing gate.",
        paste0(
          "Publication/freezing remains blocked. Complete and reconcile the '",
          kCurationAuditSheet,
          "' worksheet using Data_curation_audit_prefilled.csv and the exported ",
          "curation_documentation_requirements.csv. Statistical fitting may still run."
        )
      )
    ),
    stringsAsFactors = FALSE
  )

  list(
    records = records,
    provenance = provenance,
    checkpoint = checkpoint,
    template = BuildDataCurationAuditPrefill(raw_data),
    zero_increment_diagnostic = BuildZeroIncrementDiagnostic(raw_data),
    documentation_requirements = BuildCurationDocumentationRequirements(raw_data),
    publication_ready = overall_pass,
    unexpected_event_types = unexpected_events
  )
}

ReadGrowthIntervalSheet <- function(path = kDataFile) {
  source <- suppressMessages(readxl::read_excel(path, sheet = kDataSheet))
  # These names are the immutable column schema of the consolidated workbook.
  # They are translated to English analytical names immediately at ingestion.
  source_schema <- c(
    "parc", "tag_num", "DBH1", "DBH2", "P", "classe", "Ano1_Ano2",
    "genusCorr", "speciesCorr"
  )
  missing <- setdiff(source_schema, names(source))
  if (length(missing) > 0L) {
    stop(
      "The growth-data sheet is missing source-schema columns: ",
      paste(missing, collapse = ", ")
    )
  }
  source %>%
    dplyr::rename(
      source_plot_id = parc,
      tree_tag = tag_num,
      source_initial_dbh = DBH1,
      source_final_dbh = DBH2,
      source_interval_years = P,
      status_code = classe,
      period_pair = Ano1_Ano2,
      corrected_genus = genusCorr,
      corrected_species = speciesCorr
    )
}

ValidateEmbeddedBasalArea <- function() {
  if (anyDuplicated(kBasalArea2013ByPlot$plot_id) > 0L) {
    stop("The embedded baseline basal-area table contains duplicated plots.")
  }
  if (!setequal(kBasalArea2013ByPlot$plot_id, kTargetPlots)) {
    stop("The embedded baseline basal-area table does not match target plots.")
  }
  if (any(!is.finite(kBasalArea2013ByPlot$basal_area_2013_m2_ha)) ||
      any(kBasalArea2013ByPlot$basal_area_2013_m2_ha <= 0)) {
    stop("All embedded baseline basal-area values must be finite and positive.")
  }
  if (!isTRUE(all.equal(
    sum(kBasalArea2013ByPlot$basal_area_2013_m2_ha),
    kBasalArea2013ControlTotal,
    tolerance = 1e-12
  ))) {
    stop("The embedded baseline basal-area control total does not reconcile.")
  }
  invisible(TRUE)
}

ValidateInputColumns <- function(data) {
  required <- c(
    "source_plot_id", "tree_tag", "source_initial_dbh", "source_final_dbh",
    "source_interval_years", "status_code", "period_pair",
    "corrected_genus", "corrected_species", "AS", "species_id_analysis",
    "commercial_listed", "commercial_permission_class",
    "commercial_registry_conflict", "commercial_legal_basis",
    "commercial_registry_rows", "commercial_match_rule"
  )
  missing_columns <- setdiff(required, names(data))
  if (length(missing_columns) > 0L) {
    stop("Missing required input columns: ", paste(missing_columns, collapse = ", "))
  }
  numeric_columns <- c("source_plot_id", "source_initial_dbh", "source_final_dbh", "source_interval_years")
  invalid_numeric <- numeric_columns[
    !vapply(data[numeric_columns], is.numeric, logical(1))
  ]
  if (length(invalid_numeric) > 0L) {
    stop("Columns that must be numeric: ", paste(invalid_numeric, collapse = ", "))
  }
  if (anyNA(data[numeric_columns])) {
    stop(
      "source_plot_id, source_initial_dbh, source_final_dbh, and ",
      "source_interval_years cannot contain missing values."
    )
  }
  if (any(data$source_initial_dbh <= 0) || any(data$source_final_dbh < 0) || any(data$source_interval_years <= 0)) {
    stop("Input data must satisfy source_initial_dbh > 0, source_final_dbh >= 0, and source_interval_years > 0.")
  }
  if (anyNA(data$tree_tag) || any(trimws(as.character(data$tree_tag)) == "")) {
    stop("tree_tag must be present for repeated-tree identification.")
  }
  logical_columns <- c("commercial_listed", "commercial_registry_conflict")
  invalid_logical <- logical_columns[
    !vapply(data[logical_columns], is.logical, logical(1))
  ]
  if (length(invalid_logical) > 0L || anyNA(data[logical_columns])) {
    stop(
      "Embedded commercial flags must be complete logical columns: ",
      paste(logical_columns, collapse = ", ")
    )
  }
  allowed_classes <- c("permitted", "protected", "not_listed")
  invalid_classes <- setdiff(
    unique(trimws(as.character(data$commercial_permission_class))),
    allowed_classes
  )
  if (length(invalid_classes) > 0L) {
    stop(
      "Invalid embedded commercial_permission_class value(s): ",
      paste(invalid_classes, collapse = ", ")
    )
  }
  embedded_text_columns <- c(
    "species_id_analysis", "commercial_permission_class",
    "commercial_legal_basis", "commercial_registry_rows",
    "commercial_match_rule"
  )
  if (any(vapply(data[embedded_text_columns], function(values) {
    any(is.na(values) | trimws(as.character(values)) == "")
  }, logical(1)))) {
    stop("Embedded commercial-classification text columns must be complete.")
  }
  invisible(TRUE)
}

ValidateDiameterContinuity <- function(data, tolerance = 1e-8) {
  ordered <- data %>%
    dplyr::arrange(tree_id, period_order) %>%
    dplyr::group_by(tree_id) %>%
    dplyr::mutate(
      previous_period_order = dplyr::lag(period_order),
      previous_final_dbh = dplyr::lag(dbh_final),
      consecutive = period_order == previous_period_order + 1L,
      continuity_difference_cm = initial_dbh - previous_final_dbh
    ) %>%
    dplyr::ungroup() %>%
    dplyr::filter(consecutive %in% TRUE)
  failures <- ordered %>%
    dplyr::filter(abs(continuity_difference_cm) > tolerance)
  if (nrow(failures) > 0L) {
    stop(
      "DBH continuity failed for ", nrow(failures),
      " consecutive within-tree intervals. Resolve data lineage before fitting."
    )
  }
  list(checks = ordered, n_failures = nrow(failures))
}

NormalizeTaxonComponent <- function(values, fallback) {
  values <- trimws(as.character(values))
  values[is.na(values) | values == ""] <- fallback
  values
}

NormalizeRegistryTextKey <- function(values) {
  values <- trimws(as.character(values))
  transliterated <- iconv(values, from = "", to = "ASCII//TRANSLIT")
  transliterated[is.na(transliterated)] <- values[is.na(transliterated)]
  tolower(transliterated)
}

NormalizeRegistryScientificName <- function(values) {
  vapply(values, function(value) {
    value <- gsub("[[:space:]]+", " ", trimws(as.character(value)))
    tokens <- strsplit(value, " ", fixed = TRUE)[[1]]
    tokens <- tokens[nzchar(tokens)]
    if (length(tokens) < 2L) {
      return(NA_character_)
    }
    genus <- gsub("[^[:alpha:]-]", "", tokens[1])
    epithet <- gsub("[^[:alpha:].-]", "", tokens[2])
    if (tolower(epithet) %in% c("sp", "sp.")) {
      epithet <- "sp."
    }
    if (!nzchar(genus) || !nzchar(epithet)) {
      return(NA_character_)
    }
    paste(genus, epithet)
  }, character(1), USE.NAMES = FALSE)
}

ParseCommercialSpeciesRegistry <- function(raw_registry) {
  if (!is.data.frame(raw_registry) || ncol(raw_registry) < 3L) {
    stop("The commercially listed species worksheet must contain at least three columns.")
  }
  target_columns <- c(
    "source_status", "source_legal_basis", "source_scientific_name",
    "source_common_name", "source_family", "source_commercial_use",
    "source_wood_density", "source_ecological_group",
    "source_restoration_use", "source_reference", "source_notes"
  )
  raw_registry <- raw_registry[, seq_len(min(ncol(raw_registry), length(target_columns))),
                               drop = FALSE]
  names(raw_registry) <- target_columns[seq_len(ncol(raw_registry))]
  missing_target_columns <- setdiff(target_columns, names(raw_registry))
  for (column in missing_target_columns) {
    raw_registry[[column]] <- NA_character_
  }
  registry <- raw_registry %>%
    dplyr::mutate(
      source_row = dplyr::row_number(),
      dplyr::across(dplyr::all_of(target_columns), ~trimws(as.character(.x))),
      source_name_key = NormalizeRegistryTextKey(source_scientific_name),
      source_status_key = NormalizeRegistryTextKey(source_status),
      source_legal_key = NormalizeRegistryTextKey(source_legal_basis)
    ) %>%
    dplyr::filter(
      !is.na(source_scientific_name), nzchar(source_scientific_name),
      !source_name_key %in% c("especie", "species"),
      !source_status_key %in% c("status")
    ) %>%
    dplyr::mutate(
      species_id = NormalizeRegistryScientificName(source_scientific_name),
      row_permission_class = dplyr::case_when(
        grepl("protected|proteg", source_status_key) ~ "protected",
        grepl("permitted|permitida", source_legal_key) ~ "permitted",
        TRUE ~ "protected"
      )
    )
  if (nrow(registry) == 0L || anyNA(registry$species_id)) {
    stop("Commercially listed species rows could not be normalized to genus plus epithet.")
  }
  registry
}

ResolveCommercialRegistryRows <- function(registry_source) {
  resolved <- registry_source %>%
    dplyr::group_by(species_id) %>%
    dplyr::summarise(
      source_registry_rows = paste(source_row, collapse = ";"),
      source_registry_row_count = dplyr::n(),
      source_scientific_names = paste(unique(source_scientific_name), collapse = " | "),
      source_statuses = paste(unique(source_status), collapse = " | "),
      source_legal_bases = paste(unique(source_legal_basis), collapse = " | "),
      source_common_names = paste(unique(source_common_name), collapse = " | "),
      source_families = paste(unique(source_family), collapse = " | "),
      any_permitted_row = any(row_permission_class == "permitted"),
      any_protected_row = any(row_permission_class == "protected"),
      regulatory_status_conflict = any_permitted_row & any_protected_row,
      commercial_permission_class = ifelse(
        any_protected_row, "protected", "permitted"
      ),
      status_resolution_rule = ifelse(
        regulatory_status_conflict,
        "protected status overrides permission; conflict retained in audit",
        "single consistent registry class"
      ),
      .groups = "drop"
    ) %>%
    dplyr::arrange(commercial_permission_class, species_id)
  if (anyDuplicated(resolved$species_id) > 0L) {
    stop("Commercial registry resolution did not produce unique species IDs.")
  }
  if (!isTRUE(kProtectedStatusOverridesPermission) &&
      any(resolved$regulatory_status_conflict)) {
    stop("A registry conflict exists but protected-status precedence is disabled.")
  }
  resolved
}

ReadCommercialSpeciesRegistry <- function(path = kDataFile) {
  if (!file.exists(path)) {
    stop("Consolidated workbook containing the commercial registry was not found: ", path)
  }
  raw_registry <- suppressMessages(readxl::read_excel(
    path, sheet = kCommercialSpeciesSheet, col_names = FALSE,
    col_types = "text", .name_repair = "unique"
  ))
  source <- ParseCommercialSpeciesRegistry(raw_registry)
  list(source = source, resolved = ResolveCommercialRegistryRows(source))
}

ReconcileCommercialRegistry <- function(registry, eligible_community_data) {
  inventory_summary <- eligible_community_data %>%
    dplyr::group_by(species_id) %>%
    dplyr::summarise(
      eligible_intervals = dplyr::n(),
      eligible_unique_trees = dplyr::n_distinct(tree_id),
      eligible_plots = dplyr::n_distinct(plot_id),
      eligible_periods = dplyr::n_distinct(period_label),
      minimum_observed_dbh_cm = min(c(initial_dbh, dbh_final)),
      maximum_observed_dbh_cm = max(c(initial_dbh, dbh_final)),
      mean_increment_cm = mean(increment_cm),
      .groups = "drop"
    )
  reconciliation <- registry$resolved %>%
    dplyr::left_join(inventory_summary, by = "species_id") %>%
    dplyr::mutate(
      matched_to_eligible_inventory = !is.na(eligible_intervals),
      dplyr::across(
        c(eligible_intervals, eligible_unique_trees, eligible_plots,
          eligible_periods),
        ~dplyr::coalesce(as.integer(.x), 0L)
      ),
      match_rule = ifelse(
        matched_to_eligible_inventory,
        "exact genus + specific epithet match",
        "not observed in the eligible analytical inventory; no fuzzy match applied"
      )
    ) %>%
    dplyr::arrange(
      dplyr::desc(matched_to_eligible_inventory),
      commercial_permission_class, species_id
    )
  annotation <- registry$resolved %>%
    dplyr::select(
      species_id,
      expected_commercial_permission_class = commercial_permission_class,
      expected_commercial_registry_conflict = regulatory_status_conflict,
      expected_commercial_legal_basis = source_legal_bases,
      expected_commercial_registry_rows = source_registry_rows
    )
  checked_community <- eligible_community_data %>%
    dplyr::left_join(annotation, by = "species_id") %>%
    dplyr::mutate(
      expected_commercial_listed = !is.na(
        expected_commercial_permission_class
      ),
      expected_commercial_permission_class = dplyr::coalesce(
        expected_commercial_permission_class, "not_listed"
      ),
      expected_commercial_registry_conflict = dplyr::coalesce(
        expected_commercial_registry_conflict, FALSE
      ),
      expected_commercial_legal_basis = dplyr::coalesce(
        expected_commercial_legal_basis, "not listed in embedded registry"
      ),
      expected_commercial_registry_rows = dplyr::coalesce(
        expected_commercial_registry_rows, "not listed"
      ),
      expected_commercial_match_rule = ifelse(
        expected_commercial_listed,
        "exact genus + specific epithet match to embedded registry",
        "not listed in embedded registry; no fuzzy match applied"
      )
    )
  mismatches <- checked_community %>%
    dplyr::filter(
      trimws(as.character(species_id_analysis)) != species_id |
        commercial_listed != expected_commercial_listed |
        trimws(as.character(commercial_permission_class)) !=
          expected_commercial_permission_class |
        commercial_registry_conflict !=
          expected_commercial_registry_conflict |
        trimws(as.character(commercial_legal_basis)) !=
          expected_commercial_legal_basis |
        trimws(as.character(commercial_registry_rows)) !=
          expected_commercial_registry_rows |
        trimws(as.character(commercial_match_rule)) !=
          expected_commercial_match_rule
    )
  if (nrow(mismatches) > 0L) {
    stop(
      "Embedded row-level commercial classifications disagree with ",
      "Commercial_registry for ", nrow(mismatches),
      " eligible interval(s). Rebuild or audit the consolidated workbook."
    )
  }
  annotated_community <- checked_community %>%
    dplyr::select(-dplyr::starts_with("expected_commercial_"))
  list(
    source = registry$source,
    resolved = registry$resolved,
    reconciliation = reconciliation,
    conflicts = reconciliation %>%
      dplyr::filter(regulatory_status_conflict),
    unmatched = reconciliation %>%
      dplyr::filter(!matched_to_eligible_inventory),
    matched = reconciliation %>%
      dplyr::filter(matched_to_eligible_inventory),
    annotated_community = annotated_community
  )
}

ValidateCommercialRegistryReconciliation <- function(registry_audit) {
  commercial_data <- registry_audit$annotated_community %>%
    dplyr::filter(commercial_listed)
  observed <- c(
    registry_rows = nrow(registry_audit$source),
    unique_registry_taxa = nrow(registry_audit$resolved),
    permitted_registry_taxa = sum(
      registry_audit$resolved$commercial_permission_class == "permitted"
    ),
    protected_registry_taxa = sum(
      registry_audit$resolved$commercial_permission_class == "protected"
    ),
    registry_status_conflicts = sum(
      registry_audit$resolved$regulatory_status_conflict
    ),
    matched_registry_taxa = nrow(registry_audit$matched),
    matched_permitted_taxa = sum(
      registry_audit$matched$commercial_permission_class == "permitted"
    ),
    matched_protected_taxa = sum(
      registry_audit$matched$commercial_permission_class == "protected"
    ),
    commercial_intervals = nrow(commercial_data),
    commercial_unique_trees = dplyr::n_distinct(commercial_data$tree_id)
  )
  expected <- c(
    registry_rows = kExpectedCommercialRegistryRows,
    unique_registry_taxa = kExpectedCommercialUniqueTaxa,
    permitted_registry_taxa = kExpectedCommercialPermittedTaxa,
    protected_registry_taxa = kExpectedCommercialProtectedTaxa,
    registry_status_conflicts = kExpectedCommercialStatusConflicts,
    matched_registry_taxa = kExpectedCommercialMatchedTaxa,
    matched_permitted_taxa = kExpectedCommercialMatchedPermittedTaxa,
    matched_protected_taxa = kExpectedCommercialMatchedProtectedTaxa,
    commercial_intervals = kExpectedCommercialIntervals,
    commercial_unique_trees = kExpectedCommercialUniqueTrees
  )
  mismatch <- names(observed)[observed != expected]
  if (length(mismatch) > 0L) {
    stop(
      "Commercial-registry reconciliation failed: ",
      paste0(
        mismatch, " observed=", observed[mismatch],
        " expected=", expected[mismatch], collapse = "; "
      ),
      ". Review Commercial_registry and update the versioned controls only after taxonomic review."
    )
  }
  if (!setequal(unique(commercial_data$plot_id), kTargetPlots)) {
    stop("The reconciled commercially listed species group does not cover all six target plots.")
  }
  if (!setequal(
    unique(commercial_data$commercial_permission_class),
    c("permitted", "protected")
  )) {
    stop("Both permitted and protected commercial strata must be represented.")
  }
  LogMessage(
    "INFO",
    sprintf(
      paste0(
        "Commercial registry reconciled: %d matched taxa, %d intervals, ",
        "%d trees and %d documented status conflict(s)."
      ),
      nrow(registry_audit$matched), nrow(commercial_data),
      dplyr::n_distinct(commercial_data$tree_id),
      nrow(registry_audit$conflicts)
    )
  )
  invisible(data.frame(item = names(observed), observed, expected))
}

AuditExcludedPlaceholderPeriods <- function(raw_data) {
  excluded <- raw_data %>%
    dplyr::filter(as.character(period_pair) %in% kExcludedPlaceholderPeriods) %>%
    dplyr::mutate(
      survivor = !is.na(status_code) & as.character(status_code) == kTargetClass,
      increment_cm = source_final_dbh - source_initial_dbh
    )
  if (nrow(excluded) == 0L) {
    stop(
      "The configured excluded placeholder period was not found: ",
      paste(kExcludedPlaceholderPeriods, collapse = ", ")
    )
  }
  audit <- excluded %>%
    dplyr::group_by(period_pair) %>%
    dplyr::summarise(
      source_rows = dplyr::n(),
      survivor_rows = sum(survivor),
      survivor_zero_increments = sum(survivor & increment_cm == 0),
      survivor_nonzero_increments = sum(survivor & increment_cm != 0),
      survivor_zero_fraction = ifelse(
        survivor_rows > 0, survivor_zero_increments / survivor_rows, NA_real_
      ),
      exclusion_rule = paste0(
        "excluded as an unmeasured placeholder only when every survivor has source_final_dbh=source_initial_dbh; ",
        "field documentation remains required"
      ),
      .groups = "drop"
    )
  if (any(audit$survivor_rows == 0L) ||
      any(audit$survivor_nonzero_increments > 0L) ||
      any(abs(audit$survivor_zero_fraction - 1) > 1e-12)) {
    stop(
      "The excluded-period placeholder rule no longer holds. Review ",
      paste(kExcludedPlaceholderPeriods, collapse = ", "),
      " before fitting; a period containing actual remeasurements cannot be excluded."
    )
  }
  audit
}

AnalysisScopeLabel <- function() {
  if (identical(kAnalysisScopeMode, "eligible_community")) {
    "all eligible species in the monitored tree community"
  } else {
    paste0(
      "explicit species group: ",
      paste(sort(unique(trimws(kTargetSpecies))), collapse = "; ")
    )
  }
}

PrepareGrowthData <- function(raw_data, curation_provenance = NULL) {
  if (!"period_pair" %in% names(raw_data)) {
    stop("Missing required input column: period_pair")
  }
  ValidateEmbeddedBasalArea()
  ValidateInputColumns(raw_data)
  excluded_period_audit <- AuditExcludedPlaceholderPeriods(raw_data)

  period_source <- raw_data %>%
    dplyr::filter(as.character(period_pair) %in% kModelingPeriods)
  period_source <- period_source %>%
    dplyr::mutate(
      increment_cm = source_final_dbh - source_initial_dbh,
      annual_increment_cm_yr = increment_cm / source_interval_years
    )

  negative_growth <- period_source %>%
    dplyr::filter(as.character(status_code) == kTargetClass, increment_cm < 0)
  if (nrow(negative_growth) > 0L) {
    stop(
      "The supplied analytic workbook contains ", nrow(negative_growth),
      " negative-increment survivor rows. The upstream exclusion rule must be ",
      "resolved and documented before the pipeline may proceed."
    )
  }

  eligible_community_data <- period_source %>%
    dplyr::filter(
      as.character(status_code) == kTargetClass,
      increment_cm >= kMinimumIncrementCm
    ) %>%
    dplyr::rename(
      plot_id = source_plot_id,
      initial_dbh = source_initial_dbh,
      dbh_final = source_final_dbh,
      interval_years_value = source_interval_years,
      period_label = period_pair
    ) %>%
    dplyr::mutate(
      plot_id = as.integer(plot_id),
      tree_id = paste(plot_id, as.character(tree_tag), sep = ":"),
      genus_name = NormalizeTaxonComponent(corrected_genus, "Unidentified"),
      specific_epithet = NormalizeTaxonComponent(corrected_species, "sp."),
      species_id = paste(genus_name, specific_epithet),
      taxon_identified = !tolower(genus_name) %in% c(
        "indet", "unidentified", "ni", "n.i.", "na"
      ) & !tolower(specific_epithet) %in% c(
        "indet", "unidentified", "ni", "n.i.", "sp", "sp.", "na"
      ),
      period_label = as.character(period_label),
      period_order = match(period_label, kModelingPeriods)
    ) %>%
    dplyr::left_join(kBasalArea2013ByPlot, by = "plot_id") %>%
    dplyr::arrange(plot_id, tree_id, period_order) %>%
    dplyr::mutate(analysis_row_id = dplyr::row_number())

  requested_species <- sort(unique(trimws(kTargetSpecies)))
  requested_species <- requested_species[nzchar(requested_species)]
  if (!kAnalysisScopeMode %in% c(
    "eligible_community", "explicit_species_group"
  )) {
    stop(
      "kAnalysisScopeMode must be 'eligible_community' or 'explicit_species_group'."
    )
  }
  if (identical(kAnalysisScopeMode, "eligible_community") &&
      length(requested_species) > 0L) {
    stop(
      "kTargetSpecies must be empty when kAnalysisScopeMode is 'eligible_community'."
    )
  }
  if (identical(kAnalysisScopeMode, "explicit_species_group") &&
      length(requested_species) == 0L) {
    stop(
      "An explicit commercially listed species group requires a non-empty kTargetSpecies vector."
    )
  }
  unknown_species <- setdiff(
    requested_species, sort(unique(eligible_community_data$species_id))
  )
  if (length(unknown_species) > 0L) {
    stop(
      "Configured target species were not found after taxonomic normalization: ",
      paste(unknown_species, collapse = ", ")
    )
  }
  analysis_data <- if (identical(kAnalysisScopeMode, "eligible_community")) {
    eligible_community_data
  } else {
    eligible_community_data %>%
      dplyr::filter(.data$species_id %in% .env$requested_species)
  }

  if (nrow(analysis_data) == 0L) {
    stop("No observations remain under the predefined analytical rules.")
  }
  if (!setequal(unique(analysis_data$plot_id), kTargetPlots)) {
    stop("The analytical dataset does not contain exactly the six target plots.")
  }
  if (anyNA(analysis_data$basal_area_2013_m2_ha)) {
    stop("One or more analytical rows could not be linked to baseline basal area.")
  }
  if (any(analysis_data$dbh_final <= 0)) {
    stop("All surviving-tree final diameters must be positive.")
  }
  duplicate_basis <- analysis_data %>% dplyr::select(-analysis_row_id)
  if (anyDuplicated(duplicate_basis) > 0L) {
    stop("Exact duplicate rows occur in the analytical growth dataset.")
  }

  continuity <- ValidateDiameterContinuity(analysis_data)
  LogMessage(
    "INFO",
    sprintf(
      paste0(
        "Analytical scope '%s': %d intervals, %d trees, %d species, %d plots, ",
        "and %d predefined periods."
      ),
      AnalysisScopeLabel(),
      nrow(analysis_data), dplyr::n_distinct(analysis_data$tree_id),
      dplyr::n_distinct(analysis_data$species_id),
      dplyr::n_distinct(analysis_data$plot_id),
      dplyr::n_distinct(analysis_data$period_label)
    )
  )
  LogMessage(
    "INFO",
    sprintf(
      paste0(
        "Observations retained from the supplied analytical workbook: %d zero ",
        "increments and %d annual increments above %.1f cm year-1; documentary ",
        "verification status is reported separately."
      ),
      sum(analysis_data$increment_cm == 0),
      sum(analysis_data$annual_increment_cm_yr > kHighAnnualIncrementAuditThreshold),
      kHighAnnualIncrementAuditThreshold
    )
  )
  list(
    data = analysis_data,
    eligible_community_data = eligible_community_data,
    continuity = continuity$checks,
    excluded_period_audit = excluded_period_audit,
    data_curation_provenance = curation_provenance,
    analysis_scope = AnalysisScopeLabel(),
    negative_growth_rows_in_supplied_workbook = nrow(negative_growth),
    non_target_class_rows = sum(as.character(period_source$status_code) != kTargetClass)
  )
}

AttachCommercialRegistryToPrepared <- function(prepared, registry_audit) {
  prepared$eligible_community_data <- registry_audit$annotated_community
  prepared$data <- registry_audit$annotated_community
  prepared$commercial_registry_audit <- registry_audit
  prepared
}

BuildPreparedAnalysisScope <- function(base_prepared, scope_id,
                                       commercial_species) {
  SetAnalysisScope(scope_id, commercial_species)
  analysis_data <- if (identical(scope_id, "community")) {
    base_prepared$eligible_community_data
  } else {
    base_prepared$eligible_community_data %>%
      dplyr::filter(.data$species_id %in% .env$commercial_species)
  }
  if (nrow(analysis_data) == 0L) {
    stop("No observations remain in scope ", scope_id, ".")
  }
  if (!setequal(unique(analysis_data$plot_id), kTargetPlots)) {
    stop("Scope ", scope_id, " does not contain exactly the six target plots.")
  }
  if (identical(scope_id, "commercial_group") &&
      any(!analysis_data$commercial_listed)) {
    stop("The commercially listed species scope contains a row absent from the embedded registry.")
  }
  continuity <- ValidateDiameterContinuity(analysis_data)
  result <- base_prepared
  result$data <- analysis_data
  result$continuity <- continuity$checks
  result$analysis_scope <- AnalysisScopeLabel()
  result$analysis_scope_id <- scope_id
  LogMessage(
    "INFO",
    sprintf(
      "Prepared scope '%s': %d intervals, %d trees, %d species and %d plots.",
      scope_id, nrow(analysis_data),
      dplyr::n_distinct(analysis_data$tree_id),
      dplyr::n_distinct(analysis_data$species_id),
      dplyr::n_distinct(analysis_data$plot_id)
    )
  )
  result
}

ValidatePreparedReconciliation <- function(raw_data, prepared) {
  data <- prepared$eligible_community_data
  observed <- c(
    input_rows = nrow(raw_data),
    rows_in_modeling_periods = sum(
      as.character(raw_data$period_pair) %in% kModelingPeriods
    ),
    eligible_community_intervals = nrow(data),
    eligible_community_unique_trees = dplyr::n_distinct(data$tree_id),
    zero_increments = sum(data$increment_cm == 0),
    high_annual_increments = sum(
      data$annual_increment_cm_yr > kHighAnnualIncrementAuditThreshold
    ),
    maximum_observed_dbh_cm = max(c(data$initial_dbh, data$dbh_final))
  )
  expected <- c(
    input_rows = kExpectedInputRows,
    rows_in_modeling_periods = kExpectedRowsInModelingPeriods,
    eligible_community_intervals = kExpectedAnalyticalIntervals,
    eligible_community_unique_trees = kExpectedUniqueTrees,
    zero_increments = kExpectedZeroIncrements,
    high_annual_increments = kExpectedHighAnnualIncrements,
    maximum_observed_dbh_cm = kExpectedMaximumObservedDbhCm
  )
  mismatch <- names(observed)[observed != expected]
  if (length(mismatch) > 0L) {
    details <- paste0(
      mismatch, " observed=", observed[mismatch], " expected=", expected[mismatch]
    )
    stop(
      "Dataset reconciliation failed: ", paste(details, collapse = "; "),
      ". Review and version any legitimate data change before model fitting."
    )
  }
  LogMessage("INFO", "All exact analytical-dataset reconciliation controls passed.")
  invisible(data.frame(item = names(observed), observed, expected))
}

ComputeBasalAreaScaler <- function(data) {
  plot_values <- data %>%
    dplyr::select(plot_id, basal_area_2013_m2_ha) %>%
    dplyr::distinct() %>%
    dplyr::arrange(plot_id)
  if (anyDuplicated(plot_values$plot_id) > 0L) {
    stop("A plot has more than one baseline basal-area value.")
  }
  center <- mean(plot_values$basal_area_2013_m2_ha)
  scale <- stats::sd(plot_values$basal_area_2013_m2_ha)
  if (!is.finite(scale) || scale <= 0) {
    stop("Training-plot basal area has zero or invalid variation.")
  }
  list(
    center = center,
    scale = scale,
    n_unique_training_plots = nrow(plot_values),
    training_plots = paste(plot_values$plot_id, collapse = ",")
  )
}

ApplyBasalAreaScaler <- function(data, scaler, uses_basal_area) {
  data %>%
    dplyr::mutate(
      basal_area_z = if (isTRUE(uses_basal_area)) {
        (basal_area_2013_m2_ha - scaler$center) / scaler$scale
      } else {
        0
      }
    )
}

# 5. STABLE EQUATIONS, BOUNDS, AND OBJECTIVES --------------------------------

ParameterNames <- function(specification, include_asymptote = TRUE) {
  names <- c("asymptote", "log_rate")
  if (isTRUE(specification$uses_basal_area)) {
    names <- c(names, "basal_area_log_rate_effect")
  }
  names <- c(names, "shape")
  if (!include_asymptote) {
    names <- setdiff(names, "asymptote")
  }
  names
}

ValidatePredictionDomainControl <- function(data) {
  maximum_initial_dbh <- max(data$initial_dbh)
  maximum_observed_dbh <- max(c(data$initial_dbh, data$dbh_final))
  valid <- all(is.finite(c(maximum_initial_dbh, maximum_observed_dbh))) &&
    kPredictionDomainAsymptoteFloorCm > maximum_observed_dbh &&
    kPredictionDomainAsymptoteFloorCm >
      max(kManagementScenarioInitialDbhCm) &&
    kAsymptoteUpper > kPredictionDomainAsymptoteFloorCm
  audit <- data.frame(
    analysis_scope = AnalysisScopeLabel(),
    maximum_initial_dbh_cm = maximum_initial_dbh,
    maximum_observed_initial_or_final_dbh_cm = maximum_observed_dbh,
    predeclared_asymptote_floor_cm = kPredictionDomainAsymptoteFloorCm,
    floor_margin_above_maximum_observed_dbh_cm =
      kPredictionDomainAsymptoteFloorCm - maximum_observed_dbh,
    maximum_scenario_start_dbh_cm = max(kManagementScenarioInitialDbhCm),
    common_fitted_asymptote_upper_cm = kAsymptoteUpper,
    status = ifelse(valid, "PASS", "FAIL"),
    interpretation = paste0(
      "full prespecified analysis domain checked before folds are constructed; ",
      "the bound is never adapted to an individual held-out fold"
    ),
    stringsAsFactors = FALSE
  )
  if (!valid) {
    stop(
      "The predeclared asymptote floor does not protect the complete ",
      "prediction domain. Review the versioned specification before fitting."
    )
  }
  audit
}

GetBounds <- function(specification, data, asymptote_upper = kAsymptoteUpper,
                      include_asymptote = TRUE) {
  if (!is.finite(kPredictionDomainAsymptoteFloorCm) ||
      kPredictionDomainAsymptoteFloorCm <=
        max(kManagementScenarioInitialDbhCm)) {
    stop(
      "The predeclared prediction-domain asymptote floor must exceed every ",
      "scenario starting DBH."
    )
  }
  lower_asymptote <- max(
    max(c(data$initial_dbh, data$dbh_final)) + 1e-3,
    kPredictionDomainAsymptoteFloorCm
  )
  if (lower_asymptote >= asymptote_upper) {
    stop(
      "The common asymptote upper bound must exceed the observed DBH and ",
      "the predeclared prediction-domain floor."
    )
  }
  shape_bounds <- if (specification$model_family == "Richards") {
    kRichardsShapeBounds
  } else {
    kLundqvistShapeBounds
  }
  lower <- c(
    asymptote = lower_asymptote,
    log_rate = kLogRateBounds[1]
  )
  upper <- c(
    asymptote = asymptote_upper,
    log_rate = kLogRateBounds[2]
  )
  if (isTRUE(specification$uses_basal_area)) {
    lower <- c(lower, basal_area_log_rate_effect = kBasalAreaEffectBounds[1])
    upper <- c(upper, basal_area_log_rate_effect = kBasalAreaEffectBounds[2])
  }
  lower <- c(lower, shape = shape_bounds[1])
  upper <- c(upper, shape = shape_bounds[2])
  if (!include_asymptote) {
    lower <- lower[names(lower) != "asymptote"]
    upper <- upper[names(upper) != "asymptote"]
  }
  list(lower = lower, upper = upper)
}

ExpandParameters <- function(parameters, specification, fixed_asymptote = NULL) {
  parameters <- as.numeric(parameters)
  names(parameters) <- ParameterNames(
    specification, include_asymptote = is.null(fixed_asymptote)
  )
  if (!is.null(fixed_asymptote)) {
    parameters <- c(asymptote = fixed_asymptote, parameters)
  }
  if (!"basal_area_log_rate_effect" %in% names(parameters)) {
    parameters <- append(
      parameters, c(basal_area_log_rate_effect = 0),
      after = match("log_rate", names(parameters))
    )
  }
  parameters[c(
    "asymptote", "log_rate", "basal_area_log_rate_effect", "shape"
  )]
}

PredictFromParameters <- function(parameters, data, specification,
                                  fixed_asymptote = NULL) {
  parameters <- ExpandParameters(parameters, specification, fixed_asymptote)
  if (!all(is.finite(parameters)) || any(!is.finite(data$basal_area_z))) {
    return(rep(NA_real_, nrow(data)))
  }
  asymptote <- unname(parameters["asymptote"])
  shape <- unname(parameters["shape"])
  ratio <- data$initial_dbh / asymptote
  linear_rate <- parameters["log_rate"] +
    parameters["basal_area_log_rate_effect"] * data$basal_area_z
  if (any(ratio <= 0 | ratio >= 1) || any(abs(linear_rate) > 700)) {
    return(rep(NA_real_, nrow(data)))
  }
  positive_rate <- exp(linear_rate)

  if (specification$model_family == "Richards") {
    if (shape <= 0 || shape >= 1 || abs(1 - shape) < 1e-8) {
      return(rep(NA_real_, nrow(data)))
    }
    inner <- 1 - ratio^(1 - shape)
    base <- 1 - exp(-positive_rate * data$interval_years_value) * inner
    if (any(inner < 0) || any(base <= 0)) {
      return(rep(NA_real_, nrow(data)))
    }
    prediction <- asymptote * base^(1 / (1 - shape))
  } else {
    if (shape <= 0) {
      return(rep(NA_real_, nrow(data)))
    }
    q <- (-1 / log(ratio))^(1 / shape)
    prediction <- asymptote * exp(-(q + positive_rate * data$interval_years_value)^(-shape))
  }
  if (!all(is.finite(prediction)) || any(prediction < data$initial_dbh - 1e-7)) {
    rep(NA_real_, nrow(data))
  } else {
    as.numeric(prediction)
  }
}

WeightedSseObjective <- function(parameters, data, specification,
                                 weights = NULL, fixed_asymptote = NULL) {
  if (is.null(weights)) {
    weights <- rep(1, nrow(data))
  }
  prediction <- PredictFromParameters(
    parameters, data, specification, fixed_asymptote = fixed_asymptote
  )
  if (anyNA(prediction) || any(!is.finite(weights)) || any(weights <= 0)) {
    return(1e100)
  }
  objective <- sum(weights * (data$dbh_final - prediction)^2)
  ifelse(is.finite(objective), objective, 1e100)
}

ComputeRobustResidualScale <- function(residuals) {
  residuals <- residuals[is.finite(residuals)]
  if (length(residuals) == 0L) {
    return(NA_real_)
  }
  center <- stats::median(residuals)
  scale <- 1.4826 * stats::median(abs(residuals - center))
  if (!is.finite(scale) || scale < kHuberMinimumScaleCm) {
    scale <- sqrt(mean(residuals^2))
  }
  if (!is.finite(scale)) NA_real_ else max(scale, kHuberMinimumScaleCm)
}

HuberLossObjective <- function(parameters, data, specification, fixed_scale,
                               tuning = kHuberTuningConstant,
                               fixed_asymptote = NULL) {
  if (!is.finite(fixed_scale) || fixed_scale <= 0 ||
      !is.finite(tuning) || tuning <= 0) {
    return(1e100)
  }
  prediction <- PredictFromParameters(
    parameters, data, specification, fixed_asymptote = fixed_asymptote
  )
  if (anyNA(prediction)) {
    return(1e100)
  }
  standardized <- (data$dbh_final - prediction) / fixed_scale
  absolute_standardized <- abs(standardized)
  rho <- ifelse(
    absolute_standardized <= tuning,
    0.5 * standardized^2,
    tuning * absolute_standardized - 0.5 * tuning^2
  )
  objective <- sum((fixed_scale^2) * rho)
  ifelse(is.finite(objective), objective, 1e100)
}

ModelFormula <- function(specification) {
  rate_term <- if (isTRUE(specification$uses_basal_area)) {
    "exp(log_rate + basal_area_log_rate_effect * basal_area_z)"
  } else {
    "exp(log_rate)"
  }
  formula_text <- if (specification$model_family == "Richards") {
    paste0(
      "dbh_final ~ asymptote * (1 - exp(-", rate_term,
      " * interval_years_value) * (1 - (initial_dbh / asymptote)^(1 - shape)))",
      "^(1 / (1 - shape))"
    )
  } else {
    paste0(
      "dbh_final ~ asymptote * exp(-(((-1 / log(initial_dbh / asymptote))",
      "^(1 / shape) + ", rate_term, " * interval_years_value)^(-shape)))"
    )
  }
  stats::as.formula(formula_text)
}

# 6. OPTIMIZATION AND ERROR-STRUCTURE SENSITIVITIES ---------------------------

RefineBoundedObjective <- function(specification, start, data, weights = NULL,
                                   asymptote_upper = kAsymptoteUpper,
                                   custom_objective = NULL,
                                   force_independent_methods = FALSE) {
  bounds <- GetBounds(specification, data, asymptote_upper = asymptote_upper)
  parameter_names <- names(bounds$lower)
  start <- as.numeric(start[parameter_names])
  names(start) <- parameter_names
  if (length(start) != length(parameter_names) || any(!is.finite(start))) {
    stop("The local-refinement start is incomplete or non-finite for ",
         specification$structural_id)
  }
  start <- pmin(pmax(start, bounds$lower), bounds$upper)
  if (is.null(weights)) {
    weights <- rep(1, nrow(data))
  }
  if (!is.null(custom_objective) && !is.function(custom_objective)) {
    stop("custom_objective must be NULL or a function.")
  }
  objective_function <- if (is.null(custom_objective)) {
    function(parameters) {
      WeightedSseObjective(parameters, data, specification, weights = weights)
    }
  } else {
    function(parameters) {
      value <- custom_objective(parameters)
      if (length(value) != 1L || !is.finite(value)) 1e100 else as.numeric(value)
    }
  }
  parameter_scale <- pmax(
    abs(start), (bounds$upper - bounds$lower) / 10, 1e-3
  )
  names(parameter_scale) <- parameter_names
  candidates <- list()
  diagnostics <- list()

  optim_result <- tryCatch(
    stats::optim(
      par = start,
      fn = objective_function,
      method = "L-BFGS-B",
      lower = bounds$lower,
      upper = bounds$upper,
      control = list(
        maxit = kLocalOptimMaxIterations,
        factr = kLocalOptimFactr,
        pgtol = kLocalOptimProjectedGradientTolerance,
        parscale = parameter_scale
      )
    ),
    error = function(error) error
  )
  if (inherits(optim_result, "error")) {
    diagnostics[["L-BFGS-B"]] <- data.frame(
      local_method = "L-BFGS-B", local_convergence_code = NA_integer_,
      local_optimizer_converged = FALSE, local_usable = FALSE,
      local_objective = NA_real_, local_iterations = NA_integer_,
      local_message = optim_result$message, stringsAsFactors = FALSE
    )
  } else {
    coefficients <- as.numeric(optim_result$par)
    names(coefficients) <- parameter_names
    prediction <- PredictFromParameters(coefficients, data, specification)
    objective <- objective_function(coefficients)
    usable <- all(is.finite(coefficients)) && all(is.finite(prediction)) &&
      is.finite(objective) && objective < 1e99
    converged <- isTRUE(optim_result$convergence == 0L) && usable
    message <- as.character(
      optim_result$message %||%
        if (converged) "L-BFGS-B convergence code 0" else
          paste("L-BFGS-B convergence code", optim_result$convergence)
    )
    diagnostics[["L-BFGS-B"]] <- data.frame(
      local_method = "L-BFGS-B",
      local_convergence_code = as.integer(optim_result$convergence),
      local_optimizer_converged = converged, local_usable = usable,
      local_objective = if (usable) objective else NA_real_,
      local_iterations = as.integer(
        unname(optim_result$counts[["function"]] %||% NA_integer_)
      ),
      local_message = message, stringsAsFactors = FALSE
    )
    if (usable) {
      candidates[["L-BFGS-B"]] <- list(
        method = "L-BFGS-B", coefficients = coefficients,
        objective = objective, converged = converged,
        convergence_code = as.integer(optim_result$convergence),
        iterations = as.integer(
          unname(optim_result$counts[["function"]] %||% NA_integer_)
        ),
        message = message
      )
    }
  }

  # nlminb is normally a recovery route. Robust-loss sensitivity forces both
  # bounded methods from the same OLS start so objective agreement is directly
  # auditable without claiming a second global search.
  run_fallback <- isTRUE(force_independent_methods) ||
    length(candidates) == 0L ||
    !isTRUE(candidates[["L-BFGS-B"]]$converged)
  if (run_fallback) {
    fallback_start <- if (isTRUE(force_independent_methods)) {
      start
    } else if (length(candidates) > 0L) {
      candidates[["L-BFGS-B"]]$coefficients
    } else {
      start
    }
    nlminb_result <- tryCatch(
      stats::nlminb(
        start = fallback_start,
        objective = objective_function,
        lower = bounds$lower,
        upper = bounds$upper,
        control = list(
          iter.max = kLocalOptimMaxIterations,
          eval.max = max(5000L, 5L * kLocalOptimMaxIterations),
          rel.tol = kLocalOptimRelativeTolerance,
          x.tol = 1e-8
        )
      ),
      error = function(error) error
    )
    if (inherits(nlminb_result, "error")) {
      diagnostics[["nlminb"]] <- data.frame(
        local_method = "nlminb", local_convergence_code = NA_integer_,
        local_optimizer_converged = FALSE, local_usable = FALSE,
        local_objective = NA_real_, local_iterations = NA_integer_,
        local_message = nlminb_result$message, stringsAsFactors = FALSE
      )
    } else {
      coefficients <- as.numeric(nlminb_result$par)
      names(coefficients) <- parameter_names
      prediction <- PredictFromParameters(coefficients, data, specification)
      objective <- objective_function(coefficients)
      usable <- all(is.finite(coefficients)) && all(is.finite(prediction)) &&
        is.finite(objective) && objective < 1e99
      converged <- isTRUE(nlminb_result$convergence == 0L) && usable
      message <- as.character(
        nlminb_result$message %||%
          if (converged) "nlminb convergence code 0" else
            paste("nlminb convergence code", nlminb_result$convergence)
      )
      diagnostics[["nlminb"]] <- data.frame(
        local_method = "nlminb",
        local_convergence_code = as.integer(nlminb_result$convergence),
        local_optimizer_converged = converged, local_usable = usable,
        local_objective = if (usable) objective else NA_real_,
        local_iterations = as.integer(nlminb_result$iterations %||% NA_integer_),
        local_message = message, stringsAsFactors = FALSE
      )
      if (usable) {
        candidates[["nlminb"]] <- list(
          method = "nlminb", coefficients = coefficients,
          objective = objective, converged = converged,
          convergence_code = as.integer(nlminb_result$convergence),
          iterations = as.integer(nlminb_result$iterations %||% NA_integer_),
          message = message
        )
      }
    }
  }

  diagnostics <- dplyr::bind_rows(diagnostics)
  if (length(candidates) == 0L) {
    messages <- unique(diagnostics$local_message)
    stop(
      "All bound-aware local refinements were unusable for ",
      specification$structural_id, ": ", paste(messages, collapse = " | ")
    )
  }
  converged_candidates <- which(vapply(
    candidates, function(candidate) isTRUE(candidate$converged), logical(1)
  ))
  eligible <- if (length(converged_candidates) > 0L) {
    converged_candidates
  } else {
    seq_along(candidates)
  }
  objectives <- vapply(
    candidates[eligible], function(candidate) candidate$objective, numeric(1)
  )
  best <- candidates[[eligible[which.min(objectives)]]]
  diagnostics$selected <- diagnostics$local_method == best$method
  best$diagnostics <- diagnostics
  best
}

AssessOlsOptimizationAcceptance <- function(trace) {
  required <- c(
    "local_method", "local_optimizer_converged", "local_usable",
    "local_objective", "de_objective", "selected"
  )
  missing <- setdiff(required, names(trace))
  if (length(missing) > 0L || nrow(trace) == 0L) {
    return(list(
      accepted = FALSE,
      basis = paste0(
        "missing optimizer diagnostics",
        if (length(missing) > 0L) paste0(": ", paste(missing, collapse = ", "))
        else ""
      ),
      formal_local_convergence = FALSE,
      independent_usable_methods = 0L,
      local_objective_relative_spread = Inf,
      selected_relative_change_from_DE = Inf
    ))
  }

  selected <- trace[!is.na(trace$selected) & trace$selected %in% TRUE, , drop = FALSE]
  usable <- trace[
    !is.na(trace$local_usable) & trace$local_usable %in% TRUE &
      is.finite(trace$local_objective),
    , drop = FALSE
  ]
  selected_valid <- nrow(selected) == 1L &&
    isTRUE(selected$local_usable[1]) &&
    is.finite(selected$local_objective[1]) &&
    is.finite(selected$de_objective[1])
  if (!selected_valid) {
    return(list(
      accepted = FALSE, basis = "selected OLS solution is absent or unusable",
      formal_local_convergence = FALSE,
      independent_usable_methods = length(unique(usable$local_method)),
      local_objective_relative_spread = Inf,
      selected_relative_change_from_DE = Inf
    ))
  }

  method_count <- length(unique(usable$local_method))
  objective_scale <- max(1, min(abs(usable$local_objective)))
  objective_spread <- if (nrow(usable) > 1L) {
    diff(range(usable$local_objective)) / objective_scale
  } else {
    0
  }
  selected_objective <- selected$local_objective[1]
  de_objective <- selected$de_objective[1]
  selected_change_from_de <- (selected_objective - de_objective) /
    max(1, abs(de_objective))
  selected_excess_over_de <- max(0, selected_change_from_de)
  formal_convergence <- isTRUE(selected$local_optimizer_converged[1])
  objective_agreement <-
    method_count >= kMinimumIndependentUsableLocalMethods &&
    is.finite(objective_spread) &&
    objective_spread <= kOptimizerObjectiveAgreementTolerance &&
    is.finite(selected_excess_over_de) &&
    selected_excess_over_de <= kOptimizerObjectiveAgreementTolerance
  accepted <- formal_convergence || objective_agreement
  basis <- if (formal_convergence) {
    "formal bounded-local convergence after global DE search"
  } else if (objective_agreement) {
    paste0(
      "accepted boundary/global optimum: ", method_count,
      " independent bounded local methods and DE agree within relative tolerance ",
      format(kOptimizerObjectiveAgreementTolerance, scientific = TRUE)
    )
  } else {
    "neither formal local convergence nor independent objective agreement"
  }
  list(
    accepted = accepted,
    basis = basis,
    formal_local_convergence = formal_convergence,
    independent_usable_methods = method_count,
    local_objective_relative_spread = objective_spread,
    selected_relative_change_from_DE = selected_change_from_de
  )
}

AssessHuberOptimizationAcceptance <- function(trace) {
  required <- c(
    "local_method", "local_optimizer_converged", "local_usable",
    "local_objective", "selected"
  )
  missing <- setdiff(required, names(trace))
  if (length(missing) > 0L || nrow(trace) == 0L) {
    return(list(
      accepted = FALSE,
      basis = paste0(
        "missing Huber optimizer diagnostics",
        if (length(missing) > 0L) paste0(": ", paste(missing, collapse = ", "))
        else ""
      ),
      formal_local_convergence = FALSE,
      independent_usable_methods = 0L,
      local_objective_relative_spread = Inf,
      selected_relative_change_from_DE = NA_real_
    ))
  }
  selected <- trace[
    !is.na(trace$selected) & trace$selected %in% TRUE, , drop = FALSE
  ]
  usable <- trace[
    !is.na(trace$local_usable) & trace$local_usable %in% TRUE &
      is.finite(trace$local_objective), , drop = FALSE
  ]
  selected_valid <- nrow(selected) == 1L &&
    isTRUE(selected$local_usable[1]) &&
    is.finite(selected$local_objective[1])
  if (!selected_valid) {
    return(list(
      accepted = FALSE,
      basis = "selected direct Huber solution is absent or unusable",
      formal_local_convergence = FALSE,
      independent_usable_methods = length(unique(usable$local_method)),
      local_objective_relative_spread = Inf,
      selected_relative_change_from_DE = NA_real_
    ))
  }
  method_count <- length(unique(usable$local_method))
  objective_scale <- max(1, min(abs(usable$local_objective)))
  objective_spread <- if (nrow(usable) > 1L) {
    diff(range(usable$local_objective)) / objective_scale
  } else {
    0
  }
  formal_convergence <- isTRUE(selected$local_optimizer_converged[1])
  objective_agreement <-
    method_count >= kMinimumIndependentUsableLocalMethods &&
    is.finite(objective_spread) &&
    objective_spread <= kOptimizerObjectiveAgreementTolerance
  accepted <- formal_convergence || objective_agreement
  basis <- if (formal_convergence) {
    "formal direct Huber bounded-local convergence from accepted OLS start"
  } else if (objective_agreement) {
    paste0(
      "direct Huber sensitivity accepted: ", method_count,
      " independent bounded local methods agree within relative tolerance ",
      format(kOptimizerObjectiveAgreementTolerance, scientific = TRUE)
    )
  } else {
    "direct Huber sensitivity lacks formal convergence and objective agreement"
  }
  list(
    accepted = accepted,
    basis = basis,
    formal_local_convergence = formal_convergence,
    independent_usable_methods = method_count,
    local_objective_relative_spread = objective_spread,
    selected_relative_change_from_DE = NA_real_
  )
}

FitOlsGlobal <- function(raw_training_data, specification, seeds,
                         de_itermax, de_np,
                         asymptote_upper = kAsymptoteUpper) {
  scaler <- ComputeBasalAreaScaler(raw_training_data)
  data <- ApplyBasalAreaScaler(
    raw_training_data, scaler, specification$uses_basal_area
  )
  bounds <- GetBounds(specification, data, asymptote_upper = asymptote_upper)
  attempts <- vector("list", length(seeds))
  candidate_refinements <- vector("list", length(seeds))

  for (index in seq_along(seeds)) {
    seed <- as.integer(seeds[index])
    set.seed(seed)
    global_result <- tryCatch(
      DEoptim::DEoptim(
        fn = function(parameters) {
          WeightedSseObjective(parameters, data, specification)
        },
        lower = bounds$lower,
        upper = bounds$upper,
        control = DEoptim::DEoptim.control(
          itermax = de_itermax,
          NP = de_np,
          F = kDeF,
          CR = kDeCr,
          trace = FALSE,
          storepopfrom = de_itermax + 1L
        )
      ),
      error = function(error) error
    )
    if (inherits(global_result, "error")) {
      attempts[[index]] <- data.frame(
        attempt_index = index, stage = "global_search", seed = seed,
        de_objective = NA_real_, local_method = NA_character_,
        local_convergence_code = NA_integer_,
        local_optimizer_converged = FALSE, local_usable = FALSE,
        local_objective = NA_real_, refined_unweighted_sse = NA_real_,
        local_iterations = NA_integer_, iterations = NA_integer_,
        local_message = global_result$message, message = global_result$message,
        stringsAsFactors = FALSE
      )
      next
    }

    start <- global_result$optim$bestmem
    names(start) <- names(bounds$lower)
    local_refinement <- tryCatch(
      RefineBoundedObjective(
        specification, start, data, asymptote_upper = asymptote_upper
      ),
      error = function(error) error
    )
    if (inherits(local_refinement, "error")) {
      attempts[[index]] <- data.frame(
        attempt_index = index, stage = "bounded_local_refinement", seed = seed,
        de_objective = global_result$optim$bestval,
        local_method = NA_character_, local_convergence_code = NA_integer_,
        local_optimizer_converged = FALSE, local_usable = FALSE,
        local_objective = NA_real_, refined_unweighted_sse = NA_real_,
        local_iterations = NA_integer_, iterations = NA_integer_,
        local_message = local_refinement$message,
        message = local_refinement$message,
        stringsAsFactors = FALSE
      )
      next
    }
    local_trace <- local_refinement$diagnostics
    local_trace$attempt_index <- index
    local_trace$stage <- "bounded_local_refinement"
    local_trace$seed <- seed
    local_trace$de_objective <- global_result$optim$bestval
    local_trace$refined_unweighted_sse <- local_trace$local_objective
    local_trace$converged <- local_trace$local_optimizer_converged
    local_trace$iterations <- local_trace$local_iterations
    local_trace$message <- local_trace$local_message
    attempts[[index]] <- local_trace
    candidate_refinements[[index]] <- local_refinement
  }

  trace <- dplyr::bind_rows(attempts)
  valid <- which(vapply(
    candidate_refinements, function(refinement) !is.null(refinement), logical(1)
  ))
  if (length(valid) == 0L) {
    messages <- unique(trace$message[!is.na(trace$message) & nzchar(trace$message)])
    stop(
      "All global/local attempts failed for ", specification$structural_id,
      if (length(messages) > 0L) paste0(": ", paste(messages, collapse = " | "))
      else ""
    )
  }
  attempt_acceptance <- lapply(valid, function(index) {
    AssessOlsOptimizationAcceptance(
      trace[trace$attempt_index == index, , drop = FALSE]
    )
  })
  accepted_valid <- valid[vapply(
    attempt_acceptance, function(assessment) isTRUE(assessment$accepted),
    logical(1)
  )]
  if (length(accepted_valid) == 0L) {
    bases <- unique(vapply(
      attempt_acceptance, `[[`, character(1), "basis"
    ))
    stop(
      "No OLS global/local attempt met the objective-agreement acceptance rule for ",
      specification$structural_id, ": ", paste(bases, collapse = " | ")
    )
  }
  eligible_valid <- accepted_valid
  eligible_sse <- vapply(
    eligible_valid,
    function(index) candidate_refinements[[index]]$objective,
    numeric(1)
  )
  best_index <- eligible_valid[which.min(eligible_sse)]
  best_refinement <- candidate_refinements[[best_index]]
  coefficients <- best_refinement$coefficients
  trace$selected <- trace$attempt_index == best_index &
    trace$local_method == best_refinement$method
  best_acceptance <- AssessOlsOptimizationAcceptance(
    trace[trace$attempt_index == best_index, , drop = FALSE]
  )
  if (!isTRUE(best_acceptance$accepted)) {
    stop("Internal optimizer-acceptance inconsistency for ",
         specification$structural_id)
  }

  list(
    structural_id = specification$structural_id,
    model_family = specification$model_family,
    uses_basal_area = specification$uses_basal_area,
    estimator = "OLS",
    coefficients = coefficients,
    scaler = scaler,
    local_refinement = best_refinement,
    training_weights = rep(1, nrow(data)),
    training_data = data,
    unweighted_sse = best_refinement$objective,
    weighted_objective = best_refinement$objective,
    optimization_trace = trace,
    weighting_trace = data.frame(),
    irls_converged = NA,
    converged = isTRUE(best_refinement$converged),
    convergence_message = best_refinement$message,
    optimization_solution_accepted = best_acceptance$accepted,
    optimization_acceptance_basis = best_acceptance$basis,
    independent_usable_local_methods =
      best_acceptance$independent_usable_methods,
    local_objective_relative_spread =
      best_acceptance$local_objective_relative_spread,
    selected_relative_change_from_DE =
      best_acceptance$selected_relative_change_from_DE
  )
}

ParameterRelativeDifference <- function(new_parameters, old_parameters) {
  names_new <- sort(names(new_parameters))
  names_old <- sort(names(old_parameters))
  if (!identical(names_new, names_old)) {
    return(Inf)
  }
  new_parameters <- new_parameters[names_old]
  old_parameters <- old_parameters[names_old]
  max(abs(new_parameters - old_parameters) / pmax(1, abs(old_parameters)))
}

FitHuberSensitivity <- function(ols_fit, specification) {
  if (!isTRUE(ols_fit$optimization_solution_accepted %||% ols_fit$converged)) {
    stop("Direct Huber sensitivity requires an accepted OLS starting fit.")
  }
  data <- ols_fit$training_data
  ols_prediction <- PredictFromParameters(
    ols_fit$coefficients, data, specification
  )
  fixed_scale <- ComputeRobustResidualScale(data$dbh_final - ols_prediction)
  if (!is.finite(fixed_scale) || fixed_scale <= 0) {
    stop("Could not estimate a finite fixed residual scale for Huber sensitivity.")
  }
  huber_objective <- function(parameters) {
    HuberLossObjective(
      parameters, data, specification, fixed_scale = fixed_scale,
      tuning = kHuberTuningConstant
    )
  }
  refinement <- RefineBoundedObjective(
    specification = specification,
    start = ols_fit$coefficients,
    data = data,
    custom_objective = huber_objective,
    force_independent_methods = TRUE
  )
  trace <- refinement$diagnostics
  trace$attempt_index <- 1L
  trace$stage <- "direct_Huber_M_estimation"
  trace$seed <- NA_integer_
  trace$de_objective <- NA_real_
  trace$refined_unweighted_sse <- NA_real_
  trace$converged <- trace$local_optimizer_converged
  trace$iterations <- trace$local_iterations
  trace$message <- trace$local_message
  assessment <- AssessHuberOptimizationAcceptance(trace)
  if (!isTRUE(assessment$accepted)) {
    stop(
      "Direct Huber sensitivity did not meet the bounded-optimization ",
      "acceptance rule for ", specification$structural_id, ": ",
      assessment$basis
    )
  }

  prediction <- PredictFromParameters(
    refinement$coefficients, data, specification
  )
  if (any(!is.finite(prediction))) {
    stop("Direct Huber sensitivity produced non-finite training predictions.")
  }
  residual <- data$dbh_final - prediction
  standardized <- residual / fixed_scale
  absolute_standardized <- abs(standardized)
  influence_weights <- ifelse(
    absolute_standardized <= kHuberTuningConstant,
    1,
    kHuberTuningConstant / pmax(absolute_standardized, .Machine$double.eps)
  )
  unweighted_sse <- sum(residual^2)
  trace$refined_unweighted_sse[trace$selected %in% TRUE] <- unweighted_sse

  result <- ols_fit
  result$estimator <- "Huber"
  result$coefficients <- refinement$coefficients
  result$local_refinement <- refinement
  result$training_weights <- influence_weights
  result$unweighted_sse <- unweighted_sse
  result$weighted_objective <- huber_objective(refinement$coefficients)
  result$optimization_trace <- trace
  result$weighting_trace <- data.frame(
    stage = "Huber_fixed_OLS_scale",
    iteration = 1L,
    converged = assessment$accepted,
    parameter_change = ParameterRelativeDifference(
      refinement$coefficients, ols_fit$coefficients
    ),
    scale = fixed_scale,
    huber_tuning_constant = kHuberTuningConstant,
    downweighted_observations = sum(
      absolute_standardized > kHuberTuningConstant
    ),
    downweighted_fraction = mean(
      absolute_standardized > kHuberTuningConstant
    ),
    maximum_absolute_standardized_residual = max(absolute_standardized),
    message = assessment$basis,
    stringsAsFactors = FALSE
  )
  result$irls_converged <- NA
  result$converged <- isTRUE(refinement$converged)
  result$convergence_message <- paste(refinement$message, assessment$basis, sep = "; ")
  result$optimization_solution_accepted <- assessment$accepted
  result$optimization_acceptance_basis <- assessment$basis
  result$independent_usable_local_methods <-
    assessment$independent_usable_methods
  result$local_objective_relative_spread <-
    assessment$local_objective_relative_spread
  result$selected_relative_change_from_DE <- NA_real_
  result$huber_fixed_scale_cm <- fixed_scale
  result$huber_tuning_constant <- kHuberTuningConstant
  result
}

FitFglsSensitivity <- function(ols_fit, specification) {
  data <- ols_fit$training_data
  current_refinement <- ols_fit$local_refinement
  current_parameters <- ols_fit$coefficients
  final_weights <- rep(1, nrow(data))
  trace <- vector("list", kFglsMaxIterations)
  variance_coefficients <- c(
    variance_intercept = NA_real_, variance_log_predicted_dbh = NA_real_,
    variance_log_interval_years = NA_real_
  )
  successful_iterations <- 0L
  irls_converged <- FALSE

  for (iteration in seq_len(kFglsMaxIterations)) {
    prediction <- PredictFromParameters(current_parameters, data, specification)
    residual <- data$dbh_final - prediction
    epsilon <- max(stats::median(residual^2) * 1e-6, 1e-8)
    variance_data <- data.frame(
      log_squared_residual = log(pmax(residual^2, epsilon)),
      log_predicted_dbh = log(pmax(prediction, 1e-6)),
      log_interval_years = log(data$interval_years_value)
    )
    variance_model <- stats::lm(
      log_squared_residual ~ log_predicted_dbh + log_interval_years,
      data = variance_data
    )
    log_variance <- as.numeric(stats::predict(variance_model, newdata = variance_data))
    limits <- stats::quantile(log_variance, probs = c(0.01, 0.99), na.rm = TRUE)
    log_variance <- pmin(pmax(log_variance, limits[1]), limits[2])
    new_weights <- exp(-log_variance)
    new_weights <- new_weights / mean(new_weights)
    refined <- tryCatch(
      RefineBoundedObjective(
        specification, current_parameters, data, weights = new_weights
      ),
      error = function(error) error
    )
    if (inherits(refined, "error")) {
      trace[[iteration]] <- data.frame(
        stage = "FGLS_IRLS", iteration = iteration, converged = FALSE,
        parameter_change = NA_real_, scale = NA_real_,
        variance_intercept = NA_real_, variance_log_predicted_dbh = NA_real_,
        variance_log_interval_years = NA_real_, message = refined$message,
        stringsAsFactors = FALSE
      )
      break
    }
    new_parameters <- refined$coefficients
    change <- ParameterRelativeDifference(new_parameters, current_parameters)
    coefficients <- stats::coef(variance_model)
    variance_coefficients <- c(
      variance_intercept = unname(coefficients["(Intercept)"]),
      variance_log_predicted_dbh = unname(coefficients["log_predicted_dbh"]),
      variance_log_interval_years = unname(coefficients["log_interval_years"])
    )
    trace[[iteration]] <- data.frame(
      stage = "FGLS_IRLS", iteration = iteration,
      converged = isTRUE(change < kIrlsConvergenceTolerance),
      parameter_change = change, scale = NA_real_,
      variance_intercept = variance_coefficients[1],
      variance_log_predicted_dbh = variance_coefficients[2],
      variance_log_interval_years = variance_coefficients[3],
      local_method = refined$method,
      local_convergence_code = refined$convergence_code,
      local_optimizer_converged = refined$converged,
      message = refined$message,
      stringsAsFactors = FALSE
    )
    current_refinement <- refined
    current_parameters <- new_parameters
    final_weights <- new_weights
    successful_iterations <- successful_iterations + 1L
    if (change < kIrlsConvergenceTolerance) {
      irls_converged <- TRUE
      break
    }
  }

  if (successful_iterations == 0L) {
    stop("FGLS sensitivity failed before completing one weighted refinement.")
  }
  if (!isTRUE(irls_converged)) {
    stop(
      "FGLS sensitivity did not satisfy the IRLS convergence tolerance after ",
      successful_iterations, " successful refinements."
    )
  }
  if (!isTRUE(current_refinement$converged)) {
    stop("FGLS sensitivity ended without formal bounded-local convergence.")
  }

  prediction <- PredictFromParameters(current_parameters, data, specification)
  result <- ols_fit
  result$estimator <- "FGLS"
  result$coefficients <- current_parameters
  result$local_refinement <- current_refinement
  result$training_weights <- final_weights
  result$unweighted_sse <- sum((data$dbh_final - prediction)^2)
  result$weighted_objective <- sum(final_weights * (data$dbh_final - prediction)^2)
  result$optimization_trace <- data.frame()
  result$weighting_trace <- dplyr::bind_rows(trace)
  result$variance_coefficients <- variance_coefficients
  result$irls_converged <- irls_converged
  result$converged <- isTRUE(current_refinement$converged)
  result$optimization_solution_accepted <- isTRUE(current_refinement$converged)
  result$optimization_acceptance_basis <- if (result$converged) {
    "formal bounded-local convergence in final FGLS iteration"
  } else {
    "sensitivity estimate retained with a local-optimizer convergence warning"
  }
  result$independent_usable_local_methods <- NA_integer_
  result$local_objective_relative_spread <- NA_real_
  result$selected_relative_change_from_DE <- NA_real_
  result$convergence_message <- paste0(
    current_refinement$message,
    if (irls_converged) "; FGLS IRLS converged" else
      "; FGLS IRLS reached the iteration limit"
  )
  result
}

FitStudentTSensitivity <- function(ols_fit, specification) {
  data <- ols_fit$training_data
  current_refinement <- ols_fit$local_refinement
  current_parameters <- ols_fit$coefficients
  final_weights <- rep(1, nrow(data))
  trace <- vector("list", kStudentTMaxIterations)
  final_scale <- NA_real_
  successful_iterations <- 0L
  irls_converged <- FALSE

  for (iteration in seq_len(kStudentTMaxIterations)) {
    prediction <- PredictFromParameters(current_parameters, data, specification)
    residual <- data$dbh_final - prediction
    robust_scale <- 1.4826 * stats::median(abs(residual - stats::median(residual)))
    if (!is.finite(robust_scale) || robust_scale <= 1e-8) {
      robust_scale <- sqrt(mean(residual^2))
    }
    standardized <- residual / max(robust_scale, 1e-8)
    new_weights <- (kStudentTDegreesFreedom + 1) /
      (kStudentTDegreesFreedom + standardized^2)
    new_weights <- new_weights / mean(new_weights)
    refined <- tryCatch(
      RefineBoundedObjective(
        specification, current_parameters, data, weights = new_weights
      ),
      error = function(error) error
    )
    if (inherits(refined, "error")) {
      trace[[iteration]] <- data.frame(
        stage = "Student_t_IRLS", iteration = iteration, converged = FALSE,
        parameter_change = NA_real_, scale = robust_scale,
        degrees_freedom = kStudentTDegreesFreedom,
        message = refined$message, stringsAsFactors = FALSE
      )
      break
    }
    new_parameters <- refined$coefficients
    change <- ParameterRelativeDifference(new_parameters, current_parameters)
    trace[[iteration]] <- data.frame(
      stage = "Student_t_IRLS", iteration = iteration,
      converged = isTRUE(change < kIrlsConvergenceTolerance),
      parameter_change = change, scale = robust_scale,
      degrees_freedom = kStudentTDegreesFreedom,
      local_method = refined$method,
      local_convergence_code = refined$convergence_code,
      local_optimizer_converged = refined$converged,
      message = refined$message,
      stringsAsFactors = FALSE
    )
    current_refinement <- refined
    current_parameters <- new_parameters
    final_weights <- new_weights
    final_scale <- robust_scale
    successful_iterations <- successful_iterations + 1L
    if (change < kIrlsConvergenceTolerance) {
      irls_converged <- TRUE
      break
    }
  }

  if (successful_iterations == 0L) {
    stop("Student-t sensitivity failed before completing one weighted refinement.")
  }
  if (!isTRUE(irls_converged)) {
    stop(
      "Student-t sensitivity did not satisfy the IRLS convergence tolerance after ",
      successful_iterations, " successful refinements."
    )
  }
  if (!isTRUE(current_refinement$converged)) {
    stop("Student-t sensitivity ended without formal bounded-local convergence.")
  }

  prediction <- PredictFromParameters(current_parameters, data, specification)
  result <- ols_fit
  result$estimator <- "Student_t"
  result$coefficients <- current_parameters
  result$local_refinement <- current_refinement
  result$training_weights <- final_weights
  result$unweighted_sse <- sum((data$dbh_final - prediction)^2)
  result$weighted_objective <- sum(final_weights * (data$dbh_final - prediction)^2)
  result$optimization_trace <- data.frame()
  result$weighting_trace <- dplyr::bind_rows(trace)
  result$student_t_scale <- final_scale
  result$student_t_degrees_freedom <- kStudentTDegreesFreedom
  result$irls_converged <- irls_converged
  result$converged <- isTRUE(current_refinement$converged)
  result$optimization_solution_accepted <- isTRUE(current_refinement$converged)
  result$optimization_acceptance_basis <- if (result$converged) {
    "formal bounded-local convergence in final Student-t iteration"
  } else {
    "sensitivity estimate retained with a local-optimizer convergence warning"
  }
  result$independent_usable_local_methods <- NA_integer_
  result$local_objective_relative_spread <- NA_real_
  result$selected_relative_change_from_DE <- NA_real_
  result$convergence_message <- paste0(
    current_refinement$message,
    if (irls_converged) "; Student-t IRLS converged" else
      "; Student-t IRLS reached the iteration limit"
  )
  result
}

AnnotateValidationPayloadAcceptance <- function(payload) {
  if (!is.list(payload) || !is.data.frame(payload$fold_summary) ||
      !is.data.frame(payload$optimizer_diagnostics)) {
    return(payload)
  }
  summary <- payload$fold_summary
  summary$optimization_solution_accepted <- NA
  summary$optimization_acceptance_basis <- NA_character_
  summary$independent_usable_local_methods <- NA_integer_
  summary$local_objective_relative_spread <- NA_real_
  summary$selected_relative_change_from_DE <- NA_real_
  if (!"local_optimizer_converged" %in% names(summary)) {
    summary$local_optimizer_converged <- NA
  }
  diagnostic_keys <- c("scheme", "fold_id", "structural_id", "estimator")

  ols_rows <- which(summary$estimator == "OLS")
  for (row_index in ols_rows) {
    row <- summary[row_index, , drop = FALSE]
    trace <- if (all(diagnostic_keys %in% names(payload$optimizer_diagnostics))) {
      diagnostics <- payload$optimizer_diagnostics
      diagnostics[
        diagnostics$scheme == row$scheme[1] &
          diagnostics$fold_id == row$fold_id[1] &
          diagnostics$structural_id == row$structural_id[1] &
          diagnostics$estimator == "OLS",
        , drop = FALSE
      ]
    } else {
      data.frame()
    }
    assessment <- AssessOlsOptimizationAcceptance(trace)
    accepted <- isTRUE(as.character(row$status[1]) == "success") &&
      isTRUE(assessment$accepted)
    summary$optimization_solution_accepted[row_index] <- accepted
    summary$optimization_acceptance_basis[row_index] <- assessment$basis
    summary$independent_usable_local_methods[row_index] <-
      assessment$independent_usable_methods
    summary$local_objective_relative_spread[row_index] <-
      assessment$local_objective_relative_spread
    summary$selected_relative_change_from_DE[row_index] <-
      assessment$selected_relative_change_from_DE
  }

  huber_rows <- which(summary$estimator == "Huber")
  for (row_index in huber_rows) {
    row <- summary[row_index, , drop = FALSE]
    trace <- if (all(diagnostic_keys %in% names(payload$optimizer_diagnostics))) {
      diagnostics <- payload$optimizer_diagnostics
      diagnostics[
        diagnostics$scheme == row$scheme[1] &
          diagnostics$fold_id == row$fold_id[1] &
          diagnostics$structural_id == row$structural_id[1] &
          diagnostics$estimator == "Huber",
        , drop = FALSE
      ]
    } else {
      data.frame()
    }
    assessment <- AssessHuberOptimizationAcceptance(trace)
    accepted <- isTRUE(as.character(row$status[1]) == "success") &&
      isTRUE(assessment$accepted)
    summary$optimization_solution_accepted[row_index] <- accepted
    summary$optimization_acceptance_basis[row_index] <- assessment$basis
    summary$independent_usable_local_methods[row_index] <-
      assessment$independent_usable_methods
    summary$local_objective_relative_spread[row_index] <-
      assessment$local_objective_relative_spread
    summary$selected_relative_change_from_DE[row_index] <- NA_real_
  }

  sensitivity_rows <- which(summary$estimator %in% c("FGLS", "Student_t"))
  if (length(sensitivity_rows) > 0L) {
    summary$optimization_solution_accepted[sensitivity_rows] <-
      summary$status[sensitivity_rows] == "success" &
      summary$local_optimizer_converged[sensitivity_rows] %in% TRUE
    summary$optimization_acceptance_basis[sensitivity_rows] <- ifelse(
      summary$optimization_solution_accepted[sensitivity_rows] %in% TRUE,
      "formal bounded-local convergence in final sensitivity iteration",
      "sensitivity estimate retained with a local-optimizer convergence warning"
    )
  }
  payload$fold_summary <- summary
  payload
}

ReadCompatibleCache <- function(path, signature) {
  if (kForceRefit || !file.exists(path)) {
    return(NULL)
  }
  object <- tryCatch(readRDS(path), error = function(error) NULL)
  if (is.list(object) && identical(object$signature, signature)) {
    return(AnnotateValidationPayloadAcceptance(object$payload))
  }
  # Cached objects are reusable only under an identical analytical signature.
  NULL
}

WriteCache <- function(path, signature, payload) {
  dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
  saveRDS(
    list(
      signature = signature,
      model_specification_version = kModelSpecVersion,
      saved_at = Sys.time(),
      payload = payload
    ),
    path
  )
  invisible(path)
}

# 7. PREDICTIONS, METRICS, COEFFICIENTS, AND IDENTIFIABILITY -----------------

ComputePredictionMetrics <- function(observed_final, predicted_final,
                                     initial_dbh, interval_years) {
  keep <- is.finite(observed_final) & is.finite(predicted_final) &
    is.finite(initial_dbh) & is.finite(interval_years) & interval_years > 0
  observed_final <- observed_final[keep]
  predicted_final <- predicted_final[keep]
  initial_dbh <- initial_dbh[keep]
  interval_years <- interval_years[keep]
  if (length(observed_final) == 0L) {
    return(data.frame(
      n = 0L, RMSE_final_cm = NA_real_, MAE_final_cm = NA_real_,
      mean_error_final_cm = NA_real_, predictive_R2 = NA_real_,
      modeling_efficiency_increment = NA_real_, RMSE_increment_cm = NA_real_,
      MAE_increment_cm = NA_real_, RMSE_annualized_cm_yr = NA_real_,
      MAE_annualized_cm_yr = NA_real_
    ))
  }
  residual <- observed_final - predicted_final
  observed_increment <- observed_final - initial_dbh
  predicted_increment <- predicted_final - initial_dbh
  increment_denominator <- sum((observed_increment - mean(observed_increment))^2)
  predictive_r2 <- if (length(observed_final) > 1L &&
      stats::sd(observed_final) > 0 && stats::sd(predicted_final) > 0) {
    stats::cor(observed_final, predicted_final)^2
  } else {
    NA_real_
  }
  data.frame(
    n = length(observed_final),
    RMSE_final_cm = sqrt(mean(residual^2)),
    MAE_final_cm = mean(abs(residual)),
    mean_error_final_cm = mean(residual),
    predictive_R2 = predictive_r2,
    modeling_efficiency_increment = if (increment_denominator > 0) {
      1 - sum((observed_increment - predicted_increment)^2) / increment_denominator
    } else {
      NA_real_
    },
    RMSE_increment_cm = sqrt(mean((observed_increment - predicted_increment)^2)),
    MAE_increment_cm = mean(abs(observed_increment - predicted_increment)),
    RMSE_annualized_cm_yr = sqrt(mean((residual / interval_years)^2)),
    MAE_annualized_cm_yr = mean(abs(residual / interval_years))
  )
}

ColumnOrDefault <- function(data, column, default) {
  if (column %in% names(data)) data[[column]] else rep(default, nrow(data))
}

BuildPredictionRows <- function(fit, raw_data, scheme, fold_id) {
  specification <- GetSpecification(fit$structural_id)
  data <- ApplyBasalAreaScaler(
    raw_data, fit$scaler, specification$uses_basal_area
  )
  prediction <- PredictFromParameters(fit$coefficients, data, specification)
  data.frame(
    scheme = scheme,
    fold_id = as.character(fold_id),
    structural_id = fit$structural_id,
    model_family = fit$model_family,
    uses_basal_area = fit$uses_basal_area,
    estimator = fit$estimator,
    analysis_row_id = data$analysis_row_id,
    plot_id = data$plot_id,
    tree_id = data$tree_id,
    genus_name = data$genus_name,
    specific_epithet = data$specific_epithet,
    species_id = data$species_id,
    taxon_identified = data$taxon_identified,
    commercial_listed = ColumnOrDefault(data, "commercial_listed", FALSE),
    commercial_permission_class = ColumnOrDefault(
      data, "commercial_permission_class", "not_listed"
    ),
    commercial_registry_conflict = ColumnOrDefault(
      data, "commercial_registry_conflict", FALSE
    ),
    commercial_legal_basis = ColumnOrDefault(
      data, "commercial_legal_basis", "not available"
    ),
    period_label = data$period_label,
    period_order = data$period_order,
    interval_years = data$interval_years_value,
    basal_area_2013_m2_ha = data$basal_area_2013_m2_ha,
    basal_area_z_training_scaler = data$basal_area_z,
    initial_dbh_cm = data$initial_dbh,
    observed_final_dbh_cm = data$dbh_final,
    predicted_final_dbh_cm = prediction,
    observed_increment_cm = data$dbh_final - data$initial_dbh,
    predicted_increment_cm = prediction - data$initial_dbh,
    residual_cm = data$dbh_final - prediction,
    annualized_residual_cm_yr = (data$dbh_final - prediction) / data$interval_years_value,
    stringsAsFactors = FALSE
  )
}

BuildPersistenceRows <- function(raw_data, scheme, fold_id) {
  data.frame(
    scheme = scheme,
    fold_id = as.character(fold_id),
    structural_id = "Persistence",
    model_family = "Persistence",
    uses_basal_area = FALSE,
    estimator = "Persistence",
    analysis_row_id = raw_data$analysis_row_id,
    plot_id = raw_data$plot_id,
    tree_id = raw_data$tree_id,
    genus_name = raw_data$genus_name,
    specific_epithet = raw_data$specific_epithet,
    species_id = raw_data$species_id,
    taxon_identified = raw_data$taxon_identified,
    commercial_listed = ColumnOrDefault(raw_data, "commercial_listed", FALSE),
    commercial_permission_class = ColumnOrDefault(
      raw_data, "commercial_permission_class", "not_listed"
    ),
    commercial_registry_conflict = ColumnOrDefault(
      raw_data, "commercial_registry_conflict", FALSE
    ),
    commercial_legal_basis = ColumnOrDefault(
      raw_data, "commercial_legal_basis", "not available"
    ),
    period_label = raw_data$period_label,
    period_order = raw_data$period_order,
    interval_years = raw_data$interval_years_value,
    basal_area_2013_m2_ha = raw_data$basal_area_2013_m2_ha,
    basal_area_z_training_scaler = NA_real_,
    initial_dbh_cm = raw_data$initial_dbh,
    observed_final_dbh_cm = raw_data$dbh_final,
    predicted_final_dbh_cm = raw_data$initial_dbh,
    observed_increment_cm = raw_data$dbh_final - raw_data$initial_dbh,
    predicted_increment_cm = 0,
    residual_cm = raw_data$dbh_final - raw_data$initial_dbh,
    annualized_residual_cm_yr =
      (raw_data$dbh_final - raw_data$initial_dbh) / raw_data$interval_years_value,
    stringsAsFactors = FALSE
  )
}

BuildFoldSummary <- function(prediction_rows, n_train, n_test,
                             n_train_plots, n_test_plots, status = "success",
                             message = "") {
  metrics <- ComputePredictionMetrics(
    prediction_rows$observed_final_dbh_cm,
    prediction_rows$predicted_final_dbh_cm,
    prediction_rows$initial_dbh_cm,
    prediction_rows$interval_years
  )
  cbind(
    prediction_rows[1, c(
      "scheme", "fold_id", "structural_id", "model_family",
      "uses_basal_area", "estimator"
    ), drop = FALSE],
    data.frame(
      status = status, message = message,
      n_train = n_train, n_test = n_test,
      n_train_plots = n_train_plots, n_test_plots = n_test_plots,
      stringsAsFactors = FALSE
    ),
    metrics
  )
}

BuildFailedFoldSummary <- function(scheme, fold_id, specification, estimator,
                                   n_train, n_test, n_train_plots, n_test_plots,
                                   message) {
  data.frame(
    scheme = scheme, fold_id = as.character(fold_id),
    structural_id = specification$structural_id,
    model_family = specification$model_family,
    uses_basal_area = specification$uses_basal_area,
    estimator = estimator, status = "failed", message = message,
    n_train = n_train, n_test = n_test,
    n_train_plots = n_train_plots, n_test_plots = n_test_plots,
    n = 0L, RMSE_final_cm = NA_real_, MAE_final_cm = NA_real_,
    mean_error_final_cm = NA_real_, predictive_R2 = NA_real_,
    modeling_efficiency_increment = NA_real_, RMSE_increment_cm = NA_real_,
    MAE_increment_cm = NA_real_, RMSE_annualized_cm_yr = NA_real_,
    MAE_annualized_cm_yr = NA_real_, stringsAsFactors = FALSE
  )
}

ExtractCoefficientRows <- function(fit, scheme, fold_id) {
  coefficients <- fit$coefficients
  transformed <- c(
    rate_at_mean_basal_area = exp(unname(coefficients["log_rate"])),
    rate_ratio_per_one_sd_basal_area = if (
      "basal_area_log_rate_effect" %in% names(coefficients)
    ) exp(unname(coefficients["basal_area_log_rate_effect"])) else 1
  )
  values <- c(coefficients, transformed)
  data.frame(
    scheme = scheme, fold_id = as.character(fold_id),
    structural_id = fit$structural_id, model_family = fit$model_family,
    uses_basal_area = fit$uses_basal_area, estimator = fit$estimator,
    parameter = names(values), estimate = as.numeric(values),
    scaler_center_m2_ha = fit$scaler$center,
    scaler_sd_m2_ha = fit$scaler$scale,
    scaler_unique_training_plots = fit$scaler$n_unique_training_plots,
    scaler_training_plots = fit$scaler$training_plots,
    stringsAsFactors = FALSE
  )
}

ExtractOptimizerRows <- function(fit, scheme, fold_id) {
  global <- fit$optimization_trace
  if (nrow(global) > 0L) {
    global$iteration <- NA_integer_
    global$parameter_change <- NA_real_
    global$scale <- NA_real_
  }
  weighting <- fit$weighting_trace
  if (nrow(weighting) > 0L) {
    weighting$seed <- NA_integer_
    weighting$de_objective <- NA_real_
    weighting$refined_unweighted_sse <- NA_real_
    weighting$iterations <- NA_integer_
    weighting$selected <- NA
  }
  result <- dplyr::bind_rows(global, weighting)
  if (nrow(result) == 0L) {
    return(data.frame())
  }
  result$scheme <- scheme
  result$fold_id <- as.character(fold_id)
  result$structural_id <- fit$structural_id
  result$model_family <- fit$model_family
  result$uses_basal_area <- fit$uses_basal_area
  result$estimator <- fit$estimator
  result
}

MatrixSvdDiagnostics <- function(matrix, prefix) {
  singular_values <- svd(matrix, nu = 0, nv = 0)$d
  tolerance <- max(singular_values) * sqrt(.Machine$double.eps)
  condition <- if (min(singular_values) > 0) {
    max(singular_values) / min(singular_values)
  } else {
    Inf
  }
  list(
    summary = data.frame(
      diagnostic_scale = prefix,
      condition_number = condition,
      numerical_rank = sum(singular_values > tolerance),
      n_parameters = ncol(matrix),
      minimum_singular_value = min(singular_values),
      maximum_singular_value = max(singular_values),
      stringsAsFactors = FALSE
    ),
    singular_values = data.frame(
      diagnostic_scale = prefix,
      singular_value_index = seq_along(singular_values),
      singular_value = singular_values,
      stringsAsFactors = FALSE
    )
  )
}

NumericalPredictionJacobian <- function(parameters, data, specification,
                                        bounds = NULL) {
  parameters <- as.numeric(parameters)
  names(parameters) <- ParameterNames(specification)
  if (is.null(bounds)) {
    bounds <- GetBounds(specification, data)
  }
  base_prediction <- PredictFromParameters(parameters, data, specification)
  if (any(!is.finite(base_prediction))) {
    stop("Cannot compute a Jacobian from non-finite fitted predictions for ",
         specification$structural_id)
  }
  jacobian <- matrix(
    NA_real_, nrow = nrow(data), ncol = length(parameters),
    dimnames = list(NULL, names(parameters))
  )
  bound_range <- bounds$upper[names(parameters)] - bounds$lower[names(parameters)]

  for (parameter_index in seq_along(parameters)) {
    parameter_name <- names(parameters)[parameter_index]
    value <- parameters[parameter_index]
    step <- max(
      (.Machine$double.eps)^(1 / 3) * max(1, abs(value)),
      1e-6 * bound_range[parameter_name]
    )
    forward_value <- min(value + step, bounds$upper[parameter_name])
    backward_value <- max(value - step, bounds$lower[parameter_name])
    has_forward <- is.finite(forward_value) && forward_value > value
    has_backward <- is.finite(backward_value) && backward_value < value

    if (has_forward && has_backward) {
      forward <- parameters
      backward <- parameters
      forward[parameter_index] <- forward_value
      backward[parameter_index] <- backward_value
      forward_prediction <- PredictFromParameters(forward, data, specification)
      backward_prediction <- PredictFromParameters(backward, data, specification)
      derivative <- (forward_prediction - backward_prediction) /
        (forward_value - backward_value)
    } else if (has_forward) {
      forward <- parameters
      forward[parameter_index] <- forward_value
      forward_prediction <- PredictFromParameters(forward, data, specification)
      derivative <- (forward_prediction - base_prediction) /
        (forward_value - value)
    } else if (has_backward) {
      backward <- parameters
      backward[parameter_index] <- backward_value
      backward_prediction <- PredictFromParameters(backward, data, specification)
      derivative <- (base_prediction - backward_prediction) /
        (value - backward_value)
    } else {
      stop("No finite-difference direction is available for parameter ",
           parameter_name, " in ", specification$structural_id)
    }
    if (any(!is.finite(derivative))) {
      stop("Non-finite numerical Jacobian column for parameter ",
           parameter_name, " in ", specification$structural_id)
    }
    jacobian[, parameter_index] <- derivative
  }
  jacobian
}

AssessIdentifiability <- function(fit) {
  specification <- GetSpecification(fit$structural_id)
  bounds <- GetBounds(specification, fit$training_data)
  jacobian <- NumericalPredictionJacobian(
    fit$coefficients, fit$training_data, specification, bounds
  )
  if (nrow(jacobian) != nrow(fit$training_data)) {
    stop("Unexpected Jacobian dimensions for ", fit$structural_id)
  }
  raw <- MatrixSvdDiagnostics(jacobian, "raw")
  column_norms <- sqrt(colSums(jacobian^2))
  unit_jacobian <- sweep(jacobian, 2, pmax(column_norms, .Machine$double.eps), "/")
  unit <- MatrixSvdDiagnostics(unit_jacobian, "unit_column_norm")
  bound_ranges <- bounds$upper - bounds$lower
  bound_scaled <- MatrixSvdDiagnostics(
    sweep(jacobian, 2, bound_ranges[names(fit$coefficients)], "*"),
    "bound_range_scaled"
  )
  coefficients <- fit$coefficients
  relative_to_lower <- abs(coefficients - bounds$lower[names(coefficients)]) /
    pmax(bound_ranges[names(coefficients)], .Machine$double.eps)
  relative_to_upper <- abs(bounds$upper[names(coefficients)] - coefficients) /
    pmax(bound_ranges[names(coefficients)], .Machine$double.eps)
  boundary <- data.frame(
    parameter = names(coefficients), estimate = as.numeric(coefficients),
    lower_bound = bounds$lower[names(coefficients)],
    upper_bound = bounds$upper[names(coefficients)],
    relative_distance_to_lower = as.numeric(relative_to_lower),
    relative_distance_to_upper = as.numeric(relative_to_upper),
    at_boundary = as.numeric(pmin(relative_to_lower, relative_to_upper)) <=
      kBoundaryRelativeTolerance,
    jacobian_column_norm = as.numeric(column_norms),
    stringsAsFactors = FALSE
  )
  summary <- dplyr::bind_rows(raw$summary, unit$summary, bound_scaled$summary)
  summary$structural_id <- fit$structural_id
  summary$model_family <- fit$model_family
  summary$uses_basal_area <- fit$uses_basal_area
  summary$estimator <- fit$estimator
  summary$any_boundary <- any(boundary$at_boundary)
  unit_condition <- summary$condition_number[
    summary$diagnostic_scale == "unit_column_norm"
  ]
  summary$short_interval_prediction_supported <-
    isTRUE(fit$optimization_solution_accepted %||% fit$converged) &&
    all(is.finite(fit$coefficients))
  summary$long_term_projection_supported <- FALSE
  summary$identifiability_warning <- any(boundary$at_boundary) ||
    !is.finite(unit_condition) || unit_condition > kScaledConditionThreshold

  singular_values <- dplyr::bind_rows(
    raw$singular_values, unit$singular_values, bound_scaled$singular_values
  )
  singular_values$structural_id <- fit$structural_id
  singular_values$estimator <- fit$estimator
  boundary$structural_id <- fit$structural_id
  boundary$estimator <- fit$estimator
  list(summary = summary, singular_values = singular_values, boundary = boundary)
}

# 8. STRICT VALIDATION ---------------------------------------------------------

MakeValidationFolds <- function(data) {
  folds <- list()
  plots <- sort(unique(data$plot_id))
  periods <- seq_along(kModelingPeriods)

  for (plot in plots) {
    folds[[length(folds) + 1L]] <- list(
      scheme = "LOPO",
      role = "primary_internal_spatially_blocked_validation",
      fold_id = paste0("plot_", plot),
      train_index = which(data$plot_id != plot),
      test_index = which(data$plot_id == plot)
    )
  }

  plot_pairs <- utils::combn(plots, 2)
  for (column in seq_len(ncol(plot_pairs))) {
    held_out <- plot_pairs[, column]
    folds[[length(folds) + 1L]] <- list(
      scheme = "L2PO",
      role = "spatial_stress_test",
      fold_id = paste0("plots_", held_out[1], "_", held_out[2]),
      train_index = which(!data$plot_id %in% held_out),
      test_index = which(data$plot_id %in% held_out)
    )
  }

  for (test_period in periods[-1]) {
    training_periods <- periods[periods < test_period]
    if (length(training_periods) < kTemporalMinimumTrainingPeriods) {
      next
    }
    folds[[length(folds) + 1L]] <- list(
      scheme = "Temporal",
      role = "complementary_future_interval_validation",
      fold_id = paste0(
        "train_through_", kModelingPeriods[max(training_periods)],
        "__test_", kModelingPeriods[test_period]
      ),
      train_index = which(data$period_order %in% training_periods),
      test_index = which(data$period_order == test_period)
    )
  }
  folds
}

ValidateFoldInventory <- function(folds, data) {
  schemes <- vapply(folds, `[[`, character(1), "scheme")
  observed_counts <- table(factor(schemes, levels = c("LOPO", "L2PO", "Temporal")))
  expected <- stats::setNames(
    ExpectedFoldCounts()$expected_folds,
    ExpectedFoldCounts()$scheme
  )
  if (!all(as.numeric(observed_counts) == as.numeric(expected[names(observed_counts)]))) {
    stop("Validation-fold inventory does not match the fixed analytical design.")
  }

  coverage <- lapply(c("LOPO", "L2PO", "Temporal"), function(scheme) {
    scheme_folds <- folds[schemes == scheme]
    test_counts <- integer(nrow(data))
    for (fold in scheme_folds) {
      test_counts[fold$test_index] <- test_counts[fold$test_index] + 1L
    }
    expected_row_coverage <- if (scheme == "LOPO") {
      rep(1L, nrow(data))
    } else if (scheme == "L2PO") {
      rep(length(kTargetPlots) - 1L, nrow(data))
    } else {
      ifelse(data$period_order == 1L, 0L, 1L)
    }
    if (!identical(as.integer(test_counts), as.integer(expected_row_coverage))) {
      stop("Unexpected test-set coverage in validation scheme: ", scheme)
    }
    data.frame(
      scheme = scheme,
      folds = length(scheme_folds),
      minimum_test_appearances_per_eligible_row = min(
        test_counts[expected_row_coverage > 0L]
      ),
      maximum_test_appearances_per_eligible_row = max(
        test_counts[expected_row_coverage > 0L]
      ),
      eligible_unique_rows = sum(expected_row_coverage > 0L),
      design_check = "PASS",
      stringsAsFactors = FALSE
    )
  })
  dplyr::bind_rows(coverage)
}

ValidateFoldSeparation <- function(fold, training_data, testing_data) {
  if (nrow(training_data) == 0L || nrow(testing_data) == 0L) {
    stop("Empty training or testing set in ", fold$fold_id)
  }
  if (length(intersect(training_data$analysis_row_id, testing_data$analysis_row_id)) > 0L) {
    stop("Training/testing row overlap detected in ", fold$fold_id)
  }
  if (fold$scheme %in% c("LOPO", "L2PO") &&
      length(intersect(training_data$plot_id, testing_data$plot_id)) > 0L) {
    stop("Plot leakage detected in ", fold$fold_id)
  }
  if (fold$scheme == "Temporal" &&
      max(training_data$period_order) >= min(testing_data$period_order)) {
    stop("Temporal leakage detected in ", fold$fold_id)
  }
  invisible(TRUE)
}

RunValidationCandidateFold <- function(fold, training_data, testing_data,
                                       specification, signature) {
  safe_fold <- gsub("[^A-Za-z0-9_-]", "_", fold$fold_id)
  cache_path <- file.path(
    kOutputDirectory, "Cache", fold$scheme, specification$structural_id,
    paste0(safe_fold, ".rds")
  )
  cached <- ReadCompatibleCache(cache_path, signature)
  if (!is.null(cached)) {
    return(cached)
  }

  estimators <- "OLS"
  if (isTRUE(kRunHuberSensitivity) &&
      fold$scheme %in% c("LOPO", "Temporal")) {
    estimators <- c(estimators, "Huber")
  }
  if (isTRUE(kRunExploratoryErrorSensitivities) && fold$scheme != "L2PO") {
    estimators <- c(estimators, "FGLS", "Student_t")
  }
  n_train <- nrow(training_data)
  n_test <- nrow(testing_data)
  n_train_plots <- dplyr::n_distinct(training_data$plot_id)
  n_test_plots <- dplyr::n_distinct(testing_data$plot_id)
  seed <- DeterministicSeed(
    specification$structural_id, fold$scheme, fold$fold_id
  )
  ols_fit <- tryCatch(
    FitOlsGlobal(
      training_data, specification, seeds = seed,
      de_itermax = kCvDeIterMax, de_np = kCvDeNp
    ),
    error = function(error) error
  )
  if (inherits(ols_fit, "error")) {
    result <- list(
      fold_summary = dplyr::bind_rows(lapply(estimators, function(estimator) {
        BuildFailedFoldSummary(
          fold$scheme, fold$fold_id, specification, estimator,
          n_train, n_test, n_train_plots, n_test_plots,
          ols_fit$message
        )
      })),
      predictions = data.frame(),
      coefficients = data.frame(),
      optimizer_diagnostics = data.frame()
    )
    result <- AnnotateValidationPayloadAcceptance(result)
    WriteCache(cache_path, signature, result)
    return(result)
  }

  fits <- list(OLS = ols_fit)
  if (isTRUE(kRunHuberSensitivity) &&
      fold$scheme %in% c("LOPO", "Temporal")) {
    fits$Huber <- tryCatch(
      FitHuberSensitivity(ols_fit, specification),
      error = function(error) error
    )
  }
  if (isTRUE(kRunExploratoryErrorSensitivities) && fold$scheme != "L2PO") {
    fits$FGLS <- tryCatch(
      FitFglsSensitivity(ols_fit, specification),
      error = function(error) error
    )
    fits$Student_t <- tryCatch(
      FitStudentTSensitivity(ols_fit, specification),
      error = function(error) error
    )
  }

  summaries <- list()
  predictions <- list()
  coefficients <- list()
  optimizers <- list()
  for (estimator in estimators) {
    fit <- fits[[estimator]]
    if (inherits(fit, "error")) {
      summaries[[estimator]] <- BuildFailedFoldSummary(
        fold$scheme, fold$fold_id, specification, estimator,
        n_train, n_test, n_train_plots, n_test_plots,
        fit$message
      )
      next
    }
    prediction_rows <- BuildPredictionRows(
      fit, testing_data, fold$scheme, fold$fold_id
    )
    if (any(!is.finite(prediction_rows$predicted_final_dbh_cm))) {
      summaries[[estimator]] <- BuildFailedFoldSummary(
        fold$scheme, fold$fold_id, specification, estimator,
        n_train, n_test, n_train_plots, n_test_plots,
        "Non-finite out-of-sample prediction"
      )
      next
    }
    predictions[[estimator]] <- prediction_rows
    summaries[[estimator]] <- BuildFoldSummary(
      prediction_rows, n_train, n_test, n_train_plots, n_test_plots,
      status = "success", message = fit$convergence_message
    )
    summaries[[estimator]]$local_optimizer_converged <- fit$converged
    summaries[[estimator]]$IRLS_converged <- fit$irls_converged
    coefficients[[estimator]] <- ExtractCoefficientRows(
      fit, fold$scheme, fold$fold_id
    )
    optimizers[[estimator]] <- ExtractOptimizerRows(
      fit, fold$scheme, fold$fold_id
    )
  }

  result <- list(
    fold_summary = dplyr::bind_rows(summaries),
    predictions = dplyr::bind_rows(predictions),
    coefficients = dplyr::bind_rows(coefficients),
    optimizer_diagnostics = dplyr::bind_rows(optimizers)
  )
  result <- AnnotateValidationPayloadAcceptance(result)
  WriteCache(cache_path, signature, result)
  result
}

RunStrictValidation <- function(data, signature) {
  prediction_domain_audit <- ValidatePredictionDomainControl(data)
  folds <- MakeValidationFolds(data)
  design_audit <- ValidateFoldInventory(folds, data)
  fold_results <- list()
  persistence_predictions <- list()
  persistence_summaries <- list()
  counter <- 0L
  last_lopo_index <- max(which(vapply(
    folds, function(fold) identical(fold$scheme, "LOPO"), logical(1)
  )))

  for (fold_index in seq_along(folds)) {
    fold <- folds[[fold_index]]
    training_data <- data[fold$train_index, , drop = FALSE]
    testing_data <- data[fold$test_index, , drop = FALSE]
    ValidateFoldSeparation(fold, training_data, testing_data)
    LogMessage(
      "INFO",
      sprintf(
        "Validation %s / %s: %d training and %d testing rows.",
        fold$scheme, fold$fold_id, nrow(training_data), nrow(testing_data)
      )
    )

    persistence <- BuildPersistenceRows(testing_data, fold$scheme, fold$fold_id)
    persistence_predictions[[length(persistence_predictions) + 1L]] <- persistence
    persistence_summaries[[length(persistence_summaries) + 1L]] <-
      BuildFoldSummary(
        persistence, nrow(training_data), nrow(testing_data),
        dplyr::n_distinct(training_data$plot_id),
        dplyr::n_distinct(testing_data$plot_id)
      )

    for (structural_id in kStructuralSpecifications$structural_id) {
      counter <- counter + 1L
      specification <- GetSpecification(structural_id)
      candidate_result <- RunValidationCandidateFold(
        fold, training_data, testing_data, specification, signature
      )
      fold_results[[counter]] <- candidate_result
      failed_ols <- candidate_result$fold_summary %>%
        dplyr::filter(estimator == "OLS", status != "success")
      if (nrow(failed_ols) > 0L) {
        LogMessage(
          "WARN",
          paste0(
            "Primary OLS failure in ", fold$scheme, " / ", fold$fold_id,
            " / ", structural_id, ": ", failed_ols$message[1]
          )
        )
      }
      failed_huber <- candidate_result$fold_summary %>%
        dplyr::filter(estimator == "Huber", status != "success")
      if (nrow(failed_huber) > 0L) {
        LogMessage(
          "WARN",
          paste0(
            "Huber sensitivity failure in ", fold$scheme, " / ",
            fold$fold_id, " / ", structural_id, ": ",
            failed_huber$message[1],
            ". Canonical OLS validation is unaffected."
          )
        )
      }
      accepted_boundary_ols <- candidate_result$fold_summary %>%
        dplyr::filter(
          estimator == "OLS", status == "success",
          optimization_solution_accepted %in% TRUE,
          !local_optimizer_converged %in% TRUE
        )
      if (nrow(accepted_boundary_ols) > 0L) {
        LogMessage(
          "WARN",
          paste0(
            "OLS boundary/global solution accepted in ", fold$scheme, " / ",
            fold$fold_id, " / ", structural_id,
            " by independent objective agreement; formal local convergence ",
            "remains FALSE and is retained as a diagnostic."
          )
        )
      }
    }

    # L2PO and temporal validation proceed only when the primary LOPO comparison
    # is complete; checkpoints are exported before termination for auditability.
    if (fold_index == last_lopo_index) {
      lopo_checkpoint <- dplyr::bind_rows(
        lapply(fold_results, `[[`, "fold_summary"), persistence_summaries
      )
      if (!"optimization_solution_accepted" %in% names(lopo_checkpoint)) {
        lopo_checkpoint$optimization_solution_accepted <- FALSE
      }
      expected_primary <- expand.grid(
        structural_id = kStructuralSpecifications$structural_id,
        fold_id = paste0("plot_", kTargetPlots),
        stringsAsFactors = FALSE
      )
      observed_primary <- lopo_checkpoint %>%
        dplyr::filter(
          scheme == "LOPO", estimator == "OLS", status == "success",
          optimization_solution_accepted %in% TRUE,
          is.finite(RMSE_final_cm), n == n_test
        ) %>%
        dplyr::distinct(structural_id, fold_id)
      missing_primary <- dplyr::anti_join(
        expected_primary, observed_primary,
        by = c("structural_id", "fold_id")
      )
      WriteCsv(lopo_checkpoint, "LOPO_checkpoint_fold_summary.csv")
      if (nrow(missing_primary) > 0L) {
        failure_detail <- missing_primary %>%
          dplyr::left_join(
            lopo_checkpoint %>%
              dplyr::filter(scheme == "LOPO", estimator == "OLS") %>%
              dplyr::select(
                structural_id, fold_id, status,
                optimization_solution_accepted,
                optimization_acceptance_basis,
                independent_usable_local_methods,
                local_objective_relative_spread,
                selected_relative_change_from_DE,
                local_optimizer_converged, message
              ),
            by = c("structural_id", "fold_id")
          )
        WriteCsv(failure_detail, "LOPO_checkpoint_failures.csv")
        stop(
          "Primary LOPO checkpoint failed for ", nrow(missing_primary),
          " of ", nrow(expected_primary),
          " structural fold fits. See Tables/LOPO_checkpoint_failures.csv."
        )
      }
      stale_failure_path <- file.path(
        kOutputDirectory, "Tables", "LOPO_checkpoint_failures.csv"
      )
      if (file.exists(stale_failure_path) && unlink(stale_failure_path) != 0L) {
        warning("Could not remove stale LOPO checkpoint failure table.")
      }
      LogMessage(
        "INFO",
        paste0(
          "Primary LOPO checkpoint passed: all 24 structural OLS fold solutions ",
          "were accepted by formal convergence or the pre-specified independent ",
          "objective-agreement rule."
        )
      )
    }
  }

  list(
    prediction_domain_audit = prediction_domain_audit,
    design_audit = design_audit,
    fold_summary = dplyr::bind_rows(
      lapply(fold_results, `[[`, "fold_summary"),
      persistence_summaries
    ),
    predictions = dplyr::bind_rows(
      lapply(fold_results, `[[`, "predictions"),
      persistence_predictions
    ),
    coefficients = dplyr::bind_rows(
      lapply(fold_results, `[[`, "coefficients")
    ),
    optimizer_diagnostics = dplyr::bind_rows(
      lapply(fold_results, `[[`, "optimizer_diagnostics")
    )
  )
}

ExpectedFoldCounts <- function() {
  data.frame(
    scheme = c("LOPO", "L2PO", "Temporal"),
    expected_folds = c(length(kTargetPlots), choose(length(kTargetPlots), 2),
                       length(kModelingPeriods) - 1L),
    validation_role = c(
      "primary_internal_spatially_blocked_validation", "spatial_stress_test",
      "complementary_future_interval_validation"
    ),
    stringsAsFactors = FALSE
  )
}

SummarizeValidation <- function(validation) {
  successful <- validation$fold_summary %>%
    dplyr::filter(status == "success") %>%
    dplyr::group_by(
      scheme, structural_id, model_family, uses_basal_area, estimator
    ) %>%
    dplyr::summarise(
      successful_folds = dplyr::n_distinct(fold_id),
      mean_fold_RMSE_cm = mean(RMSE_final_cm),
      sd_fold_RMSE_cm = stats::sd(RMSE_final_cm),
      minimum_fold_RMSE_cm = min(RMSE_final_cm),
      maximum_fold_RMSE_cm = max(RMSE_final_cm),
      .groups = "drop"
    )
  failed <- validation$fold_summary %>%
    dplyr::group_by(
      scheme, structural_id, model_family, uses_basal_area, estimator
    ) %>%
    dplyr::summarise(
      attempted_folds = dplyr::n_distinct(fold_id),
      failed_folds = sum(status != "success"),
      .groups = "drop"
    )
  split_predictions <- split(
    validation$predictions,
    interaction(
      validation$predictions$scheme,
      validation$predictions$structural_id,
      validation$predictions$estimator,
      drop = TRUE, lex.order = TRUE
    )
  )
  pooled <- lapply(split_predictions, function(rows) {
    metrics <- ComputePredictionMetrics(
      rows$observed_final_dbh_cm, rows$predicted_final_dbh_cm,
      rows$initial_dbh_cm, rows$interval_years
    )
    cbind(
      rows[1, c(
        "scheme", "structural_id", "model_family", "uses_basal_area",
        "estimator"
      ), drop = FALSE],
      metrics
    )
  }) %>% dplyr::bind_rows()

  pooled %>%
    dplyr::left_join(successful, by = c(
      "scheme", "structural_id", "model_family", "uses_basal_area", "estimator"
    )) %>%
    dplyr::left_join(failed, by = c(
      "scheme", "structural_id", "model_family", "uses_basal_area", "estimator"
    )) %>%
    dplyr::left_join(ExpectedFoldCounts(), by = "scheme") %>%
    dplyr::mutate(
      validation_status = ifelse(
        successful_folds == expected_folds & failed_folds == 0L,
        "complete", "partial"
      )
    ) %>%
    dplyr::arrange(scheme, model_family, uses_basal_area, estimator)
}

SelectBasalAreaStructures <- function(validation_summary, fold_summary) {
  results <- list()
  for (family in c("Richards", "Lundqvist")) {
    family_summary <- validation_summary %>%
      dplyr::filter(
        .data$scheme == "LOPO", .data$estimator == "OLS",
        .data$model_family == .env$family
      )
    no_ba <- family_summary %>% dplyr::filter(!uses_basal_area)
    with_ba <- family_summary %>% dplyr::filter(uses_basal_area)
    if (nrow(no_ba) != 1L || nrow(with_ba) != 1L) {
      stop("Incomplete LOPO structural comparison for ", family)
    }
    fold_no_ba <- fold_summary %>%
      dplyr::filter(
        .data$scheme == "LOPO", .data$estimator == "OLS",
        .data$model_family == .env$family,
        !.data$uses_basal_area, .data$status == "success"
      ) %>%
      dplyr::select(fold_id, RMSE_noBA_cm = RMSE_final_cm)
    fold_with_ba <- fold_summary %>%
      dplyr::filter(
        .data$scheme == "LOPO", .data$estimator == "OLS",
        .data$model_family == .env$family,
        .data$uses_basal_area, .data$status == "success"
      ) %>%
      dplyr::select(fold_id, RMSE_BA_cm = RMSE_final_cm)
    paired <- dplyr::inner_join(fold_no_ba, fold_with_ba, by = "fold_id")
    winning_plots <- sum(paired$RMSE_BA_cm < paired$RMSE_noBA_cm)
    gain <- no_ba$RMSE_final_cm - with_ba$RMSE_final_cm
    retain_ba <- isTRUE(gain >= kMinimumPracticalBaGainCm) &&
      winning_plots >= kMinimumBaWinningPlots
    results[[family]] <- data.frame(
      model_family = family,
      noBA_structural_id = no_ba$structural_id,
      BA_structural_id = with_ba$structural_id,
      LOPO_RMSE_noBA_cm = no_ba$RMSE_final_cm,
      LOPO_RMSE_BA_cm = with_ba$RMSE_final_cm,
      BA_RMSE_gain_cm = gain,
      BA_RMSE_gain_percent = 100 * gain / no_ba$RMSE_final_cm,
      BA_winning_plot_folds = winning_plots,
      paired_plot_folds = nrow(paired),
      minimum_practical_gain_cm = kMinimumPracticalBaGainCm,
      minimum_winning_plot_folds = kMinimumBaWinningPlots,
      retain_BA_for_reporting = retain_ba,
      selected_structural_id = if (retain_ba) {
        with_ba$structural_id
      } else {
        no_ba$structural_id
      },
      selection_basis = paste0(
        "Audit-frozen LOPO parsimony rule: gain >= ",
        kMinimumPracticalBaGainCm, " cm and BA wins >= ",
        kMinimumBaWinningPlots, " of 6 plot folds"
      ),
      stringsAsFactors = FALSE
    )
  }
  dplyr::bind_rows(results)
}

AssessFamilyEquivalence <- function(validation_summary, selection) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  selected <- validation_summary %>%
    dplyr::filter(
      .data$scheme == "LOPO", .data$estimator == "OLS",
      .data$structural_id %in% .env$selected_ids,
      .data$validation_status == "complete"
    )
  if (nrow(selected) != 2L ||
      !setequal(selected$model_family, c("Richards", "Lundqvist"))) {
    stop("The selected Richards/Lundqvist LOPO comparison is incomplete.")
  }
  richards <- selected$RMSE_final_cm[selected$model_family == "Richards"]
  lundqvist <- selected$RMSE_final_cm[selected$model_family == "Lundqvist"]
  difference <- richards - lundqvist
  equivalent <- abs(difference) < kMinimumPracticalFamilyRmseDifferenceCm
  data.frame(
    Richards_selected_structure = selected$structural_id[
      selected$model_family == "Richards"
    ],
    Lundqvist_selected_structure = selected$structural_id[
      selected$model_family == "Lundqvist"
    ],
    Richards_LOPO_RMSE_cm = richards,
    Lundqvist_LOPO_RMSE_cm = lundqvist,
    Richards_minus_Lundqvist_RMSE_cm = difference,
    absolute_RMSE_difference_cm = abs(difference),
    practical_difference_threshold_cm =
      kMinimumPracticalFamilyRmseDifferenceCm,
    practically_indistinguishable = equivalent,
    reporting_decision = if (equivalent) {
      paste0(
        "retain both families as structural uncertainty; do not declare a unique winner"
      )
    } else if (difference < 0) {
      "Richards has a practically lower LOPO RMSE"
    } else {
      "Lundqvist has a practically lower LOPO RMSE"
    },
    stringsAsFactors = FALSE
  )
}

ComputeSpeciesOosDiagnostics <- function(validation, selection) {
  selected <- FilterSelectedPredictions(
    validation$predictions, selection, estimator = "OLS", scheme = "LOPO"
  )
  persistence <- validation$predictions %>%
    dplyr::filter(
      .data$scheme == "LOPO", .data$estimator == "Persistence",
      .data$structural_id == "Persistence"
    ) %>%
    dplyr::select(
      scheme, fold_id, analysis_row_id,
      persistence_residual_cm = residual_cm
    )
  if (anyDuplicated(
    persistence[c("scheme", "fold_id", "analysis_row_id")]
  ) > 0L) {
    stop("Persistence LOPO predictions are not unique by fold and row.")
  }
  joined <- selected %>%
    dplyr::left_join(
      persistence,
      by = c("scheme", "fold_id", "analysis_row_id")
    )
  if (anyNA(joined$persistence_residual_cm)) {
    stop("Species diagnostics could not match all selected LOPO predictions.")
  }
  joined %>%
    dplyr::group_by(
      structural_id, model_family, species_id, genus_name,
      specific_epithet, taxon_identified, commercial_listed,
      commercial_permission_class, commercial_registry_conflict
    ) %>%
    dplyr::summarise(
      intervals = dplyr::n(),
      unique_trees = dplyr::n_distinct(tree_id),
      held_out_plots = dplyr::n_distinct(plot_id),
      LOPO_RMSE_cm = sqrt(mean(residual_cm^2)),
      LOPO_MAE_cm = mean(abs(residual_cm)),
      LOPO_mean_error_cm = mean(residual_cm),
      persistence_RMSE_cm = sqrt(mean(persistence_residual_cm^2)),
      .groups = "drop"
    ) %>%
    dplyr::mutate(
      RMSE_gain_over_persistence_cm =
        persistence_RMSE_cm - LOPO_RMSE_cm,
      RMSE_gain_over_persistence_percent = 100 *
        RMSE_gain_over_persistence_cm / persistence_RMSE_cm,
      diagnostic_sample_eligible =
        intervals >= kMinimumSpeciesIntervalsForDiagnostics &
        unique_trees >= kMinimumSpeciesTreesForDiagnostics &
        held_out_plots >= kMinimumSpeciesPlotsForDiagnostics,
      eligibility_rule = paste0(
        ">=", kMinimumSpeciesIntervalsForDiagnostics, " intervals, >=",
        kMinimumSpeciesTreesForDiagnostics, " trees, >=",
        kMinimumSpeciesPlotsForDiagnostics, " plots"
      )
    ) %>%
    dplyr::arrange(model_family, dplyr::desc(intervals), species_id)
}

SummarizeSpeciesGroupRobustness <- function(species_diagnostics) {
  rows <- lapply(c("Richards", "Lundqvist"), function(family_name) {
    values <- species_diagnostics %>%
      dplyr::filter(
        .data$model_family == .env$family_name,
        .data$diagnostic_sample_eligible
      )
    data.frame(
      model_family = family_name,
      eligible_species = nrow(values),
      species_with_positive_gain_over_persistence = sum(
        values$RMSE_gain_over_persistence_cm > 0, na.rm = TRUE
      ),
      fraction_with_positive_gain = if (nrow(values) > 0L) {
        mean(values$RMSE_gain_over_persistence_cm > 0, na.rm = TRUE)
      } else {
        NA_real_
      },
      macro_mean_species_RMSE_cm = if (nrow(values) > 0L) {
        mean(values$LOPO_RMSE_cm)
      } else {
        NA_real_
      },
      macro_mean_absolute_species_bias_cm = if (nrow(values) > 0L) {
        mean(abs(values$LOPO_mean_error_cm))
      } else {
        NA_real_
      },
      maximum_absolute_species_bias_cm = if (nrow(values) > 0L) {
        max(abs(values$LOPO_mean_error_cm))
      } else {
        NA_real_
      },
      interpretation = paste0(
        "descriptive internal LOPO heterogeneity audit; not proof of exchangeability ",
        "among species and not external validation"
      ),
      stringsAsFactors = FALSE
    )
  })
  dplyr::bind_rows(rows)
}

ComputeRegulatoryStratumOosDiagnostics <- function(validation, selection) {
  selected <- FilterSelectedPredictions(
    validation$predictions, selection, estimator = "OLS", scheme = "LOPO"
  ) %>%
    dplyr::filter(commercial_listed)
  persistence <- validation$predictions %>%
    dplyr::filter(
      .data$scheme == "LOPO", .data$estimator == "Persistence",
      .data$structural_id == "Persistence", .data$commercial_listed
    ) %>%
    dplyr::select(
      scheme, fold_id, analysis_row_id,
      persistence_residual_cm = residual_cm
    )
  joined <- selected %>%
    dplyr::left_join(
      persistence,
      by = c("scheme", "fold_id", "analysis_row_id")
    )
  if (nrow(joined) == 0L || anyNA(joined$persistence_residual_cm)) {
    stop("Regulatory-stratum diagnostics could not reconcile LOPO predictions.")
  }
  diagnostics <- joined %>%
    dplyr::group_by(
      structural_id, model_family, commercial_permission_class
    ) %>%
    dplyr::summarise(
      intervals = dplyr::n(),
      unique_trees = dplyr::n_distinct(tree_id),
      species = dplyr::n_distinct(species_id),
      held_out_plots = dplyr::n_distinct(plot_id),
      registry_conflict_intervals = sum(commercial_registry_conflict),
      LOPO_RMSE_cm = sqrt(mean(residual_cm^2)),
      LOPO_MAE_cm = mean(abs(residual_cm)),
      LOPO_mean_error_cm = mean(residual_cm),
      LOPO_RMSE_annualized_cm_yr = sqrt(mean(annualized_residual_cm_yr^2)),
      persistence_RMSE_cm = sqrt(mean(persistence_residual_cm^2)),
      .groups = "drop"
    ) %>%
    dplyr::mutate(
      RMSE_gain_over_persistence_cm = persistence_RMSE_cm - LOPO_RMSE_cm,
      regulatory_status_role = paste0(
        "post-validation descriptive stratum only; status is neither a fitted ",
        "predictor nor a causal treatment"
      ),
      inference_note = paste0(
        "internal LOPO heterogeneity diagnostic; protected/permitted labels come ",
        "from the embedded registry and do not alter the growth observations"
      )
    ) %>%
    dplyr::arrange(model_family, commercial_permission_class)
  if (!setequal(
    unique(diagnostics$commercial_permission_class),
    c("permitted", "protected")
  )) {
    stop("Regulatory-stratum diagnostics are incomplete.")
  }
  diagnostics
}

ComputeTemporalFoldContrasts <- function(fold_summary, selection) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  model_rows <- fold_summary %>%
    dplyr::filter(
      .data$scheme == "Temporal", .data$estimator == "OLS",
      .data$status == "success",
      .data$structural_id %in% .env$selected_ids
    ) %>%
    dplyr::select(
      fold_id, structural_id, model_family,
      model_RMSE_cm = RMSE_final_cm, model_MAE_cm = MAE_final_cm,
      model_mean_error_cm = mean_error_final_cm, n_test
    )
  persistence <- fold_summary %>%
    dplyr::filter(
      .data$scheme == "Temporal", .data$estimator == "Persistence",
      .data$status == "success"
    ) %>%
    dplyr::select(
      fold_id, persistence_RMSE_cm = RMSE_final_cm,
      persistence_MAE_cm = MAE_final_cm,
      persistence_mean_error_cm = mean_error_final_cm
    )
  model_rows %>%
    dplyr::left_join(persistence, by = "fold_id") %>%
    dplyr::mutate(
      RMSE_gain_over_persistence_cm = persistence_RMSE_cm - model_RMSE_cm,
      RMSE_gain_over_persistence_percent = 100 *
        RMSE_gain_over_persistence_cm / persistence_RMSE_cm
    ) %>%
    dplyr::arrange(model_family, fold_id)
}

BootstrapLopoClusterContrasts <- function(validation, selection) {
  selected_ids <- SelectedStructuralIds(selection)
  contrast_table <- data.frame(
    contrast_id = c(
      "Richards_BA_minus_noBA", "Lundqvist_BA_minus_noBA",
      "selected_Richards_minus_selected_Lundqvist",
      "selected_Richards_minus_persistence",
      "selected_Lundqvist_minus_persistence"
    ),
    candidate_A = c(
      "Richards_BA2013", "Lundqvist_BA2013",
      unname(selected_ids["Richards"]), unname(selected_ids["Richards"]),
      unname(selected_ids["Lundqvist"])
    ),
    candidate_B = c(
      "Richards_noBA", "Lundqvist_noBA",
      unname(selected_ids["Lundqvist"]), "Persistence", "Persistence"
    ),
    stringsAsFactors = FALSE
  )
  candidates <- unique(c(contrast_table$candidate_A, contrast_table$candidate_B))
  rows <- validation$predictions %>%
    dplyr::filter(
      scheme == "LOPO", estimator %in% c("OLS", "Persistence"),
      structural_id %in% candidates
    )
  aggregated <- rows %>%
    dplyr::group_by(structural_id, plot_id) %>%
    dplyr::summarise(
      SSE = sum(residual_cm^2), n = dplyr::n(), .groups = "drop"
    )
  plots <- sort(unique(rows$plot_id))
  if (!setequal(plots, kTargetPlots)) {
    stop("LOPO cluster bootstrap does not contain all six held-out plots.")
  }
  sse_by_candidate <- lapply(candidates, function(candidate) {
    values <- aggregated %>%
      dplyr::filter(structural_id == candidate) %>%
      dplyr::arrange(match(plot_id, plots))
    if (!identical(values$plot_id, plots)) {
      stop("Incomplete LOPO candidate in cluster bootstrap: ", candidate)
    }
    values$SSE
  })
  names(sse_by_candidate) <- candidates
  n_by_candidate <- lapply(candidates, function(candidate) {
    aggregated %>%
      dplyr::filter(structural_id == candidate) %>%
      dplyr::arrange(match(plot_id, plots)) %>%
      dplyr::pull(n)
  })
  names(n_by_candidate) <- candidates

  set.seed(kLopoClusterBootstrapSeed)
  sampled_indices <- matrix(
    sample(
      seq_along(plots),
      size = kLopoClusterBootstrapReplicates * length(plots),
      replace = TRUE
    ),
    nrow = kLopoClusterBootstrapReplicates,
    ncol = length(plots)
  )
  cluster_weights <- t(apply(
    sampled_indices, 1, tabulate, nbins = length(plots)
  ))
  rmse_replicates <- lapply(candidates, function(candidate) {
    sqrt(
      as.numeric(cluster_weights %*% sse_by_candidate[[candidate]]) /
        as.numeric(cluster_weights %*% n_by_candidate[[candidate]])
    )
  })
  names(rmse_replicates) <- candidates

  replicate_rows <- list()
  summary_rows <- list()
  for (index in seq_len(nrow(contrast_table))) {
    contrast <- contrast_table[index, ]
    difference <- rmse_replicates[[contrast$candidate_A]] -
      rmse_replicates[[contrast$candidate_B]]
    observed_A <- sqrt(
      sum(sse_by_candidate[[contrast$candidate_A]]) /
        sum(n_by_candidate[[contrast$candidate_A]])
    )
    observed_B <- sqrt(
      sum(sse_by_candidate[[contrast$candidate_B]]) /
        sum(n_by_candidate[[contrast$candidate_B]])
    )
    interval <- stats::quantile(difference, c(0.025, 0.975), names = FALSE)
    summary_rows[[index]] <- data.frame(
      contrast_id = contrast$contrast_id,
      candidate_A = contrast$candidate_A,
      candidate_B = contrast$candidate_B,
      observed_RMSE_A_cm = observed_A,
      observed_RMSE_B_cm = observed_B,
      observed_difference_A_minus_B_cm = observed_A - observed_B,
      percentile_95_lower_cm = interval[1],
      percentile_95_upper_cm = interval[2],
      bootstrap_probability_A_lower_RMSE = mean(difference < 0),
      independent_clusters = length(plots),
      bootstrap_replicates = kLopoClusterBootstrapReplicates,
      inference_note = paste0(
        "descriptive plot-cluster bootstrap with only six independent plots; ",
        "not a substitute for additional independent sites"
      ),
      stringsAsFactors = FALSE
    )
    replicate_rows[[index]] <- data.frame(
      contrast_id = contrast$contrast_id,
      replicate = seq_len(kLopoClusterBootstrapReplicates),
      RMSE_difference_A_minus_B_cm = difference,
      stringsAsFactors = FALSE
    )
  }
  list(
    summary = dplyr::bind_rows(summary_rows),
    replicates = dplyr::bind_rows(replicate_rows)
  )
}

ComputeResidualDependence <- function(predictions) {
  eligible <- predictions %>%
    dplyr::filter(scheme %in% c("Full_data", "LOPO", "Temporal")) %>%
    dplyr::arrange(
      scheme, structural_id, estimator, tree_id, period_order
    ) %>%
    dplyr::group_by(scheme, structural_id, model_family, estimator, tree_id) %>%
    dplyr::mutate(
      lagged_residual_cm = dplyr::lag(residual_cm),
      lagged_period_order = dplyr::lag(period_order),
      consecutive_pair = period_order == lagged_period_order + 1L
    ) %>%
    dplyr::ungroup() %>%
    dplyr::filter(consecutive_pair %in% TRUE)
  group_keys <- eligible %>%
    dplyr::distinct(scheme, structural_id, model_family, estimator)
  rows <- lapply(seq_len(nrow(group_keys)), function(index) {
    key <- group_keys[index, ]
    values <- eligible %>%
      dplyr::filter(
        scheme == key$scheme,
        structural_id == key$structural_id,
        estimator == key$estimator
      )
    correlation <- if (nrow(values) > 1L &&
        stats::sd(values$residual_cm) > 0 &&
        stats::sd(values$lagged_residual_cm) > 0) {
      stats::cor(values$residual_cm, values$lagged_residual_cm)
    } else {
      NA_real_
    }
    data.frame(
      scheme = key$scheme,
      structural_id = key$structural_id,
      model_family = key$model_family,
      estimator = key$estimator,
      consecutive_within_tree_pairs = nrow(values),
      unique_trees_with_pairs = dplyr::n_distinct(values$tree_id),
      lag1_residual_correlation = correlation,
      interpretation = paste0(
        "descriptive dependence diagnostic only; parameter-level Wald inference ",
        "is not used"
      ),
      stringsAsFactors = FALSE
    )
  })
  dplyr::bind_rows(rows)
}

ComputePlotResidualDiagnostics <- function(predictions) {
  predictions %>%
    dplyr::filter(scheme %in% c("Full_data", "LOPO", "Temporal")) %>%
    dplyr::group_by(
      scheme, structural_id, model_family, uses_basal_area, estimator, plot_id
    ) %>%
    dplyr::summarise(
      n = dplyr::n(), RMSE_cm = sqrt(mean(residual_cm^2)),
      MAE_cm = mean(abs(residual_cm)), mean_error_cm = mean(residual_cm),
      .groups = "drop"
    )
}

BuildRobustLossSensitivity <- function(validation, validation_summary,
                                       selection) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  comparison_keys <- c(
    "scheme", "structural_id", "model_family", "uses_basal_area"
  )
  ols_summary <- validation_summary %>%
    dplyr::filter(
      .data$scheme %in% c("LOPO", "Temporal"),
      .data$structural_id %in% .env$selected_ids,
      .data$estimator == "OLS"
    ) %>%
    dplyr::select(
      dplyr::all_of(comparison_keys),
      OLS_validation_status = validation_status,
      OLS_successful_folds = successful_folds,
      OLS_RMSE_cm = RMSE_final_cm,
      OLS_MAE_cm = MAE_final_cm,
      OLS_mean_error_cm = mean_error_final_cm
    )
  huber_summary <- validation_summary %>%
    dplyr::filter(
      .data$scheme %in% c("LOPO", "Temporal"),
      .data$structural_id %in% .env$selected_ids,
      .data$estimator == "Huber"
    ) %>%
    dplyr::select(
      dplyr::all_of(comparison_keys),
      Huber_validation_status = validation_status,
      Huber_successful_folds = successful_folds,
      Huber_RMSE_cm = RMSE_final_cm,
      Huber_MAE_cm = MAE_final_cm,
      Huber_mean_error_cm = mean_error_final_cm
    )
  metric_comparison <- ols_summary %>%
    dplyr::left_join(huber_summary, by = comparison_keys) %>%
    dplyr::mutate(
      Huber_minus_OLS_RMSE_cm = Huber_RMSE_cm - OLS_RMSE_cm,
      Huber_minus_OLS_MAE_cm = Huber_MAE_cm - OLS_MAE_cm,
      Huber_minus_OLS_mean_error_cm =
        Huber_mean_error_cm - OLS_mean_error_cm,
      robust_sensitivity_status = dplyr::case_when(
        !isTRUE(kRunHuberSensitivity) ~ "disabled",
        is.na(Huber_successful_folds) ~ "not_available",
        Huber_validation_status == "complete" ~ "complete",
        TRUE ~ "partial"
      ),
      interpretation = paste0(
        "OLS remains canonical; Huber is a fixed-scale direct robust-loss ",
        "sensitivity and does not alter structural selection"
      )
    )

  fold_completeness <- validation$fold_summary %>%
    dplyr::filter(
      .data$scheme %in% c("LOPO", "Temporal"),
      .data$structural_id %in% .env$selected_ids,
      .data$estimator %in% c("OLS", "Huber")
    ) %>%
    dplyr::group_by(
      scheme, structural_id, model_family, estimator
    ) %>%
    dplyr::summarise(
      attempted_folds = dplyr::n_distinct(fold_id),
      successful_folds = dplyr::n_distinct(fold_id[status == "success"]),
      accepted_folds = dplyr::n_distinct(
        fold_id[status == "success" &
                  optimization_solution_accepted %in% TRUE]
      ),
      failed_folds = sum(status != "success"),
      .groups = "drop"
    ) %>%
    dplyr::left_join(ExpectedFoldCounts(), by = "scheme") %>%
    dplyr::mutate(
      sensitivity_complete = attempted_folds == expected_folds &
        successful_folds == expected_folds & accepted_folds == expected_folds,
      inference_role = ifelse(
        estimator == "OLS", "canonical", "robust-loss sensitivity"
      )
    )

  prediction_keys <- c(
    "scheme", "fold_id", "structural_id", "analysis_row_id"
  )
  ols_prediction <- validation$predictions %>%
    dplyr::filter(
      .data$scheme %in% c("LOPO", "Temporal"),
      .data$structural_id %in% .env$selected_ids,
      .data$estimator == "OLS"
    ) %>%
    dplyr::select(
      dplyr::all_of(prediction_keys), model_family,
      observed_final_dbh_cm, OLS_prediction_cm = predicted_final_dbh_cm,
      OLS_residual_cm = residual_cm
    )
  huber_prediction <- validation$predictions %>%
    dplyr::filter(
      .data$scheme %in% c("LOPO", "Temporal"),
      .data$structural_id %in% .env$selected_ids,
      .data$estimator == "Huber"
    ) %>%
    dplyr::select(
      dplyr::all_of(prediction_keys),
      Huber_prediction_cm = predicted_final_dbh_cm,
      Huber_residual_cm = residual_cm
    )
  paired <- dplyr::inner_join(
    ols_prediction, huber_prediction, by = prediction_keys
  )
  prediction_shift <- if (nrow(paired) == 0L) {
    data.frame(
      scheme = character(), structural_id = character(),
      model_family = character(), paired_predictions = integer(),
      OLS_RMSE_cm = numeric(), Huber_RMSE_cm = numeric(),
      Huber_minus_OLS_RMSE_cm = numeric(),
      median_absolute_prediction_shift_cm = numeric(),
      p95_absolute_prediction_shift_cm = numeric(),
      maximum_absolute_prediction_shift_cm = numeric(),
      stringsAsFactors = FALSE
    )
  } else {
    paired %>%
      dplyr::mutate(
        absolute_prediction_shift_cm = abs(
          Huber_prediction_cm - OLS_prediction_cm
        )
      ) %>%
      dplyr::group_by(scheme, structural_id, model_family) %>%
      dplyr::summarise(
        paired_predictions = dplyr::n(),
        OLS_RMSE_cm = sqrt(mean(OLS_residual_cm^2)),
        Huber_RMSE_cm = sqrt(mean(Huber_residual_cm^2)),
        Huber_minus_OLS_RMSE_cm = Huber_RMSE_cm - OLS_RMSE_cm,
        median_absolute_prediction_shift_cm =
          stats::median(absolute_prediction_shift_cm),
        p95_absolute_prediction_shift_cm = as.numeric(stats::quantile(
          absolute_prediction_shift_cm, 0.95, names = FALSE
        )),
        maximum_absolute_prediction_shift_cm =
          max(absolute_prediction_shift_cm),
        .groups = "drop"
      ) %>%
      dplyr::mutate(
        interpretation = paste0(
          "paired out-of-sample comparison on folds where both estimators succeeded"
        )
      )
  }
  list(
    metric_comparison = metric_comparison,
    fold_completeness = fold_completeness,
    prediction_shift = prediction_shift
  )
}

BuildExtremeResidualAudit <- function(validation, selection) {
  if (length(kExtremeResidualThresholdsCm) != 3L ||
      any(diff(kExtremeResidualThresholdsCm) <= 0) ||
      kExtremeResidualRowsExportThresholdCm <
        min(kExtremeResidualThresholdsCm)) {
    stop("Extreme-residual thresholds are not internally consistent.")
  }
  selected <- FilterSelectedPredictions(
    validation$predictions, selection, estimator = "OLS", scheme = "LOPO"
  ) %>%
    dplyr::mutate(absolute_residual_cm = abs(residual_cm))
  summary <- selected %>%
    dplyr::group_by(structural_id, model_family) %>%
    dplyr::summarise(
      out_of_sample_intervals = dplyr::n(),
      median_absolute_residual_cm = stats::median(absolute_residual_cm),
      p95_absolute_residual_cm = as.numeric(stats::quantile(
        absolute_residual_cm, 0.95, names = FALSE
      )),
      p99_absolute_residual_cm = as.numeric(stats::quantile(
        absolute_residual_cm, 0.99, names = FALSE
      )),
      maximum_absolute_residual_cm = max(absolute_residual_cm),
      residuals_above_2_cm = sum(
        absolute_residual_cm > kExtremeResidualThresholdsCm[1]
      ),
      residuals_above_5_cm = sum(
        absolute_residual_cm > kExtremeResidualThresholdsCm[2]
      ),
      residuals_above_10_cm = sum(
        absolute_residual_cm > kExtremeResidualThresholdsCm[3]
      ),
      percent_above_2_cm = 100 * mean(
        absolute_residual_cm > kExtremeResidualThresholdsCm[1]
      ),
      percent_above_5_cm = 100 * mean(
        absolute_residual_cm > kExtremeResidualThresholdsCm[2]
      ),
      percent_above_10_cm = 100 * mean(
        absolute_residual_cm > kExtremeResidualThresholdsCm[3]
      ),
      .groups = "drop"
    ) %>%
    dplyr::mutate(
      treatment = paste0(
        "diagnostic only; all rows retained; robust-loss sensitivity reported separately"
      )
    )
  rows <- selected %>%
    dplyr::filter(
      absolute_residual_cm > kExtremeResidualRowsExportThresholdCm
    ) %>%
    dplyr::group_by(structural_id) %>%
    dplyr::arrange(dplyr::desc(absolute_residual_cm), .by_group = TRUE) %>%
    dplyr::mutate(within_model_absolute_residual_rank = dplyr::row_number()) %>%
    dplyr::ungroup() %>%
    dplyr::arrange(model_family, within_model_absolute_residual_rank)
  list(summary = summary, rows = rows)
}

# 9. FULL-DATA FITS AND ASYMPTOTE PROFILES -----------------------------------

FitFullCandidate <- function(data, specification, signature) {
  cache_path <- file.path(
    kOutputDirectory, "Models", paste0(specification$structural_id, "_fits.rds")
  )
  cached <- ReadCompatibleCache(cache_path, signature)
  if (!is.null(cached)) {
    LogMessage("INFO", paste("Compatible full-fit cache loaded:", specification$structural_id))
    return(cached)
  }
  LogMessage("INFO", paste("Fitting full-data candidate:", specification$structural_id))
  ols <- FitOlsGlobal(
    data, specification, seeds = kFullGlobalSeeds,
    de_itermax = kFullDeIterMax, de_np = kFullDeNp
  )
  fits <- list(OLS = ols)
  if (isTRUE(kRunHuberSensitivity)) {
    huber <- tryCatch(
      FitHuberSensitivity(ols, specification),
      error = function(error) error
    )
    if (inherits(huber, "error")) {
      LogMessage(
        "WARN",
        paste0(
          "Full-data Huber sensitivity failed for ",
          specification$structural_id, ": ", huber$message,
          ". Canonical OLS results remain valid."
        )
      )
    } else {
      fits$Huber <- huber
    }
  }
  if (isTRUE(kRunExploratoryErrorSensitivities)) {
    fits$FGLS <- FitFglsSensitivity(ols, specification)
    fits$Student_t <- FitStudentTSensitivity(ols, specification)
  }
  WriteCache(cache_path, signature, fits)
  fits
}

FitAllFullCandidates <- function(data, signature) {
  results <- list()
  for (structural_id in kStructuralSpecifications$structural_id) {
    specification <- GetSpecification(structural_id)
    results[[structural_id]] <- FitFullCandidate(data, specification, signature)
  }
  results
}

FitFixedAsymptotePoint <- function(raw_data, specification, fixed_asymptote,
                                   reference_fit = NULL) {
  scaler <- ComputeBasalAreaScaler(raw_data)
  data <- ApplyBasalAreaScaler(
    raw_data, scaler, specification$uses_basal_area
  )
  if (fixed_asymptote <= max(c(data$initial_dbh, data$dbh_final))) {
    return(list(success = FALSE, message = "Fixed asymptote is not above observed DBH"))
  }
  bounds <- GetBounds(
    specification, data,
    asymptote_upper = max(kAsymptoteUpper, fixed_asymptote + 1),
    include_asymptote = FALSE
  )
  global_starts <- list()
  global_trace <- list()
  for (index in seq_along(kProfileGlobalSeeds)) {
    seed <- DeterministicSeed(
      specification$structural_id, "profile", fixed_asymptote,
      kProfileGlobalSeeds[index]
    )
    set.seed(seed)
    result <- tryCatch(
      DEoptim::DEoptim(
        fn = function(parameters) {
          WeightedSseObjective(
            parameters, data, specification,
            fixed_asymptote = fixed_asymptote
          )
        },
        lower = bounds$lower,
        upper = bounds$upper,
        control = DEoptim::DEoptim.control(
          itermax = kProfileDeIterMax, NP = kProfileDeNp,
          F = kDeF, CR = kDeCr, trace = FALSE,
          storepopfrom = kProfileDeIterMax + 1L
        )
      ),
      error = function(error) error
    )
    if (!inherits(result, "error")) {
      start <- result$optim$bestmem
      names(start) <- names(bounds$lower)
      global_starts[[length(global_starts) + 1L]] <- start
      global_trace[[length(global_trace) + 1L]] <- data.frame(
        seed = seed, de_objective = result$optim$bestval,
        stringsAsFactors = FALSE
      )
    }
  }
  midpoint <- (bounds$lower + bounds$upper) / 2
  starts <- c(global_starts, list(midpoint))
  if (!is.null(reference_fit)) {
    reference <- reference_fit$coefficients[names(bounds$lower)]
    reference <- pmin(pmax(reference, bounds$lower + 1e-8), bounds$upper - 1e-8)
    starts <- c(starts, list(reference))
  }
  if (length(starts) == 0L) {
    return(list(success = FALSE, message = "All fixed-asymptote global searches failed"))
  }

  local_results <- lapply(starts, function(start) {
    tryCatch(
      stats::optim(
        par = start,
        fn = function(parameters) {
          WeightedSseObjective(
            parameters, data, specification,
            fixed_asymptote = fixed_asymptote
          )
        },
        method = "L-BFGS-B",
        lower = bounds$lower,
        upper = bounds$upper,
        control = list(maxit = 2000, factr = 1e7)
      ),
      error = function(error) NULL
    )
  })
  valid <- which(vapply(
    local_results,
    function(result) !is.null(result) && is.finite(result$value),
    logical(1)
  ))
  if (length(valid) == 0L) {
    return(list(success = FALSE, message = "All fixed-asymptote local refinements failed"))
  }
  best <- local_results[[valid[which.min(vapply(
    local_results[valid], `[[`, numeric(1), "value"
  ))]]]
  global_trace <- dplyr::bind_rows(global_trace)
  list(
    success = TRUE,
    sse = best$value,
    coefficients = best$par,
    local_convergence = best$convergence,
    n_global_starts = length(global_starts),
    n_local_starts = length(starts),
    best_global_de_objective = if (nrow(global_trace) > 0L) {
      min(global_trace$de_objective)
    } else {
      NA_real_
    },
    global_de_objective_range = if (nrow(global_trace) > 0L) {
      max(global_trace$de_objective) - min(global_trace$de_objective)
    } else {
      NA_real_
    },
    global_trace = global_trace,
    message = best$message %||% ""
  )
}

ProfileAsymptote <- function(data, specification, reference_fit, signature) {
  cache_path <- file.path(
    kOutputDirectory, "Cache", "Profiles",
    paste0(specification$structural_id, "_asymptote_profile.rds")
  )
  cached <- ReadCompatibleCache(cache_path, signature)
  if (!is.null(cached)) {
    return(cached)
  }
  points <- lapply(kAsymptoteProfile, function(asymptote) {
    fit <- FitFixedAsymptotePoint(
      data, specification, asymptote, reference_fit = reference_fit
    )
    if (!isTRUE(fit$success)) {
      return(data.frame(
        structural_id = specification$structural_id,
        model_family = specification$model_family,
        uses_basal_area = specification$uses_basal_area,
        estimator = "OLS",
        fixed_asymptote_cm = asymptote, status = "failed", SSE = NA_real_,
        log_rate = NA_real_, basal_area_log_rate_effect = NA_real_,
        shape = NA_real_,
        optimization_solution_accepted = FALSE,
        optimization_acceptance_basis = "fixed-asymptote fit failed",
        global_objective_relative_spread = NA_real_,
        selected_relative_change_from_best_DE = NA_real_,
        local_convergence = NA_integer_, n_global_starts = 0L,
        n_local_starts = 0L, best_global_de_objective = NA_real_,
        global_de_objective_range = NA_real_, global_seeds = NA_character_,
        message = fit$message,
        stringsAsFactors = FALSE
      ))
    }
    expanded <- ExpandParameters(
      fit$coefficients, specification, fixed_asymptote = asymptote
    )
    objective_scale <- if (is.finite(fit$best_global_de_objective)) {
      max(1, abs(fit$best_global_de_objective))
    } else {
      max(1, abs(fit$sse))
    }
    global_objective_relative_spread <-
      fit$global_de_objective_range / objective_scale
    selected_relative_change_from_best_de <-
      (fit$sse - fit$best_global_de_objective) / objective_scale
    formal_local_convergence <- isTRUE(fit$local_convergence == 0L)
    independent_global_agreement <-
      fit$n_global_starts >= kMinimumIndependentUsableLocalMethods &&
      is.finite(global_objective_relative_spread) &&
      global_objective_relative_spread <=
        kOptimizerObjectiveAgreementTolerance &&
      is.finite(selected_relative_change_from_best_de) &&
      abs(selected_relative_change_from_best_de) <=
        kOptimizerObjectiveAgreementTolerance
    solution_accepted <- formal_local_convergence ||
      independent_global_agreement
    data.frame(
      structural_id = specification$structural_id,
      model_family = specification$model_family,
      uses_basal_area = specification$uses_basal_area,
      estimator = "OLS",
      fixed_asymptote_cm = asymptote,
      status = ifelse(solution_accepted, "success", "unaccepted"),
      SSE = fit$sse,
      log_rate = unname(expanded["log_rate"]),
      basal_area_log_rate_effect = unname(
        expanded["basal_area_log_rate_effect"]
      ),
      shape = unname(expanded["shape"]),
      optimization_solution_accepted = solution_accepted,
      optimization_acceptance_basis = if (formal_local_convergence) {
        "formal fixed-asymptote local convergence"
      } else if (independent_global_agreement) {
        paste0(
          "accepted boundary/global solution: independent DE starts and local ",
          "objective agree within relative tolerance ",
          format(kOptimizerObjectiveAgreementTolerance, scientific = TRUE)
        )
      } else {
        "neither formal local convergence nor independent objective agreement"
      },
      global_objective_relative_spread = global_objective_relative_spread,
      selected_relative_change_from_best_DE =
        selected_relative_change_from_best_de,
      local_convergence = fit$local_convergence,
      n_global_starts = fit$n_global_starts,
      n_local_starts = fit$n_local_starts,
      best_global_de_objective = fit$best_global_de_objective,
      global_de_objective_range = fit$global_de_objective_range,
      global_seeds = paste(fit$global_trace$seed, collapse = ","),
      message = fit$message,
      stringsAsFactors = FALSE
    )
  }) %>% dplyr::bind_rows()
  if (!any(points$status == "success")) {
    stop("All asymptote-profile points failed for ", specification$structural_id)
  }
  minimum_sse <- min(points$SSE[points$status == "success"], na.rm = TRUE)
  points <- points %>%
    dplyr::mutate(
      delta_AIC_fixed_profile = ifelse(
        status == "success", nrow(data) * log(SSE / minimum_sse), NA_real_
      ),
      relative_support = ifelse(
        status == "success", exp(-0.5 * delta_AIC_fixed_profile), NA_real_
      )
    )
  WriteCache(cache_path, signature, points)
  points
}

FitFixedAsymptoteHuberPoint <- function(raw_data, specification,
                                        fixed_asymptote,
                                        accepted_ols_profile_row) {
  if (nrow(accepted_ols_profile_row) != 1L ||
      !isTRUE(accepted_ols_profile_row$status == "success") ||
      !isTRUE(accepted_ols_profile_row$optimization_solution_accepted)) {
    return(list(
      success = FALSE,
      message = "The corresponding OLS profile point is absent or unaccepted."
    ))
  }
  scaler <- ComputeBasalAreaScaler(raw_data)
  data <- ApplyBasalAreaScaler(
    raw_data, scaler, specification$uses_basal_area
  )
  if (fixed_asymptote <= max(c(data$initial_dbh, data$dbh_final))) {
    return(list(
      success = FALSE, message = "Fixed asymptote is not above observed DBH."
    ))
  }
  bounds <- GetBounds(
    specification, data,
    asymptote_upper = max(kAsymptoteUpper, fixed_asymptote + 1),
    include_asymptote = FALSE
  )
  start <- c(log_rate = accepted_ols_profile_row$log_rate)
  if (isTRUE(specification$uses_basal_area)) {
    start <- c(
      start,
      basal_area_log_rate_effect =
        accepted_ols_profile_row$basal_area_log_rate_effect
    )
  }
  start <- c(start, shape = accepted_ols_profile_row$shape)
  start <- start[names(bounds$lower)]
  start <- pmin(pmax(start, bounds$lower), bounds$upper)
  ols_prediction <- PredictFromParameters(
    start, data, specification, fixed_asymptote = fixed_asymptote
  )
  fixed_scale <- ComputeRobustResidualScale(data$dbh_final - ols_prediction)
  if (!is.finite(fixed_scale) || fixed_scale <= 0) {
    return(list(
      success = FALSE,
      message = "The accepted OLS profile point did not yield a finite Huber scale."
    ))
  }
  objective <- function(parameters) {
    HuberLossObjective(
      parameters, data, specification, fixed_scale = fixed_scale,
      tuning = kHuberTuningConstant,
      fixed_asymptote = fixed_asymptote
    )
  }
  parameter_scale <- pmax(
    abs(start), (bounds$upper - bounds$lower) / 10, 1e-3
  )
  optim_result <- tryCatch(
    stats::optim(
      par = start, fn = objective, method = "L-BFGS-B",
      lower = bounds$lower, upper = bounds$upper,
      control = list(
        maxit = kLocalOptimMaxIterations,
        factr = kLocalOptimFactr,
        pgtol = kLocalOptimProjectedGradientTolerance,
        parscale = parameter_scale
      )
    ),
    error = function(error) error
  )
  nlminb_result <- tryCatch(
    stats::nlminb(
      start = start, objective = objective,
      lower = bounds$lower, upper = bounds$upper,
      control = list(
        iter.max = kLocalOptimMaxIterations,
        eval.max = max(5000L, 5L * kLocalOptimMaxIterations),
        rel.tol = kLocalOptimRelativeTolerance,
        x.tol = 1e-8
      )
    ),
    error = function(error) error
  )
  candidates <- list()
  traces <- list()
  AddCandidate <- function(method, result, coefficients, value,
                           convergence, iterations, message) {
    prediction <- PredictFromParameters(
      coefficients, data, specification,
      fixed_asymptote = fixed_asymptote
    )
    usable <- all(is.finite(coefficients)) && all(is.finite(prediction)) &&
      is.finite(value) && value < 1e99
    converged <- isTRUE(convergence == 0L) && usable
    traces[[method]] <<- data.frame(
      local_method = method,
      local_convergence_code = if (inherits(result, "error")) {
        NA_integer_
      } else {
        as.integer(convergence)
      },
      local_optimizer_converged = converged,
      local_usable = usable,
      local_objective = if (usable) value else NA_real_,
      local_iterations = as.integer(iterations),
      local_message = message,
      stringsAsFactors = FALSE
    )
    if (usable) {
      candidates[[method]] <<- list(
        method = method, coefficients = coefficients, objective = value,
        converged = converged, convergence_code = convergence,
        iterations = iterations, message = message
      )
    }
  }
  if (inherits(optim_result, "error")) {
    traces[["L-BFGS-B"]] <- data.frame(
      local_method = "L-BFGS-B", local_convergence_code = NA_integer_,
      local_optimizer_converged = FALSE, local_usable = FALSE,
      local_objective = NA_real_, local_iterations = NA_integer_,
      local_message = optim_result$message, stringsAsFactors = FALSE
    )
  } else {
    coefficients <- optim_result$par
    names(coefficients) <- names(bounds$lower)
    AddCandidate(
      "L-BFGS-B", optim_result, coefficients, objective(coefficients),
      optim_result$convergence,
      unname(optim_result$counts[["function"]] %||% NA_integer_),
      as.character(optim_result$message %||% "L-BFGS-B completed")
    )
  }
  if (inherits(nlminb_result, "error")) {
    traces[["nlminb"]] <- data.frame(
      local_method = "nlminb", local_convergence_code = NA_integer_,
      local_optimizer_converged = FALSE, local_usable = FALSE,
      local_objective = NA_real_, local_iterations = NA_integer_,
      local_message = nlminb_result$message, stringsAsFactors = FALSE
    )
  } else {
    coefficients <- nlminb_result$par
    names(coefficients) <- names(bounds$lower)
    AddCandidate(
      "nlminb", nlminb_result, coefficients, objective(coefficients),
      nlminb_result$convergence,
      nlminb_result$iterations %||% NA_integer_,
      as.character(nlminb_result$message %||% "nlminb completed")
    )
  }
  trace <- dplyr::bind_rows(traces)
  if (length(candidates) == 0L) {
    return(list(
      success = FALSE,
      message = paste(unique(trace$local_message), collapse = " | ")
    ))
  }
  converged_candidates <- candidates[vapply(
    candidates, function(candidate) isTRUE(candidate$converged), logical(1)
  )]
  eligible <- if (length(converged_candidates) > 0L) {
    converged_candidates
  } else {
    candidates
  }
  best <- eligible[[which.min(vapply(
    eligible, function(candidate) candidate$objective, numeric(1)
  ))]]
  trace$selected <- trace$local_method == best$method
  assessment <- AssessHuberOptimizationAcceptance(trace)
  if (!isTRUE(assessment$accepted)) {
    return(list(success = FALSE, message = assessment$basis, trace = trace))
  }
  if (length(assessment$independent_usable_methods) != 1L ||
      !is.finite(assessment$independent_usable_methods)) {
    stop(
      "Internal Huber optimizer-metadata contract failed for ",
      specification$structural_id, " at fixed asymptote ",
      fixed_asymptote, " cm."
    )
  }
  prediction <- PredictFromParameters(
    best$coefficients, data, specification,
    fixed_asymptote = fixed_asymptote
  )
  residual <- data$dbh_final - prediction
  standardized <- residual / fixed_scale
  list(
    success = TRUE,
    coefficients = best$coefficients,
    huber_objective = best$objective,
    unweighted_sse = sum(residual^2),
    fixed_ols_scale_cm = fixed_scale,
    downweighted_observations = sum(
      abs(standardized) > kHuberTuningConstant
    ),
    downweighted_fraction = mean(
      abs(standardized) > kHuberTuningConstant
    ),
    optimization_solution_accepted = assessment$accepted,
    optimization_acceptance_basis = assessment$basis,
    independent_usable_local_methods =
      assessment$independent_usable_methods,
    local_objective_relative_spread =
      assessment$local_objective_relative_spread,
    selected_method = best$method,
    selected_convergence_code = best$convergence_code,
    trace = trace,
    message = best$message
  )
}

ProfileHuberAsymptote <- function(data, specification, ols_profile, signature) {
  cache_path <- file.path(
    kOutputDirectory, "Cache", "Profiles",
    paste0(specification$structural_id, "_Huber_asymptote_profile.rds")
  )
  cached <- ReadCompatibleCache(cache_path, signature)
  if (!is.null(cached)) {
    return(cached)
  }
  points <- lapply(kAsymptoteProfile, function(asymptote) {
    ols_row <- ols_profile %>%
      dplyr::filter(
        .data$structural_id == specification$structural_id,
        .data$fixed_asymptote_cm == .env$asymptote,
        .data$status == "success",
        .data$optimization_solution_accepted %in% TRUE
      )
    fit <- FitFixedAsymptoteHuberPoint(
      data, specification, asymptote, ols_row
    )
    if (!isTRUE(fit$success)) {
      return(data.frame(
        structural_id = specification$structural_id,
        model_family = specification$model_family,
        uses_basal_area = specification$uses_basal_area,
        estimator = "Huber", fixed_asymptote_cm = asymptote,
        status = "failed", Huber_objective = NA_real_, SSE = NA_real_,
        log_rate = NA_real_, basal_area_log_rate_effect = NA_real_,
        shape = NA_real_, fixed_OLS_scale_cm = NA_real_,
        Huber_tuning_constant = kHuberTuningConstant,
        downweighted_observations = NA_integer_,
        downweighted_fraction = NA_real_,
        optimization_solution_accepted = FALSE,
        optimization_acceptance_basis = fit$message,
        independent_usable_local_methods = NA_integer_,
        local_objective_relative_spread = NA_real_,
        selected_method = NA_character_, selected_convergence_code = NA_integer_,
        message = fit$message, relative_support = NA_real_,
        delta_AIC_fixed_profile = NA_real_, stringsAsFactors = FALSE
      ))
    }
    expanded <- ExpandParameters(
      fit$coefficients, specification, fixed_asymptote = asymptote
    )
    data.frame(
      structural_id = specification$structural_id,
      model_family = specification$model_family,
      uses_basal_area = specification$uses_basal_area,
      estimator = "Huber", fixed_asymptote_cm = asymptote,
      status = "success", Huber_objective = fit$huber_objective,
      SSE = fit$unweighted_sse,
      log_rate = unname(expanded["log_rate"]),
      basal_area_log_rate_effect = unname(
        expanded["basal_area_log_rate_effect"]
      ),
      shape = unname(expanded["shape"]),
      fixed_OLS_scale_cm = fit$fixed_ols_scale_cm,
      Huber_tuning_constant = kHuberTuningConstant,
      downweighted_observations = fit$downweighted_observations,
      downweighted_fraction = fit$downweighted_fraction,
      optimization_solution_accepted =
        fit$optimization_solution_accepted,
      optimization_acceptance_basis =
        fit$optimization_acceptance_basis,
      independent_usable_local_methods =
        fit$independent_usable_local_methods,
      local_objective_relative_spread =
        fit$local_objective_relative_spread,
      selected_method = fit$selected_method,
      selected_convergence_code = fit$selected_convergence_code,
      message = fit$message,
      relative_support = NA_real_,
      delta_AIC_fixed_profile = NA_real_,
      stringsAsFactors = FALSE
    )
  }) %>% dplyr::bind_rows()
  WriteCache(cache_path, signature, points)
  points
}

BuildAsymptoteIdentificationSummary <- function(full_outputs, ols_profile,
                                                selection) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  full_asymptotes <- full_outputs$coefficients %>%
    dplyr::filter(
      scheme == "Full_data", estimator == "OLS", parameter == "asymptote"
    ) %>%
    dplyr::select(
      structural_id, full_fit_asymptote_cm = estimate
    )
  boundary <- full_outputs$boundary_diagnostics %>%
    dplyr::filter(estimator == "OLS", parameter == "asymptote") %>%
    dplyr::select(
      structural_id, full_fit_asymptote_at_boundary = at_boundary,
      full_fit_relative_distance_to_upper = relative_distance_to_upper
    )
  profile_summary <- ols_profile %>%
    dplyr::filter(
      estimator == "OLS", status == "success",
      optimization_solution_accepted %in% TRUE,
      is.finite(delta_AIC_fixed_profile)
    ) %>%
    dplyr::group_by(structural_id, model_family, uses_basal_area) %>%
    dplyr::summarise(
      accepted_profile_points = dplyr::n(),
      profile_minimum_asymptote_cm = min(fixed_asymptote_cm),
      profile_maximum_asymptote_cm = max(fixed_asymptote_cm),
      minimum_supported_asymptote_cm = min(
        fixed_asymptote_cm[
          delta_AIC_fixed_profile <= kAsymptoteProfileSupportDeltaThreshold
        ]
      ),
      maximum_supported_asymptote_cm = max(
        fixed_asymptote_cm[
          delta_AIC_fixed_profile <= kAsymptoteProfileSupportDeltaThreshold
        ]
      ),
      high_asymptote_points_with_delta_below_threshold = sum(
        fixed_asymptote_cm >= kHighAsymptotePlateauThresholdCm &
          delta_AIC_fixed_profile <= kAsymptoteProfileSupportDeltaThreshold
      ),
      high_asymptote_profile_plateau =
        high_asymptote_points_with_delta_below_threshold >= 2L,
      best_fixed_asymptote_cm = fixed_asymptote_cm[
        which.min(delta_AIC_fixed_profile)
      ][1],
      .groups = "drop"
    )
  summary <- profile_summary %>%
    dplyr::left_join(full_asymptotes, by = "structural_id") %>%
    dplyr::left_join(boundary, by = "structural_id") %>%
    dplyr::mutate(
      selected_for_reporting = structural_id %in% selected_ids,
      asymptote_identification = ifelse(
        full_fit_asymptote_at_boundary %in% TRUE |
          high_asymptote_profile_plateau %in% TRUE,
        "asymptote_not_point_identified",
        "profile_support_concentrated_within_predeclared_grid"
      ),
      full_fit_asymptote_interpretation = paste0(
        "optimization descriptor only; never interpreted as a biological ",
        "maximum diameter or used alone for long-horizon claims"
      ),
      reporting_rule = paste0(
        "report conditional fixed-asymptote profiles; label nonidentification ",
        "when the full fit reaches a bound or at least two profile values >= ",
        kHighAsymptotePlateauThresholdCm, " cm have delta criterion <= ",
        kAsymptoteProfileSupportDeltaThreshold
      )
    ) %>%
    dplyr::arrange(model_family, uses_basal_area)
  checkpoint_pass <- nrow(summary) == nrow(kStructuralSpecifications) &&
    all(!is.na(summary$asymptote_identification)) &&
    all(!is.na(summary$full_fit_asymptote_at_boundary)) &&
    all(is.finite(summary$full_fit_asymptote_cm)) &&
    all(nzchar(summary$full_fit_asymptote_interpretation))
  checkpoint <- data.frame(
    check = c(
      "all OLS structural candidates have an identification classification",
      "boundary and high-asymptote profile plateau are jointly evaluated",
      "full-fit asymptotes are not assigned a biological interpretation"
    ),
    status = c(
      ifelse(checkpoint_pass, "PASS", "FAIL"),
      ifelse(checkpoint_pass, "PASS", "FAIL"),
      ifelse(checkpoint_pass, "PASS", "FAIL")
    ),
    interpretation = c(
      paste(nrow(summary), "of", nrow(kStructuralSpecifications), "candidates"),
      paste0(
        "Profile plateau threshold: A >= ",
        kHighAsymptotePlateauThresholdCm, " cm and delta <= ",
        kAsymptoteProfileSupportDeltaThreshold, "."
      ),
      "Conditional profiles, rather than a full-fit point estimate, govern extrapolation."
    ),
    stringsAsFactors = FALSE
  )
  if (!checkpoint_pass) {
    WriteCsv(checkpoint, "asymptote_identification_checkpoint.csv")
    stop("Asymptote-identification checkpoint failed.")
  }
  list(summary = summary, checkpoint = checkpoint)
}

AssignDiameterSupportClass <- function(values) {
  cut(
    values,
    breaks = kDiameterSupportBreaksCm,
    labels = kDiameterSupportLabels,
    right = FALSE,
    include.lowest = TRUE,
    ordered_result = TRUE
  )
}

BuildDiameterSupportAudit <- function(data) {
  required <- c(
    "initial_dbh", "dbh_final", "tree_id", "species_id", "plot_id",
    "period_label"
  )
  missing <- setdiff(required, names(data))
  if (length(kDiameterSupportLabels) !=
      length(kDiameterSupportBreaksCm) - 1L) {
    stop("Diameter-support labels and breaks are inconsistent.")
  }
  if (length(missing) > 0L) {
    stop(
      "Diameter-support audit is missing columns: ",
      paste(missing, collapse = ", ")
    )
  }
  working <- data %>%
    dplyr::mutate(
      initial_dbh_class = AssignDiameterSupportClass(.data$initial_dbh)
    )
  if (anyNA(working$initial_dbh_class)) {
    stop("At least one initial DBH falls outside the support-class breaks.")
  }
  summary <- working %>%
    dplyr::group_by(initial_dbh_class, .drop = FALSE) %>%
    dplyr::summarise(
      intervals = dplyr::n(),
      unique_trees = dplyr::n_distinct(tree_id),
      species = dplyr::n_distinct(species_id),
      plots = dplyr::n_distinct(plot_id),
      periods = dplyr::n_distinct(period_label),
      minimum_initial_dbh_cm = if (dplyr::n() > 0L) min(initial_dbh) else NA_real_,
      maximum_initial_dbh_cm = if (dplyr::n() > 0L) max(initial_dbh) else NA_real_,
      maximum_final_dbh_cm = if (dplyr::n() > 0L) max(dbh_final) else NA_real_,
      mean_increment_cm = if (dplyr::n() > 0L) {
        mean(dbh_final - initial_dbh)
      } else {
        NA_real_
      },
      .groups = "drop"
    ) %>%
    dplyr::mutate(
      initial_dbh_class = as.character(initial_dbh_class),
      class_order = match(initial_dbh_class, kDiameterSupportLabels),
      class_lower_bound_cm = kDiameterSupportBreaksCm[class_order],
      class_upper_bound_cm = kDiameterSupportBreaksCm[class_order + 1L],
      empirical_support_level = dplyr::case_when(
        unique_trees >= kBroadDiameterSupportMinimumTrees &
          species >= kBroadDiameterSupportMinimumSpecies &
          plots >= kBroadDiameterSupportMinimumPlots ~ "broad",
        unique_trees >= kLimitedDiameterSupportMinimumTrees &
          species >= kLimitedDiameterSupportMinimumSpecies &
          plots >= kLimitedDiameterSupportMinimumPlots ~ "limited",
        TRUE ~ "sparse"
      ),
      empirical_support_warning = dplyr::case_when(
        empirical_support_level == "broad" ~
          "broad representation by the predeclared descriptive rule",
        empirical_support_level == "limited" ~ paste0(
          "limited representation; emphasize uncertainty and avoid class-specific claims"
        ),
        TRUE ~ paste0(
          "sparse representation; scenario start is assumption-dominated and not empirically validated"
        )
      ),
      support_rule = paste0(
        "broad: >=", kBroadDiameterSupportMinimumTrees, " trees, >=",
        kBroadDiameterSupportMinimumSpecies, " species, >=",
        kBroadDiameterSupportMinimumPlots, " plots; limited: >=",
        kLimitedDiameterSupportMinimumTrees, " trees, >=",
        kLimitedDiameterSupportMinimumSpecies, " species, >=",
        kLimitedDiameterSupportMinimumPlots, " plots; otherwise sparse"
      )
    ) %>%
    dplyr::arrange(class_order)
  summary
}

BuildDbhClassValidation <- function(validation, selection) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  selected_predictions <- validation$predictions %>%
    dplyr::filter(
      scheme %in% c("LOPO", "Temporal"),
      (structural_id %in% selected_ids & estimator %in% c("OLS", "Huber")) |
        (structural_id == "Persistence" & estimator == "Persistence")
    ) %>%
    dplyr::mutate(
      initial_dbh_class = as.character(
        AssignDiameterSupportClass(initial_dbh_cm)
      )
    )
  if (nrow(selected_predictions) == 0L ||
      anyNA(selected_predictions$initial_dbh_class)) {
    stop("Initial-DBH-class validation has no usable out-of-sample predictions.")
  }
  model_grid <- selected_predictions %>%
    dplyr::distinct(
      scheme, structural_id, model_family, uses_basal_area, estimator
    )
  expected_estimators <- c("OLS", "Persistence")
  if (isTRUE(kRunHuberSensitivity)) {
    expected_estimators <- c(expected_estimators, "Huber")
  }
  selected_model_grid <- expand.grid(
    scheme = c("LOPO", "Temporal"),
    structural_id = selected_ids,
    estimator = setdiff(expected_estimators, "Persistence"),
    stringsAsFactors = FALSE
  ) %>%
    dplyr::left_join(
      kStructuralSpecifications,
      by = "structural_id"
    ) %>%
    dplyr::select(
      scheme, structural_id, model_family, uses_basal_area, estimator
    )
  persistence_grid <- data.frame(
    scheme = c("LOPO", "Temporal"),
    structural_id = "Persistence", model_family = "Persistence",
    uses_basal_area = FALSE, estimator = "Persistence",
    stringsAsFactors = FALSE
  )
  expected_model_grid <- dplyr::bind_rows(
    selected_model_grid, persistence_grid
  )
  missing_models <- dplyr::anti_join(
    expected_model_grid, model_grid,
    by = c(
      "scheme", "structural_id", "model_family",
      "uses_basal_area", "estimator"
    )
  )
  support <- selected_predictions %>%
    dplyr::filter(estimator == "Persistence") %>%
    dplyr::group_by(scheme, initial_dbh_class) %>%
    dplyr::summarise(
      support_intervals = dplyr::n(),
      support_unique_trees = dplyr::n_distinct(tree_id),
      support_species = dplyr::n_distinct(species_id),
      support_plots = dplyr::n_distinct(plot_id),
      support_periods = dplyr::n_distinct(period_label),
      .groups = "drop"
    ) %>%
    dplyr::mutate(
      empirical_support_level = dplyr::case_when(
        support_unique_trees >= kBroadDiameterSupportMinimumTrees &
          support_species >= kBroadDiameterSupportMinimumSpecies &
          support_plots >= kBroadDiameterSupportMinimumPlots ~ "broad",
        support_unique_trees >= kLimitedDiameterSupportMinimumTrees &
          support_species >= kLimitedDiameterSupportMinimumSpecies &
          support_plots >= kLimitedDiameterSupportMinimumPlots ~ "limited",
        TRUE ~ "sparse"
      )
    )
  metrics <- selected_predictions %>%
    dplyr::group_by(
      scheme, structural_id, model_family, uses_basal_area, estimator,
      initial_dbh_class
    ) %>%
    dplyr::summarise(
      intervals = dplyr::n(),
      unique_trees = dplyr::n_distinct(tree_id),
      species = dplyr::n_distinct(species_id),
      plots = dplyr::n_distinct(plot_id),
      periods = dplyr::n_distinct(period_label),
      RMSE_final_cm = sqrt(mean(residual_cm^2)),
      MAE_final_cm = mean(abs(residual_cm)),
      mean_error_final_cm = mean(residual_cm),
      RMSE_annualized_cm_yr = sqrt(mean(annualized_residual_cm_yr^2)),
      MAE_annualized_cm_yr = mean(abs(annualized_residual_cm_yr)),
      .groups = "drop"
    )
  complete_grid <- tidyr::crossing(
    expected_model_grid,
    initial_dbh_class = kDiameterSupportLabels
  )
  complete_metrics <- complete_grid %>%
    dplyr::left_join(
      metrics,
      by = c(
        "scheme", "structural_id", "model_family", "uses_basal_area",
        "estimator", "initial_dbh_class"
      )
    ) %>%
    dplyr::left_join(
      support, by = c("scheme", "initial_dbh_class")
    ) %>%
    dplyr::mutate(
      class_order = match(initial_dbh_class, kDiameterSupportLabels),
      dplyr::across(
        c(
          intervals, unique_trees, species, plots, periods,
          support_intervals, support_unique_trees, support_species,
          support_plots, support_periods
        ),
        ~dplyr::coalesce(as.integer(.x), 0L)
      ),
      empirical_support_level = dplyr::coalesce(
        empirical_support_level, "sparse"
      ),
      class_specific_inference_status = ifelse(
        support_plots < kDbhClassMinimumPlotsForComparativeDescription |
          support_intervals <
            kDbhClassMinimumIntervalsForComparativeDescription |
          empirical_support_level == "sparse",
        "descriptive_only_no_class_specific_inference",
        "internal_comparative_validation_within_supported_class"
      ),
      interpretation = ifelse(
        class_specific_inference_status ==
          "descriptive_only_no_class_specific_inference",
        paste0(
          "Sparse support or fewer than the predeclared minimum plots/intervals; ",
          "report descriptively without a class-specific inferential claim."
        ),
        paste0(
          "Internal out-of-sample comparison within the monitored plots and ",
          "periods; not external validation."
        )
      )
    )
  persistence_metrics <- complete_metrics %>%
    dplyr::filter(estimator == "Persistence") %>%
    dplyr::select(
      scheme, initial_dbh_class,
      persistence_RMSE_final_cm = RMSE_final_cm,
      persistence_MAE_final_cm = MAE_final_cm,
      persistence_RMSE_annualized_cm_yr = RMSE_annualized_cm_yr
    )
  complete_metrics <- complete_metrics %>%
    dplyr::left_join(
      persistence_metrics,
      by = c("scheme", "initial_dbh_class")
    ) %>%
    dplyr::mutate(
      RMSE_gain_over_persistence_cm =
        persistence_RMSE_final_cm - RMSE_final_cm,
      MAE_gain_over_persistence_cm =
        persistence_MAE_final_cm - MAE_final_cm,
      RMSE_annualized_gain_over_persistence_cm_yr =
        persistence_RMSE_annualized_cm_yr - RMSE_annualized_cm_yr
    ) %>%
    dplyr::arrange(scheme, class_order, estimator, model_family)
  count_reconciliation <- complete_metrics %>%
    dplyr::group_by(scheme, structural_id, estimator) %>%
    dplyr::summarise(
      summarized_intervals = sum(intervals),
      expected_intervals = sum(support_intervals),
      reconciled = summarized_intervals == expected_intervals,
      .groups = "drop"
    )
  checkpoint_pass <- c(
    nrow(missing_models) == 0L,
    nrow(complete_metrics) ==
      nrow(expected_model_grid) * length(kDiameterSupportLabels),
    all(count_reconciliation$reconciled),
    !any(
      complete_metrics$support_plots <
        kDbhClassMinimumPlotsForComparativeDescription &
        complete_metrics$class_specific_inference_status !=
          "descriptive_only_no_class_specific_inference"
    )
  )
  checkpoint <- data.frame(
    check = c(
      "selected OLS, Huber, and persistence models are present",
      "all initial-DBH classes are retained for every validation model",
      "class-specific interval counts reconcile to validation totals",
      "classes represented by fewer than three plots are descriptive only"
    ),
    status = ifelse(checkpoint_pass, "PASS", "FAIL"),
    interpretation = c(
      paste(nrow(missing_models), "missing model-design combinations"),
      paste(nrow(complete_metrics), "complete class-model rows"),
      paste(sum(!count_reconciliation$reconciled), "count mismatch(es)"),
      paste0(
        "Minimum for comparative description: ",
        kDbhClassMinimumPlotsForComparativeDescription, " plots and ",
        kDbhClassMinimumIntervalsForComparativeDescription, " intervals."
      )
    ),
    stringsAsFactors = FALSE
  )
  if (any(checkpoint$status == "FAIL")) {
    WriteCsv(checkpoint, "DBH_class_validation_checkpoint.csv")
    WriteCsv(
      count_reconciliation,
      "DBH_class_count_reconciliation_failure.csv"
    )
    stop(
      "Initial-DBH-class validation checkpoint failed; inspect ",
      "DBH_class_validation_checkpoint.csv."
    )
  }
  list(
    LOPO = complete_metrics %>% dplyr::filter(scheme == "LOPO"),
    Temporal = complete_metrics %>% dplyr::filter(scheme == "Temporal"),
    combined = complete_metrics,
    checkpoint = checkpoint,
    count_reconciliation = count_reconciliation
  )
}

BuildScenarioStartSupport <- function(diameter_support) {
  starts <- data.frame(
    initial_dbh_cm = kManagementScenarioInitialDbhCm,
    initial_dbh_class = as.character(
      AssignDiameterSupportClass(kManagementScenarioInitialDbhCm)
    ),
    stringsAsFactors = FALSE
  )
  support <- diameter_support %>%
    dplyr::select(
      initial_dbh_class,
      empirical_intervals_in_class = intervals,
      empirical_unique_trees_in_class = unique_trees,
      empirical_species_in_class = species,
      empirical_plots_in_class = plots,
      empirical_periods_in_class = periods,
      empirical_support_level,
      empirical_support_warning,
      support_rule
    )
  result <- starts %>%
    dplyr::left_join(support, by = "initial_dbh_class")
  if (anyNA(result$empirical_support_level)) {
    stop("Scenario starts could not be reconciled to diameter-support classes.")
  }
  result
}

ProjectRepeatedAnnualSteps <- function(parameters, initial_dbh, years,
                                       specification, basal_area_z = 0) {
  if (length(years) != 1L || !is.finite(years) || years < 0 ||
      abs(years - round(years)) > 1e-12) {
    stop("Repeated-step projection requires one non-negative integer year.")
  }
  current_dbh <- initial_dbh
  if (years == 0L) {
    return(as.numeric(current_dbh))
  }
  for (step in seq_len(as.integer(years))) {
    projection_data <- data.frame(
      initial_dbh = current_dbh,
      interval_years_value = 1,
      basal_area_z = basal_area_z
    )
    current_dbh <- PredictFromParameters(
      parameters, projection_data, specification
    )
    if (length(current_dbh) != 1L || !is.finite(current_dbh)) {
      stop(
        "Non-finite repeated-step projection for ",
        specification$structural_id, " at step ", step, "."
      )
    }
  }
  as.numeric(current_dbh)
}

ClassifyProjectionHorizon <- function(years, maximum_empirical_interval) {
  dplyr::case_when(
    years <= maximum_empirical_interval ~ "empirically_evaluated_interval",
    years <= 10 ~ "short_horizon_sensitivity",
    years <= 35 ~ "management_cycle_sensitivity",
    TRUE ~ "long_term_structural_sensitivity"
  )
}

BuildConditionalManagementScenarios <- function(data, selection, profile,
                                                huber_profile = data.frame()) {
  empty <- list(
    trajectories = data.frame(
      structural_id = character(), model_family = character(), estimator = character(),
      fixed_asymptote_cm = numeric(), initial_dbh_cm = numeric(),
      projection_year = integer(), direct_projected_dbh_cm = numeric(),
      stringsAsFactors = FALSE
    ),
    OLS_trajectories = data.frame(),
    Huber_trajectories = data.frame(),
    family_envelope = data.frame(
      model_family = character(), initial_dbh_cm = numeric(),
      projection_year = integer(), median_projected_increment_cm = numeric(),
      stringsAsFactors = FALSE
    ),
    overall_envelope = data.frame(
      initial_dbh_cm = numeric(), projection_year = integer(),
      median_projected_increment_cm = numeric(), stringsAsFactors = FALSE
    ),
    estimator_envelope = data.frame(),
    combined_envelope = data.frame(),
    estimator_sensitivity = data.frame(),
    horizon_summary = data.frame(
      structural_id = character(), model_family = character(),
      fixed_asymptote_cm = numeric(), initial_dbh_cm = numeric(),
      projection_year = integer(), direct_projected_dbh_cm = numeric(),
      stringsAsFactors = FALSE
    ),
    horizon_envelope_diagnostics = data.frame(
      initial_dbh_cm = numeric(), projection_year = integer(),
      envelope_width_cm = numeric(), stringsAsFactors = FALSE
    ),
    diameter_threshold_crossings = data.frame(
      structural_id = character(), model_family = character(),
      fixed_asymptote_cm = numeric(), initial_dbh_cm = numeric(),
      target_dbh_cm = numeric(), first_crossing_year = numeric(),
      stringsAsFactors = FALSE
    ),
    empirical_diameter_support = data.frame(
      initial_dbh_class = character(), unique_trees = integer(),
      species = integer(), plots = integer(),
      empirical_support_level = character(), stringsAsFactors = FALSE
    ),
    scenario_start_support = data.frame(
      initial_dbh_cm = numeric(), initial_dbh_class = character(),
      empirical_support_level = character(), stringsAsFactors = FALSE
    ),
    assumptions = data.frame(
      component = "conditional scenarios", treatment = "disabled by configuration",
      stringsAsFactors = FALSE
    ),
    invariance_audit = data.frame(
      audit = "projection step invariance", maximum_absolute_difference_cm = NA_real_,
      tolerance_cm = kProjectionStepInvarianceToleranceCm, status = "NOT_RUN",
      interpretation = "conditional scenarios disabled by configuration",
      stringsAsFactors = FALSE
    ),
    Huber_long_horizon_checkpoint = data.frame()
  )
  if (!isTRUE(kEnableConditionalManagementScenarios)) {
    return(empty)
  }
  if (any(diff(kManagementTrajectoryYears) != 1L) ||
      min(kManagementTrajectoryYears) != 0L ||
      !all(kManagementHorizonYears %in% kManagementTrajectoryYears)) {
    stop("Conditional trajectory years must be consecutive from zero and contain all horizons.")
  }
  maximum_observed_dbh <- max(c(data$initial_dbh, data$dbh_final))
  if (any(kManagementScenarioAsymptotesCm <= maximum_observed_dbh)) {
    stop("Every scenario asymptote must exceed the maximum observed DBH.")
  }
  if (any(kManagementScenarioInitialDbhCm <= 0) ||
      any(kManagementScenarioInitialDbhCm >= min(kManagementScenarioAsymptotesCm))) {
    stop("Scenario initial DBH values must be positive and below every scenario asymptote.")
  }
  if (any(kLargeDiameterThresholdsCm <= 0) ||
      anyDuplicated(kLargeDiameterThresholdsCm) > 0L) {
    stop("Large-diameter thresholds must be unique and positive.")
  }
  diameter_support <- BuildDiameterSupportAudit(data)
  scenario_start_support <- BuildScenarioStartSupport(diameter_support)

  selected_ids <- unname(SelectedStructuralIds(selection))
  ols_scenario_profile <- profile %>%
    dplyr::filter(
      .data$structural_id %in% .env$selected_ids,
      .data$fixed_asymptote_cm %in% .env$kManagementScenarioAsymptotesCm,
      .data$status == "success",
      .data$optimization_solution_accepted %in% TRUE
    ) %>%
    dplyr::mutate(estimator = "OLS")
  expected_estimators <- "OLS"
  if (isTRUE(kRunHuberSensitivity)) {
    expected_estimators <- c(expected_estimators, "Huber")
    if (!is.data.frame(huber_profile) || nrow(huber_profile) == 0L) {
      stop(
        "Huber fixed-asymptote profiles are required for FEM-10 conditional scenarios."
      )
    }
  }
  huber_scenario_profile <- if (isTRUE(kRunHuberSensitivity)) {
    huber_profile %>%
      dplyr::filter(
        .data$structural_id %in% .env$selected_ids,
        .data$fixed_asymptote_cm %in% .env$kManagementScenarioAsymptotesCm,
        .data$status == "success",
        .data$optimization_solution_accepted %in% TRUE
      ) %>%
      dplyr::mutate(estimator = "Huber")
  } else {
    data.frame()
  }
  scenario_profile <- dplyr::bind_rows(
    ols_scenario_profile, huber_scenario_profile
  )
  expected_grid <- expand.grid(
    estimator = expected_estimators,
    structural_id = selected_ids,
    fixed_asymptote_cm = kManagementScenarioAsymptotesCm,
    stringsAsFactors = FALSE
  )
  observed_grid <- scenario_profile %>%
    dplyr::distinct(estimator, structural_id, fixed_asymptote_cm)
  missing_grid <- dplyr::anti_join(
    expected_grid, observed_grid,
    by = c("estimator", "structural_id", "fixed_asymptote_cm")
  )
  if (nrow(missing_grid) > 0L ||
      anyDuplicated(observed_grid) > 0L) {
    stop(
      paste0(
        "The estimator-by-structure fixed-asymptote profile is incomplete for ",
        "the conditional 5-90-year scenario grid."
      )
    )
  }

  rows <- list()
  row_index <- 0L
  maximum_empirical_interval <- max(data$interval_years_value)
  empirical_dbh_range <- range(c(data$initial_dbh, data$dbh_final))
  for (profile_index in seq_len(nrow(scenario_profile))) {
    profile_row <- scenario_profile[profile_index, , drop = FALSE]
    specification <- GetSpecification(profile_row$structural_id)
    parameters <- c(
      asymptote = profile_row$fixed_asymptote_cm,
      log_rate = profile_row$log_rate
    )
    if (isTRUE(specification$uses_basal_area)) {
      parameters <- c(
        parameters,
        basal_area_log_rate_effect = profile_row$basal_area_log_rate_effect
      )
    }
    parameters <- c(parameters, shape = profile_row$shape)
    if (any(!is.finite(parameters))) {
      stop("A scenario profile contains non-finite fitted parameters.")
    }
    for (initial_dbh in kManagementScenarioInitialDbhCm) {
      direct_data <- data.frame(
        initial_dbh = rep(initial_dbh, length(kManagementTrajectoryYears)),
        interval_years_value = kManagementTrajectoryYears,
        basal_area_z = 0
      )
      direct <- PredictFromParameters(parameters, direct_data, specification)
      repeated <- vapply(
        kManagementTrajectoryYears,
        function(year) ProjectRepeatedAnnualSteps(
          parameters, initial_dbh, year, specification, basal_area_z = 0
        ),
        numeric(1)
      )
      row_index <- row_index + 1L
      rows[[row_index]] <- data.frame(
        structural_id = profile_row$structural_id,
        model_family = profile_row$model_family,
        estimator = profile_row$estimator,
        fixed_asymptote_cm = profile_row$fixed_asymptote_cm,
        asymptote_profile_relative_support = profile_row$relative_support,
        initial_dbh_cm = initial_dbh,
        projection_year = kManagementTrajectoryYears,
        direct_projected_dbh_cm = direct,
        repeated_annual_projected_dbh_cm = repeated,
        absolute_step_invariance_difference_cm = abs(direct - repeated),
        projected_increment_cm = direct - initial_dbh,
        empirical_maximum_interval_years = maximum_empirical_interval,
        empirical_minimum_dbh_cm = empirical_dbh_range[1],
        empirical_maximum_dbh_cm = empirical_dbh_range[2],
        initial_dbh_within_empirical_range =
          initial_dbh >= empirical_dbh_range[1] &
          initial_dbh <= empirical_dbh_range[2],
        horizon_to_empirical_interval_ratio =
          kManagementTrajectoryYears / maximum_empirical_interval,
        within_empirical_interval_domain =
          kManagementTrajectoryYears <= maximum_empirical_interval,
        projection_horizon_class = ClassifyProjectionHorizon(
          kManagementTrajectoryYears, maximum_empirical_interval
        ),
        projected_dbh_within_observed_domain =
          direct >= empirical_dbh_range[1] & direct <= empirical_dbh_range[2],
        scenario_status = ifelse(
          kManagementTrajectoryYears <= maximum_empirical_interval,
          "empirically_evaluated_time_domain",
          "conditional_stationary_survivor_DBH_sensitivity_only"
        ),
        stringsAsFactors = FALSE
      )
    }
  }
  trajectories <- dplyr::bind_rows(rows) %>%
    dplyr::left_join(scenario_start_support, by = "initial_dbh_cm")
  maximum_invariance_difference <- max(
    trajectories$absolute_step_invariance_difference_cm, na.rm = TRUE
  )
  if (!is.finite(maximum_invariance_difference) ||
      maximum_invariance_difference > kProjectionStepInvarianceToleranceCm) {
    stop(
      "Projection step-invariance audit failed: maximum difference = ",
      maximum_invariance_difference, " cm."
    )
  }
  OLS_trajectories <- trajectories %>%
    dplyr::filter(estimator == "OLS")
  Huber_trajectories <- trajectories %>%
    dplyr::filter(estimator == "Huber")
  family_envelope <- OLS_trajectories %>%
    dplyr::group_by(model_family, initial_dbh_cm, projection_year) %>%
    dplyr::summarise(
      lower_projected_dbh_cm = min(direct_projected_dbh_cm),
      median_projected_dbh_cm = stats::median(direct_projected_dbh_cm),
      upper_projected_dbh_cm = max(direct_projected_dbh_cm),
      lower_projected_increment_cm = min(projected_increment_cm),
      median_projected_increment_cm = stats::median(projected_increment_cm),
      upper_projected_increment_cm = max(projected_increment_cm),
      fixed_asymptote_scenarios = dplyr::n_distinct(fixed_asymptote_cm),
      .groups = "drop"
    ) %>%
    dplyr::left_join(scenario_start_support, by = "initial_dbh_cm")
  estimator_envelope <- trajectories %>%
    dplyr::group_by(estimator, initial_dbh_cm, projection_year) %>%
    dplyr::summarise(
      lower_projected_dbh_cm = min(direct_projected_dbh_cm),
      median_projected_dbh_cm = stats::median(direct_projected_dbh_cm),
      upper_projected_dbh_cm = max(direct_projected_dbh_cm),
      lower_projected_increment_cm = min(projected_increment_cm),
      median_projected_increment_cm = stats::median(projected_increment_cm),
      upper_projected_increment_cm = max(projected_increment_cm),
      structural_scenarios = dplyr::n(),
      .groups = "drop"
    ) %>%
    dplyr::left_join(scenario_start_support, by = "initial_dbh_cm") %>%
    dplyr::mutate(
      envelope_width_cm = upper_projected_dbh_cm - lower_projected_dbh_cm,
      envelope_width_relative_to_median = ifelse(
        median_projected_dbh_cm > 0,
        envelope_width_cm / median_projected_dbh_cm,
        NA_real_
      ),
      projection_horizon_class = ClassifyProjectionHorizon(
        projection_year, maximum_empirical_interval
      ),
      interpretation = paste0(
        "range across selected model families and fixed-asymptote scenarios ",
        "within the named estimator; not a confidence or prediction interval"
      )
    )
  overall_envelope <- estimator_envelope %>%
    dplyr::filter(estimator == "OLS")
  combined_envelope <- trajectories %>%
    dplyr::group_by(initial_dbh_cm, projection_year) %>%
    dplyr::summarise(
      lower_projected_dbh_cm = min(direct_projected_dbh_cm),
      median_projected_dbh_cm = stats::median(direct_projected_dbh_cm),
      upper_projected_dbh_cm = max(direct_projected_dbh_cm),
      lower_projected_increment_cm = min(projected_increment_cm),
      median_projected_increment_cm = stats::median(projected_increment_cm),
      upper_projected_increment_cm = max(projected_increment_cm),
      structural_scenarios = dplyr::n(),
      .groups = "drop"
    ) %>%
    dplyr::left_join(scenario_start_support, by = "initial_dbh_cm") %>%
    dplyr::mutate(
      envelope_width_cm = upper_projected_dbh_cm - lower_projected_dbh_cm,
      envelope_width_relative_to_median = ifelse(
        median_projected_dbh_cm > 0,
        envelope_width_cm / median_projected_dbh_cm,
        NA_real_
      ),
      projection_horizon_class = ClassifyProjectionHorizon(
        projection_year, maximum_empirical_interval
      ),
      interpretation = paste0(
        "union across OLS and Huber, selected model families, and all fixed-",
        "asymptote scenarios; sensitivity range only; ",
        "not a confidence or prediction interval"
      )
    )
  estimator_sensitivity <- estimator_envelope %>%
    dplyr::select(
      estimator, initial_dbh_cm, projection_year,
      lower_projected_dbh_cm, median_projected_dbh_cm,
      upper_projected_dbh_cm, envelope_width_cm
    ) %>%
    tidyr::pivot_wider(
      names_from = estimator,
      values_from = c(
        lower_projected_dbh_cm, median_projected_dbh_cm,
        upper_projected_dbh_cm, envelope_width_cm
      ),
      names_glue = "{estimator}_{.value}"
    ) %>%
    dplyr::left_join(
      combined_envelope %>%
        dplyr::select(
          initial_dbh_cm, projection_year,
          combined_lower_projected_dbh_cm = lower_projected_dbh_cm,
          combined_median_projected_dbh_cm = median_projected_dbh_cm,
          combined_upper_projected_dbh_cm = upper_projected_dbh_cm,
          combined_envelope_width_cm = envelope_width_cm
        ),
      by = c("initial_dbh_cm", "projection_year")
    ) %>%
    dplyr::mutate(
      Huber_minus_OLS_median_projected_dbh_cm =
        Huber_median_projected_dbh_cm - OLS_median_projected_dbh_cm,
      Huber_extends_below_OLS_envelope =
        Huber_lower_projected_dbh_cm < OLS_lower_projected_dbh_cm,
      Huber_extends_above_OLS_envelope =
        Huber_upper_projected_dbh_cm > OLS_upper_projected_dbh_cm,
      Huber_extends_outside_OLS_envelope =
        Huber_extends_below_OLS_envelope |
          Huber_extends_above_OLS_envelope,
      combined_minus_OLS_envelope_width_cm =
        combined_envelope_width_cm - OLS_envelope_width_cm,
      interpretation = paste0(
        "estimator sensitivity under the same fixed-asymptote grid; the ",
        "combined envelope is a deterministic sensitivity range, not an interval"
      )
    )
  horizon_summary <- trajectories %>%
    dplyr::filter(.data$projection_year %in% .env$kManagementHorizonYears) %>%
    dplyr::arrange(
      initial_dbh_cm, projection_year, estimator, model_family,
      fixed_asymptote_cm
    )
  horizon_envelope_diagnostics <- combined_envelope %>%
    dplyr::filter(.data$projection_year %in% .env$kManagementHorizonYears) %>%
    dplyr::mutate(
      empirically_validated = projection_year <= maximum_empirical_interval,
      long_horizon_warning = ifelse(
        projection_horizon_class == "long_term_structural_sensitivity",
        paste0(
          "50-90-year result is an assumption-driven stress test; uncertainty ",
          "from parameters, process, mortality and recruitment is not propagated"
        ),
        "interpret according to projection_horizon_class"
      )
    ) %>%
    dplyr::arrange(initial_dbh_cm, projection_year)

  diameter_threshold_crossings <- trajectories %>%
    tidyr::crossing(target_dbh_cm = kLargeDiameterThresholdsCm) %>%
    dplyr::group_by(
      structural_id, model_family, estimator, fixed_asymptote_cm,
      asymptote_profile_relative_support, initial_dbh_cm, target_dbh_cm
    ) %>%
    dplyr::summarise(
      first_crossing_year = if (any(
        direct_projected_dbh_cm >= target_dbh_cm
      )) {
        min(projection_year[direct_projected_dbh_cm >= target_dbh_cm])
      } else {
        NA_real_
      },
      .groups = "drop"
    ) %>%
    dplyr::left_join(scenario_start_support, by = "initial_dbh_cm") %>%
    dplyr::mutate(
      crossing_status = dplyr::case_when(
        target_dbh_cm <= initial_dbh_cm ~ "already_at_or_above_threshold",
        target_dbh_cm >= fixed_asymptote_cm ~ "not_reachable_under_fixed_asymptote",
        !is.na(first_crossing_year) ~ "reached_within_90_year_sensitivity_window",
        TRUE ~ "not_reached_within_90_year_sensitivity_window"
      ),
      first_crossing_horizon_class = ifelse(
        is.na(first_crossing_year), NA_character_,
        ClassifyProjectionHorizon(
          first_crossing_year, maximum_empirical_interval
        )
      ),
      crossing_time_resolution = "one year",
      interpretation = paste0(
        "conditional first passage for a surviving tree under stationary fitted ",
        "parameters; not a species-specific minimum logging diameter or harvest age"
      )
    ) %>%
    dplyr::arrange(
      initial_dbh_cm, target_dbh_cm, estimator, model_family,
      fixed_asymptote_cm
    )
  invariance_audit <- data.frame(
    audit = "direct horizon versus repeated one-year steps",
    maximum_absolute_difference_cm = maximum_invariance_difference,
    tolerance_cm = kProjectionStepInvarianceToleranceCm,
    status = "PASS",
    interpretation = paste0(
      "numerical consistency under time-invariant parameters only; it does not ",
      "validate ecological stationarity"
    ),
    stringsAsFactors = FALSE
  )
  estimator_union_check <- estimator_envelope %>%
    dplyr::group_by(initial_dbh_cm, projection_year) %>%
    dplyr::summarise(
      expected_lower = min(lower_projected_dbh_cm),
      expected_upper = max(upper_projected_dbh_cm),
      .groups = "drop"
    ) %>%
    dplyr::left_join(
      combined_envelope %>%
        dplyr::select(
          initial_dbh_cm, projection_year,
          observed_lower = lower_projected_dbh_cm,
          observed_upper = upper_projected_dbh_cm
        ),
      by = c("initial_dbh_cm", "projection_year")
    )
  monotonicity_check <- trajectories %>%
    dplyr::arrange(
      estimator, structural_id, fixed_asymptote_cm,
      initial_dbh_cm, projection_year
    ) %>%
    dplyr::group_by(
      estimator, structural_id, fixed_asymptote_cm, initial_dbh_cm
    ) %>%
    dplyr::summarise(
      minimum_annual_change_cm = min(diff(direct_projected_dbh_cm)),
      .groups = "drop"
    )
  expected_huber_rows <- if (isTRUE(kRunHuberSensitivity)) {
    length(selected_ids) * length(kManagementScenarioAsymptotesCm) *
      length(kManagementScenarioInitialDbhCm) *
      length(kManagementTrajectoryYears)
  } else {
    0L
  }
  checkpoint_pass <- c(
    nrow(missing_grid) == 0L && anyDuplicated(observed_grid) == 0L,
    nrow(Huber_trajectories) == expected_huber_rows,
    all(is.finite(trajectories$direct_projected_dbh_cm)),
    all(monotonicity_check$minimum_annual_change_cm >= -1e-8),
    maximum_invariance_difference <= kProjectionStepInvarianceToleranceCm,
    all(abs(
      estimator_union_check$expected_lower -
        estimator_union_check$observed_lower
    ) <= 1e-10) && all(abs(
      estimator_union_check$expected_upper -
        estimator_union_check$observed_upper
    ) <= 1e-10),
    !any(
      horizon_envelope_diagnostics$projection_year >
        maximum_empirical_interval &
        horizon_envelope_diagnostics$empirically_validated
    )
  )
  Huber_long_horizon_checkpoint <- data.frame(
    check = c(
      "estimator-by-structure asymptote grid is complete",
      "Huber trajectory grid has the expected row count",
      "all conditional trajectory values are finite",
      "all conditional trajectories are non-decreasing",
      "direct and repeated annual projections are invariant",
      "combined envelope contains every OLS and Huber envelope",
      "extrapolated horizons are never labeled empirically validated"
    ),
    status = ifelse(checkpoint_pass, "PASS", "FAIL"),
    interpretation = c(
      paste(nrow(observed_grid), "accepted estimator-structure-asymptote points"),
      paste(nrow(Huber_trajectories), "of", expected_huber_rows, "rows"),
      "Finite predictions are required before reporting sensitivity envelopes.",
      paste0(
        "Minimum one-year change = ",
        format(min(monotonicity_check$minimum_annual_change_cm), digits = 8),
        " cm."
      ),
      paste0(
        "Maximum absolute discrepancy = ",
        format(maximum_invariance_difference, digits = 8), " cm."
      ),
      "The combined range is the exact union of estimator-specific ranges.",
      "Only monitored interval lengths can be described as empirically evaluated."
    ),
    stringsAsFactors = FALSE
  )
  if (any(Huber_long_horizon_checkpoint$status == "FAIL")) {
    WriteCsv(
      Huber_long_horizon_checkpoint,
      "Huber_long_horizon_checkpoint.csv"
    )
    stop(
      "FEM-10 long-horizon estimator-sensitivity checkpoint failed; inspect ",
      "Huber_long_horizon_checkpoint.csv."
    )
  }
  assumptions <- data.frame(
    component = c(
      "empirical validation horizon", "empirical DBH domain",
      "initial-DBH empirical support",
      "scenario horizons", "horizon tiers", "large-diameter thresholds",
      "state variable", "parameter stationarity", "structural uncertainty",
      "estimator sensitivity",
      "asymptote uncertainty", "uncertainty meaning", "baseline basal area",
      "excluded processes", "scientific role of 90 years",
      "management interpretation"
    ),
    treatment = c(
      sprintf("observed intervals only, up to %.2f years", maximum_empirical_interval),
      sprintf(
        "observed survivor DBH range %.2f-%.2f cm; starts outside this range are flagged",
        empirical_dbh_range[1], empirical_dbh_range[2]
      ),
      paste0(
        "every scenario start is linked to interval, tree, species and plot counts ",
        "for its predeclared initial-DBH class; broad/limited/sparse labels are ",
        "descriptive and do not establish long-horizon validity"
      ),
      paste(kManagementHorizonYears, collapse = ", "),
      paste0(
        "5-10 years = short sensitivity; 25-35 years = management-cycle ",
        "sensitivity; 50-90 years = long-term structural sensitivity"
      ),
      paste0(
        paste(kLargeDiameterThresholdsCm, collapse = ", "),
        " cm; first passage is reported at one-year resolution"
      ),
      "diameter of a surviving tree already present at scenario start",
      "all fitted parameters held constant throughout projection",
      "Richards and Lundqvist retained when practically indistinguishable",
      paste0(
        "OLS is canonical; direct fixed-OLS-scale Huber M-estimation is a ",
        "robust-loss sensitivity; the combined union is not an interval"
      ),
      paste0(
        "unweighted sensitivity envelope over the complete predefined profile A = ",
        paste(kManagementScenarioAsymptotesCm, collapse = ", "),
        " cm; no favorable post-profile subset"
      ),
      paste0(
        "scenario range, not a confidence or prediction interval; parameter and ",
        "process uncertainty are not propagated"
      ),
      "z_BA = 0 (training-plot mean) if the selected structure contains BA",
      "mortality, recruitment, harvest damage/response, abundance and volume",
      paste0(
        "biologically relevant lifetime-scale stress test supported by tropical ",
        "tree-ring studies, but not empirically calibrated by this short panel"
      ),
      "hypothesis-generating sensitivity; not a cutting-cycle recommendation"
    ),
    stringsAsFactors = FALSE
  )
  list(
    trajectories = trajectories,
    OLS_trajectories = OLS_trajectories,
    Huber_trajectories = Huber_trajectories,
    family_envelope = family_envelope,
    overall_envelope = overall_envelope,
    estimator_envelope = estimator_envelope,
    combined_envelope = combined_envelope,
    estimator_sensitivity = estimator_sensitivity,
    horizon_summary = horizon_summary,
    horizon_envelope_diagnostics = horizon_envelope_diagnostics,
    diameter_threshold_crossings = diameter_threshold_crossings,
    empirical_diameter_support = diameter_support,
    scenario_start_support = scenario_start_support,
    assumptions = assumptions,
    invariance_audit = invariance_audit,
    Huber_long_horizon_checkpoint = Huber_long_horizon_checkpoint
  )
}

BuildFullFitOutputs <- function(data, full_fits) {
  predictions <- list()
  summaries <- list()
  coefficients <- list()
  optimizers <- list()
  identifiability_summary <- list()
  singular_values <- list()
  boundaries <- list()
  counter <- 0L
  for (structural_id in names(full_fits)) {
    for (estimator in names(full_fits[[structural_id]])) {
      counter <- counter + 1L
      fit <- full_fits[[structural_id]][[estimator]]
      prediction_rows <- BuildPredictionRows(fit, data, "Full_data", "all")
      summary <- BuildFoldSummary(
        prediction_rows, nrow(data), nrow(data),
        dplyr::n_distinct(data$plot_id), dplyr::n_distinct(data$plot_id)
      )
      parameter_count <- length(fit$coefficients)
      summary$Gaussian_AIC <- if (estimator == "OLS") {
        nrow(data) * (
          log(2 * pi) + 1 + log(fit$unweighted_sse / nrow(data))
        ) + 2 * (parameter_count + 1)
      } else {
        NA_real_
      }
      summary$Gaussian_BIC <- if (estimator == "OLS") {
        nrow(data) * (
          log(2 * pi) + 1 + log(fit$unweighted_sse / nrow(data))
        ) + log(nrow(data)) * (parameter_count + 1)
      } else {
        NA_real_
      }
      summary$information_criterion_scope <- if (estimator == "OLS") {
        "descriptive in-sample Gaussian criterion; not the primary selection basis"
      } else {
        "not computed for sensitivity estimator"
      }
      summary$local_optimizer_converged <- fit$converged
      summary$optimization_solution_accepted <-
        fit$optimization_solution_accepted %||% fit$converged
      summary$optimization_acceptance_basis <-
        fit$optimization_acceptance_basis %||% fit$convergence_message
      summary$independent_usable_local_methods <-
        fit$independent_usable_local_methods %||% NA_integer_
      summary$local_objective_relative_spread <-
        fit$local_objective_relative_spread %||% NA_real_
      summary$selected_relative_change_from_DE <-
        fit$selected_relative_change_from_DE %||% NA_real_
      summary$IRLS_converged <- fit$irls_converged
      assessment <- AssessIdentifiability(fit)
      predictions[[counter]] <- prediction_rows
      summaries[[counter]] <- summary
      coefficients[[counter]] <- ExtractCoefficientRows(fit, "Full_data", "all")
      optimizers[[counter]] <- ExtractOptimizerRows(fit, "Full_data", "all")
      identifiability_summary[[counter]] <- assessment$summary
      singular_values[[counter]] <- assessment$singular_values
      boundaries[[counter]] <- assessment$boundary
    }
  }
  list(
    predictions = dplyr::bind_rows(predictions),
    summary = dplyr::bind_rows(summaries),
    coefficients = dplyr::bind_rows(coefficients),
    optimizer_diagnostics = dplyr::bind_rows(optimizers),
    identifiability = dplyr::bind_rows(identifiability_summary),
    singular_values = dplyr::bind_rows(singular_values),
    boundary_diagnostics = dplyr::bind_rows(boundaries)
  )
}

# 10. AUDIT TABLES AND METHODS METADATA --------------------------------------

BuildDataAudit <- function(raw_data, prepared) {
  data <- prepared$data
  community_data <- prepared$eligible_community_data
  period_source <- raw_data %>%
    dplyr::filter(as.character(period_pair) %in% kModelingPeriods)
  AddAuditRow <- function(item, value, note) {
    data.frame(
      item = item, value = as.character(value), note = note,
      stringsAsFactors = FALSE
    )
  }
  summary <- dplyr::bind_rows(
    AddAuditRow("input_rows_total", nrow(raw_data), "Source workbook; not modified"),
    AddAuditRow(
      "rows_in_predefined_modeling_periods", nrow(period_source),
      "Only predeclared measured periods enter model fitting"
    ),
    AddAuditRow(
      "eligible_community_intervals", nrow(community_data),
      "All eligible non-negative survivor intervals before any explicit species filter"
    ),
    AddAuditRow(
      "analytical_intervals", nrow(data),
      "Intervals in the explicitly configured taxonomic scope"
    ),
    AddAuditRow("analysis_scope", prepared$analysis_scope,
                "Controlled jointly by kAnalysisScopeMode and kTargetSpecies"),
    AddAuditRow("analysis_unique_trees", dplyr::n_distinct(data$tree_id),
                "Plot:tag identifier"),
    AddAuditRow("analysis_unique_species", dplyr::n_distinct(data$species_id),
                "Normalized genus plus specific epithet"),
    AddAuditRow(
      "maximum_observed_initial_or_final_DBH_cm",
      max(c(data$initial_dbh, data$dbh_final)),
      "Must remain below the predeclared prediction-domain asymptote floor"
    ),
    AddAuditRow(
      "prediction_domain_asymptote_floor_cm",
      kPredictionDomainAsymptoteFloorCm,
      "Fixed before validation and not adapted to held-out folds"
    ),
    AddAuditRow(
      "commercial_registry_intervals_in_scope", sum(data$commercial_listed),
      "Exact match to the embedded Commercial_registry sheet"
    ),
    AddAuditRow(
      "permitted_commercial_intervals_in_scope",
      sum(data$commercial_permission_class == "permitted"),
      "Registry classification after protected-status precedence"
    ),
    AddAuditRow(
      "protected_commercial_intervals_in_scope",
      sum(data$commercial_permission_class == "protected"),
      "Includes any taxon with a protected source row"
    ),
    AddAuditRow(
      "registry_conflict_intervals_in_scope",
      sum(data$commercial_registry_conflict),
      "Conflict remains visible; protected status prevails"
    ),
    AddAuditRow("identified_species_intervals", sum(data$taxon_identified),
                "Taxon audit; unidentified records remain explicit"),
    AddAuditRow("analysis_unique_plots", dplyr::n_distinct(data$plot_id),
                "Six independent 1-ha plots"),
    AddAuditRow("predefined_periods", length(kModelingPeriods),
                paste(kModelingPeriods, collapse = "; ")),
    AddAuditRow("excluded_placeholder_periods",
                paste(kExcludedPlaceholderPeriods, collapse = "; "),
                "Excluded only after the automated all-zero survivor audit"),
    AddAuditRow("excluded_placeholder_source_rows",
                sum(prepared$excluded_period_audit$source_rows),
                "See excluded_placeholder_period_audit.csv"),
    AddAuditRow(
      "zero_increments_retained", sum(data$increment_cm == 0),
      paste0(
        "Retained from the supplied analytical workbook; documentary ",
        "verification is reported in data_curation_provenance.csv"
      )
    ),
    AddAuditRow(
      "high_annual_increments_retained",
      sum(data$annual_increment_cm_yr > kHighAnnualIncrementAuditThreshold),
      paste0(
        "Retained without outlier deletion; documentary verification is ",
        "reported in data_curation_provenance.csv"
      )
    ),
    AddAuditRow(
      "negative_survivor_rows_in_supplied_workbook",
      prepared$negative_growth_rows_in_supplied_workbook,
      "Pipeline stops if this value is nonzero"
    ),
    AddAuditRow(
      "negative_rows_removed_upstream_count",
      if (!is.null(prepared$data_curation_provenance)) {
        negative_record <- prepared$data_curation_provenance$provenance %>%
          dplyr::filter(
            expected_event_type == "negative_increment_removed_upstream"
          )
        if (nrow(negative_record) == 1L &&
            negative_record$curation_status == "DOCUMENTED") {
          negative_record$affected_rows_reported_in_audit
        } else {
          NA_character_
        }
      } else {
        NA_character_
      },
      paste0(
        "Reported only when documented in ", kCurationAuditSheet,
        "; otherwise unavailable"
      )
    ),
    AddAuditRow("non_target_status_rows_excluded", prepared$non_target_class_rows,
                "Excluded by the predefined survivor-status rule"),
    AddAuditRow(
      "analytical_exact_duplicates",
      sum(duplicated(data %>% dplyr::select(-analysis_row_id))),
      "Pipeline stops if exact analytical duplicates occur"
    ),
    AddAuditRow(
      "consecutive_interval_continuity_failures",
      sum(abs(prepared$continuity$continuity_difference_cm) > 1e-8),
      "Checked only for consecutive observations within the same tree"
    )
  )
  by_plot_period <- data %>%
    dplyr::group_by(plot_id, period_label) %>%
    dplyr::summarise(
      intervals = dplyr::n(), unique_trees = dplyr::n_distinct(tree_id),
      mean_initial_dbh_cm = mean(initial_dbh),
      mean_increment_cm = mean(increment_cm),
      zero_increments = sum(increment_cm == 0),
      high_annual_increments = sum(
        annual_increment_cm_yr > kHighAnnualIncrementAuditThreshold
      ),
      .groups = "drop"
    )
  list(summary = summary, by_plot_period = by_plot_period)
}

BuildSpeciesCompositionAudit <- function(prepared) {
  requested_species <- sort(unique(trimws(kTargetSpecies)))
  requested_species <- requested_species[nzchar(requested_species)]
  prepared$eligible_community_data %>%
    dplyr::group_by(
      species_id, genus_name, specific_epithet, taxon_identified,
      commercial_listed, commercial_permission_class,
      commercial_registry_conflict
    ) %>%
    dplyr::summarise(
      intervals = dplyr::n(),
      unique_trees = dplyr::n_distinct(tree_id),
      plots = dplyr::n_distinct(plot_id),
      periods = dplyr::n_distinct(period_label),
      mean_initial_dbh_cm = mean(initial_dbh),
      maximum_observed_dbh_cm = max(dbh_final),
      mean_increment_cm = mean(increment_cm),
      .groups = "drop"
    ) %>%
    dplyr::mutate(
      configured_scope = if (length(requested_species) == 0L) {
        "included: eligible community"
      } else ifelse(
        .data$species_id %in% .env$requested_species,
        "included: explicit target species", "excluded: outside explicit target"
      )
    ) %>%
    dplyr::arrange(dplyr::desc(intervals), species_id)
}

BuildInferenceScopeTable <- function(data) {
  interval_range <- range(data$interval_years_value)
  data.frame(
    inference_level = c(
      "empirically evaluated", "short conditional sensitivity",
      "management-cycle conditional sensitivity",
      "long-term structural sensitivity", "not supported"
    ),
    quantity = c(
      "survivor final DBH over monitored short intervals",
      "stationary survivor DBH trajectories at 5 and 10 years",
      "stationary survivor DBH trajectories at 25, 30 and 35 years",
      "stationary survivor DBH trajectories at 50, 70 and 90 years and first passage to large DBH",
      "cutting-cycle recommendation or stand/volume recovery"
    ),
    evidence_or_assumption = c(
      sprintf(
        paste0(
          "internal plot-blocked and progressive temporal validation; ",
          "OLS canonical with direct Huber robust-loss sensitivity; ",
          "interval range %.2f-%.2f years"
        ),
        interval_range[1], interval_range[2]
      ),
      paste0(
        "semigroup projection under time-invariant parameters; OLS/Huber ",
        "sensitivity envelope across Richards/Lundqvist and fixed asymptotes ",
        paste(kManagementScenarioAsymptotesCm, collapse = ", "), " cm"
      ),
      paste0(
        "same stationary semigroup projection; horizons coincide with current ",
        "management-cycle scales but are not validation"
      ),
      paste0(
        "lifetime-scale extrapolation motivated by tropical tree-ring literature; ",
        "OLS/Huber union-envelope width, initial-DBH support counts and domain flags quantify ",
        "structural divergence and empirical sparsity, not total uncertainty"
      ),
      "mortality, recruitment, harvest response, species-specific abundance and merchantable volume are not modeled"
    ),
    permitted_interpretation = c(
      "short-interval predictive performance within the monitored forest",
      "near-term extrapolation stress test",
      "management-horizon structural sensitivity, not a cycle recommendation",
      "hypothesis-generating long-term stress test only",
      "none from this diameter-survivor model alone"
    ),
    stringsAsFactors = FALSE
  )
}

BuildScenarioLiteratureBasisTable <- function() {
  data.frame(
    reference = c(
      "Tome et al. (2006)",
      "Conde et al. (2024)",
      "Myllymaki et al. (2024)",
      "Martinez et al. (2025)"
    ),
    DOI = c(
      "10.1139/X06-065",
      "10.1016/j.jenvman.2023.119781",
      "10.1016/j.ecolmodel.2024.110669",
      "10.1016/j.ecolmodel.2024.110949"
    ),
    methodological_relevance = c(
      paste0(
        "age-independent Richards and Lundqvist difference equations can be ",
        "projection-length invariant under time-invariant parameters"
      ),
      paste0(
        "Amazonian floodplain tree-ring models yielded species-specific minimum ",
        "logging diameters of 36-90 cm and felling cycles of 6-21 years"
      ),
      paste0(
        "projection uncertainty associated with plot effects can become high ",
        "when accumulated over many years"
      ),
      paste0(
        "tree-ring data cover much more of tree life history than short permanent-plot panels; ",
        "serial growth dependence must be considered"
      )
    ),
    implication_for_current_pipeline = c(
      "supports the equation architecture and numerical step-invariance audit, not ecological stationarity",
      "supports reporting large-diameter and long-life horizons as biologically relevant sensitivity targets",
      "requires widening structural envelopes and explicit warnings at long horizons",
      "prevents interpreting 50-90-year panel extrapolations as dendrochronologically validated trajectories"
    ),
    stringsAsFactors = FALSE
  )
}

BuildModelSpecificationTable <- function() {
  kStructuralSpecifications %>%
    dplyr::mutate(
      rate_definition = ifelse(
        model_family == "Richards",
        "k(z) = exp(log_rate + beta_BA * z_BA)",
        "rho(z) = exp(log_rate + beta_BA * z_BA), rho = k^(-1/m)"
      ),
      equation = ifelse(
        model_family == "Richards",
        "D2=A*[1-exp(-k(z)*dt)*(1-(D1/A)^(1-m))]^(1/(1-m))",
        "D2=A*exp(-[(-1/log(D1/A))^(1/m)+rho(z)*dt]^(-m))"
      ),
      basal_area_definition = ifelse(
        uses_basal_area,
        "fixed complete-inventory 2013 plot BA, centered/scaled on unique training plots",
        "not included (beta_BA fixed to zero)"
      ),
      primary_estimator = "unweighted nonlinear least squares",
      sensitivity_estimators = ifelse(
        kRunHuberSensitivity,
        paste0(
          "direct fixed-OLS-scale Huber M-estimation in LOPO, temporal and ",
          "full data, plus fixed-asymptote long-horizon profiles for selected ",
          "structures; OLS remains canonical; FGLS/Student-t IRLS disabled"
        ),
        "disabled; canonical reporting is OLS with blocked validation"
      ),
      long_horizon_estimator_sensitivity = ifelse(
        kRunHuberSensitivity,
        paste0(
          "for each selected structure and every fixed asymptote, direct Huber ",
          "M-estimation starts from the accepted OLS profile solution and uses ",
          "that solution's fixed robust residual scale; OLS, Huber, and union ",
          "envelopes are reported separately"
        ),
        "not run"
      ),
      primary_validation = paste0(
        "internal leave-one-plot-out spatially blocked validation across ",
        length(kTargetPlots), " monitored plots"
      ),
      complementary_validation = "progressive temporal",
      stress_test = "leave-two-plots-out; OLS only",
      optimization_acceptance = paste0(
        "formal local convergence, or finite DE solution confirmed by >= ",
        kMinimumIndependentUsableLocalMethods,
        " independent bounded local methods with relative objective agreement <= ",
        format(kOptimizerObjectiveAgreementTolerance, scientific = TRUE)
      ),
      prediction_domain_control = paste0(
        "predeclared asymptote floor ",
        kPredictionDomainAsymptoteFloorCm,
        " cm in every fold; never derived from held-out observations"
      ),
      asymptote_profile_acceptance = paste0(
        "formal local convergence, or >= ",
        kMinimumIndependentUsableLocalMethods,
        " deterministic DE starts plus local objective agreeing within relative tolerance ",
        format(kOptimizerObjectiveAgreementTolerance, scientific = TRUE)
      ),
      asymptote_identification_rule = paste0(
        "not point-identified when the full OLS asymptote reaches a bound or ",
        "at least two profile values >= ",
        kHighAsymptotePlateauThresholdCm,
        " cm have delta criterion <= ",
        kAsymptoteProfileSupportDeltaThreshold,
        "; full-fit A is never a biological maximum-diameter estimate"
      ),
      inferential_scope = paste0(
        "short-interval prediction; 5-90-year outputs are conditional stationary ",
        "survivor-DBH OLS/Huber sensitivities, with 50-90 years explicitly treated as ",
        "long-term structural stress tests rather than forecasts"
      )
    )
}

BuildConfigurationTable <- function() {
  configuration <- data.frame(
    setting = c(
      "model_specification_version", "base_seed", "full_global_seeds",
      "profile_global_seeds", "full_DE_iterations", "full_DE_population",
      "CV_DE_iterations", "CV_DE_population", "profile_DE_iterations",
      "profile_DE_population", "local_optimizer_primary",
      "local_optimizer_fallback", "local_optimizer_max_iterations",
      "local_optimizer_factr", "local_optimizer_projected_gradient_tolerance",
      "local_optimizer_relative_tolerance",
      "optimizer_objective_agreement_tolerance",
      "minimum_independent_usable_local_methods", "asymptote_upper_cm",
      "prediction_domain_asymptote_floor_cm", "asymptote_profile_cm",
      "asymptote_profile_delta_support_threshold",
      "high_asymptote_plateau_threshold_cm",
      "log_rate_bounds", "basal_area_effect_bounds",
      "Richards_shape_bounds", "Lundqvist_shape_bounds",
      "Huber_sensitivity_enabled", "Huber_tuning_constant",
      "Huber_minimum_scale_cm", "extreme_residual_thresholds_cm",
      "extreme_residual_rows_export_threshold_cm",
      "FGLS_max_iterations", "Student_t_max_iterations",
      "Student_t_degrees_freedom", "IRLS_tolerance",
      "BA_minimum_practical_RMSE_gain_cm", "BA_minimum_winning_plot_folds",
      "LOPO_cluster_bootstrap_replicates", "LOPO_cluster_bootstrap_seed",
      "publication_figure_exports", "publication_figure_text_handling",
      "long_term_projection"
    ),
    value = c(
      kModelSpecVersion, kBaseSeed, paste(kFullGlobalSeeds, collapse = ","),
      paste(kProfileGlobalSeeds, collapse = ","), kFullDeIterMax, kFullDeNp,
      kCvDeIterMax, kCvDeNp, kProfileDeIterMax, kProfileDeNp,
      "L-BFGS-B", "nlminb", kLocalOptimMaxIterations, kLocalOptimFactr,
      kLocalOptimProjectedGradientTolerance, kLocalOptimRelativeTolerance,
      kOptimizerObjectiveAgreementTolerance,
      kMinimumIndependentUsableLocalMethods,
      kAsymptoteUpper, kPredictionDomainAsymptoteFloorCm,
      paste(kAsymptoteProfile, collapse = ","),
      kAsymptoteProfileSupportDeltaThreshold,
      kHighAsymptotePlateauThresholdCm,
      paste(kLogRateBounds, collapse = ","),
      paste(kBasalAreaEffectBounds, collapse = ","),
      paste(kRichardsShapeBounds, collapse = ","),
      paste(kLundqvistShapeBounds, collapse = ","),
      kRunHuberSensitivity, kHuberTuningConstant, kHuberMinimumScaleCm,
      paste(kExtremeResidualThresholdsCm, collapse = ","),
      kExtremeResidualRowsExportThresholdCm,
      kFglsMaxIterations, kStudentTMaxIterations,
      kStudentTDegreesFreedom, kIrlsConvergenceTolerance,
      kMinimumPracticalBaGainCm, kMinimumBaWinningPlots,
      kLopoClusterBootstrapReplicates, kLopoClusterBootstrapSeed,
      paste0(
        "double-column target width 190 mm; practical maximum height 230 mm; TIFF at ",
        kPublicationFigureDpi,
        " dpi with LZW compression plus vector PDF"
      ),
      paste0(
        "automatic title/subtitle/caption wrapping, base font ",
        kPublicationBaseFontSizePt,
        " pt, enlarged multi-panel heights and publication margins"
      ),
      paste0(
        "conditional 5-90-year stationary survivor-DBH sensitivity; 50-90 years ",
        "are long-term structural stress tests; no cutting-cycle inference"
      )
    ),
    stringsAsFactors = FALSE
  )
  scope_configuration <- data.frame(
    setting = c(
      "planned_analysis_scopes", "analysis_scope_mode", "analysis_scope",
      "explicit_target_species", "consolidated_input_workbook",
      "growth_data_sheet", "commercial_registry_sheet",
      "data_curation_audit_sheet",
      "require_documented_curation_audit",
      "block_model_fitting_when_curation_incomplete",
      "frozen_curation_requirements",
      "zero_increment_curation_policy",
      "protected_status_overrides_permission",
      "species_diagnostic_minimum_intervals",
      "species_diagnostic_minimum_trees",
      "species_diagnostic_minimum_plots",
      "excluded_placeholder_periods",
      "high_annual_increment_audit_threshold_cm_yr",
      "direct_Huber_sensitivity_enabled",
      "exploratory_error_sensitivities_enabled",
      "family_practical_RMSE_difference_cm",
      "conditional_management_scenarios_enabled",
      "conditional_horizons_years", "conditional_trajectory_years",
      "conditional_fixed_asymptotes_cm", "conditional_initial_DBH_cm",
      "large_diameter_thresholds_cm",
      "projection_step_invariance_tolerance_cm",
      "diameter_support_breaks_cm",
      "broad_diameter_support_minimum_trees",
      "broad_diameter_support_minimum_species",
      "broad_diameter_support_minimum_plots",
      "limited_diameter_support_minimum_trees",
      "limited_diameter_support_minimum_species",
      "limited_diameter_support_minimum_plots",
      "DBH_class_comparative_minimum_intervals",
      "DBH_class_comparative_minimum_plots"
    ),
    value = c(
      paste(kPlannedAnalysisScopes, collapse = ","),
      kAnalysisScopeMode,
      AnalysisScopeLabel(),
      if (length(kTargetSpecies) == 0L) "none; eligible community" else
        paste(sort(unique(kTargetSpecies)), collapse = "; "),
      normalizePath(kDataFile, mustWork = FALSE),
      kDataSheet,
      kCommercialSpeciesSheet,
      kCurationAuditSheet,
      kRequireDocumentedCurationAudit,
      kBlockModelFittingWhenCurationIncomplete,
      paste(
        c(
          "negative_increment_removed_upstream",
          "high_annual_increment_retained",
          "placeholder_period_exclusion"
        ),
        collapse = "; "
      ),
      "retained and exported diagnostically; not a publication-freeze requirement",
      kProtectedStatusOverridesPermission,
      kMinimumSpeciesIntervalsForDiagnostics,
      kMinimumSpeciesTreesForDiagnostics,
      kMinimumSpeciesPlotsForDiagnostics,
      paste(kExcludedPlaceholderPeriods, collapse = "; "),
      kHighAnnualIncrementAuditThreshold,
      kRunHuberSensitivity,
      kRunExploratoryErrorSensitivities,
      kMinimumPracticalFamilyRmseDifferenceCm,
      kEnableConditionalManagementScenarios,
      paste(kManagementHorizonYears, collapse = ","),
      paste(range(kManagementTrajectoryYears), collapse = "-"),
      paste(kManagementScenarioAsymptotesCm, collapse = ","),
      paste(kManagementScenarioInitialDbhCm, collapse = ","),
      paste(kLargeDiameterThresholdsCm, collapse = ","),
      kProjectionStepInvarianceToleranceCm,
      paste(kDiameterSupportBreaksCm, collapse = ","),
      kBroadDiameterSupportMinimumTrees,
      kBroadDiameterSupportMinimumSpecies,
      kBroadDiameterSupportMinimumPlots,
      kLimitedDiameterSupportMinimumTrees,
      kLimitedDiameterSupportMinimumSpecies,
      kLimitedDiameterSupportMinimumPlots,
      kDbhClassMinimumIntervalsForComparativeDescription,
      kDbhClassMinimumPlotsForComparativeDescription
    ),
    stringsAsFactors = FALSE
  )
  dplyr::bind_rows(scope_configuration, configuration)
}

BuildFigureExportSpecification <- function() {
  data.frame(
    component = c(
      "target width", "maximum figure height", "raster format", "raster resolution",
      "raster compression", "vector companion", "base font",
      "text overflow control", "multi-panel control"
    ),
    specification = c(
      paste0("190 mm (", round(kPublicationDoubleColumnWidthIn, 3), " in)"),
      paste0("230 mm (", round(kPublicationMaximumHeightIn, 3), " in)"),
      "RGB TIFF", paste(kPublicationFigureDpi, "dpi"), "LZW",
      "PDF", paste(kPublicationBaseFontSizePt, "pt sans"),
      "automatic wrapping of title, subtitle, and caption",
      paste(
        "expanded height, publication margins, and at most",
        kPublicationMaximumFacetColumns, "facets per row"
      )
    ),
    publication_rationale = c(
      "Elsevier double-column full-width target",
      "practical full-page cap that leaves room for the manuscript caption",
      "lossless submission artwork",
      "exceeds the 500-dpi minimum for combination artwork",
      "lossless file-size reduction",
      "scalable text and line work",
      "remains above the recommended minimum after placement at target width",
      "prevents right-edge clipping of long methodological subtitles",
      "preserves panel labels, axes, and legends at final size"
    ),
    stringsAsFactors = FALSE
  )
}

# 11. PUBLICATION-QUALITY FIGURES ---------------------------------------------

WrapPublicationPlotText <- function(plot, width_inches) {
  wrap_label <- function(value, characters_per_inch) {
    if (!is.character(value) || length(value) != 1L || !nzchar(value)) {
      return(value)
    }
    paste(
      base::strwrap(
        value,
        width = max(45L, as.integer(width_inches * characters_per_inch))
      ),
      collapse = "\n"
    )
  }
  plot$labels$title <- wrap_label(plot$labels$title, 10)
  plot$labels$subtitle <- wrap_label(plot$labels$subtitle, 11)
  plot$labels$caption <- wrap_label(plot$labels$caption, 11)
  plot
}

SavePublicationPlot <- function(plot, filename, width = 8, height = 6,
                                directory = file.path(
                                  kOutputDirectory, "Figures"
                                ), write_pdf = TRUE) {
  if (!dir.exists(directory)) {
    dir.create(directory, recursive = TRUE, showWarnings = FALSE)
  }
  width <- min(width, kPublicationDoubleColumnWidthIn)
  height <- min(height, kPublicationMaximumHeightIn)
  plot <- WrapPublicationPlotText(plot, width)
  path <- file.path(directory, filename)
  ggplot2::ggsave(
    filename = path, plot = plot, device = "tiff",
    dpi = kPublicationFigureDpi,
    width = width, height = height, units = "in", compression = "lzw",
    bg = "white", limitsize = FALSE
  )
  pdf_path <- NA_character_
  if (isTRUE(write_pdf)) {
    pdf_path <- file.path(
      directory,
      paste0(tools::file_path_sans_ext(filename), ".pdf")
    )
    ggplot2::ggsave(
      filename = pdf_path, plot = plot, device = "pdf",
      width = width, height = height, units = "in", bg = "white",
      limitsize = FALSE
    )
  }
  invisible(c(TIFF = path, PDF = pdf_path))
}

SelectedStructuralIds <- function(selection) {
  stats::setNames(selection$selected_structural_id, selection$model_family)
}

FilterSelectedPredictions <- function(predictions, selection,
                                      estimator = NULL, scheme = NULL) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  result <- predictions %>%
    dplyr::filter(.data$structural_id %in% .env$selected_ids)
  if (!is.null(estimator)) {
    result <- result %>% dplyr::filter(.data$estimator %in% .env$estimator)
  }
  if (!is.null(scheme)) {
    result <- result %>% dplyr::filter(.data$scheme %in% .env$scheme)
  }
  result
}

BuildCommunityStructurePlot <- function(data) {
  plot_data <- data %>%
    dplyr::filter(period_label == kModelingPeriods[1]) %>%
    dplyr::mutate(plot_id = factor(plot_id))
  ggplot2::ggplot(plot_data, ggplot2::aes(x = plot_id, y = initial_dbh)) +
    ggplot2::geom_violin(fill = "#BFD7EA", color = "#3B5368", linewidth = 0.35) +
    ggplot2::geom_boxplot(width = 0.16, outlier.shape = NA, fill = "white", linewidth = 0.35) +
    ggplot2::labs(
      x = "Plot", y = "Initial DBH (cm)",
      title = "Diameter structure of the configured analysis population"
    ) +
    kPublicationTheme
}

BuildCombinedDiagnosticsPlot <- function(predictions, selection) {
  data <- FilterSelectedPredictions(
    predictions, selection, estimator = "OLS", scheme = "Full_data"
  ) %>%
    dplyr::mutate(model_family = factor(model_family, c("Richards", "Lundqvist")))
  ggplot2::ggplot(
    data,
    ggplot2::aes(x = predicted_final_dbh_cm, y = residual_cm, color = model_family)
  ) +
    ggplot2::geom_hline(yintercept = 0, color = "grey40", linewidth = 0.35) +
    ggplot2::geom_point(alpha = 0.22, size = 0.55) +
    ggplot2::geom_smooth(method = "loess", se = FALSE, linewidth = 0.7) +
    ggplot2::facet_wrap(~model_family, ncol = 1) +
    ggplot2::scale_color_manual(values = kModelColors, guide = "none") +
    ggplot2::labs(
      x = "Predicted final DBH (cm)", y = "Residual (observed - predicted; cm)",
      title = "In-sample residual diagnostics for LOPO-selected structures"
    ) +
    kPublicationTheme
}

BuildObservedEstimatedCommunityPlot <- function(predictions, selection,
                                                family = NULL) {
  data <- FilterSelectedPredictions(
    predictions, selection, estimator = "OLS", scheme = "Full_data"
  )
  if (!is.null(family)) {
    data <- data %>%
      dplyr::filter(.data$model_family == .env$family)
  }
  long <- data %>%
    dplyr::select(
      model_family, plot_id, observed_final_dbh_cm, predicted_final_dbh_cm
    ) %>%
    tidyr::pivot_longer(
      cols = c(observed_final_dbh_cm, predicted_final_dbh_cm),
      names_to = "series", values_to = "final_dbh_cm"
    ) %>%
    dplyr::mutate(
      series = factor(
        series,
        c("observed_final_dbh_cm", "predicted_final_dbh_cm"),
        c("Observed", "Predicted")
      ),
      plot_id = factor(plot_id)
    )
  ggplot2::ggplot(long, ggplot2::aes(x = plot_id, y = final_dbh_cm, fill = series)) +
    ggplot2::geom_boxplot(
      position = ggplot2::position_dodge(width = 0.8), width = 0.65,
      outlier.shape = NA, linewidth = 0.3
    ) +
    ggplot2::facet_wrap(~model_family, ncol = 1) +
    ggplot2::scale_fill_manual(values = c("Observed" = "#999999", "Predicted" = "#56B4E9")) +
    ggplot2::labs(
      x = "Plot", y = "Final DBH (cm)", fill = NULL,
      title = "Observed and fitted analysis-population diameter distributions"
    ) +
    kPublicationTheme
}

BuildResidualCommunityPlot <- function(predictions, selection, family = NULL) {
  data <- FilterSelectedPredictions(
    predictions, selection, estimator = "OLS", scheme = "Full_data"
  )
  if (!is.null(family)) {
    data <- data %>%
      dplyr::filter(.data$model_family == .env$family)
  }
  data <- data %>% dplyr::mutate(plot_id = factor(plot_id))
  ggplot2::ggplot(data, ggplot2::aes(x = plot_id, y = residual_cm, fill = model_family)) +
    ggplot2::geom_hline(yintercept = 0, color = "grey30", linewidth = 0.35) +
    ggplot2::geom_boxplot(outlier.alpha = 0.20, linewidth = 0.3) +
    ggplot2::facet_wrap(~model_family, ncol = 1) +
    ggplot2::scale_fill_manual(values = kModelColors, guide = "none") +
    ggplot2::labs(
      x = "Plot", y = "Residual (cm)",
      title = "In-sample residual distributions by plot"
    ) +
    kPublicationTheme
}

BuildObservedPredictedByPlot <- function(predictions, selection, family = NULL) {
  data <- FilterSelectedPredictions(
    predictions, selection, estimator = "OLS", scheme = "Full_data"
  )
  if (!is.null(family)) {
    data <- data %>%
      dplyr::filter(.data$model_family == .env$family)
  }
  ggplot2::ggplot(
    data,
    ggplot2::aes(x = observed_final_dbh_cm, y = predicted_final_dbh_cm,
                 color = model_family)
  ) +
    ggplot2::geom_abline(slope = 1, intercept = 0, color = "grey30", linewidth = 0.4) +
    ggplot2::geom_point(alpha = 0.22, size = 0.5) +
    ggplot2::coord_equal() +
    ggplot2::facet_wrap(
      ggplot2::vars(plot_id, model_family),
      ncol = kPublicationMaximumFacetColumns
    ) +
    ggplot2::scale_color_manual(values = kModelColors, guide = "none") +
    ggplot2::labs(
      x = "Observed final DBH (cm)", y = "Predicted final DBH (cm)",
      title = "Observed versus fitted DBH by plot"
    ) +
    kPublicationTheme
}

BuildResidualsByPlot <- function(predictions, selection, family = NULL) {
  data <- FilterSelectedPredictions(
    predictions, selection, estimator = "OLS", scheme = "Full_data"
  )
  if (!is.null(family)) {
    data <- data %>%
      dplyr::filter(.data$model_family == .env$family)
  }
  ggplot2::ggplot(
    data,
    ggplot2::aes(x = predicted_final_dbh_cm, y = residual_cm, color = model_family)
  ) +
    ggplot2::geom_hline(yintercept = 0, color = "grey30", linewidth = 0.35) +
    ggplot2::geom_point(alpha = 0.22, size = 0.5) +
    ggplot2::geom_smooth(method = "loess", se = FALSE, linewidth = 0.55) +
    ggplot2::facet_wrap(
      ggplot2::vars(plot_id, model_family),
      ncol = kPublicationMaximumFacetColumns
    ) +
    ggplot2::scale_color_manual(values = kModelColors, guide = "none") +
    ggplot2::labs(
      x = "Predicted final DBH (cm)", y = "Residual (cm)",
      title = "Residual patterns by plot"
    ) +
    kPublicationTheme
}

BuildAsymptoteProfilePlot <- function(profile) {
  data <- profile %>%
    dplyr::filter(status == "success", is.finite(delta_AIC_fixed_profile)) %>%
    dplyr::mutate(
      basal_area_structure = ifelse(uses_basal_area, "With baseline BA", "Without BA")
    )
  ggplot2::ggplot(
    data,
    ggplot2::aes(
      x = fixed_asymptote_cm, y = delta_AIC_fixed_profile,
      color = model_family, linetype = basal_area_structure,
      group = structural_id
    )
  ) +
    ggplot2::geom_hline(yintercept = 2, color = "grey60", linetype = 3) +
    ggplot2::geom_line(linewidth = 0.7) +
    ggplot2::geom_point(size = 1.8) +
    ggplot2::scale_x_log10(breaks = kAsymptoteProfile) +
    ggplot2::scale_color_manual(values = kModelColors) +
    ggplot2::labs(
      x = "Fixed asymptote A (cm; log scale)",
      y = expression(Delta * " profile criterion"),
      color = "Family", linetype = "Structure",
      title = "Global multi-start asymptote profiles"
    ) +
    kPublicationTheme +
    ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 35, hjust = 1)
    )
}

BuildLopoValidationPlot <- function(validation_summary) {
  data <- validation_summary %>%
    dplyr::filter(scheme == "LOPO", estimator %in% c("OLS", "Persistence")) %>%
    dplyr::mutate(
      candidate = ifelse(
        structural_id == "Persistence", "Persistence",
        paste(model_family, ifelse(uses_basal_area, "+ BA", "no BA"))
      )
    )
  ggplot2::ggplot(data, ggplot2::aes(x = reorder(candidate, RMSE_final_cm), y = RMSE_final_cm)) +
    ggplot2::geom_col(fill = "#4C78A8", width = 0.7) +
    ggplot2::coord_flip() +
    ggplot2::labs(
      x = NULL, y = "Pooled LOPO RMSE (cm)",
      title = "Primary plot-blocked predictive validation"
    ) +
    kPublicationTheme
}

BuildCrossValidationOverview <- function(validation_summary, selection) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  data <- validation_summary %>%
    dplyr::filter(
      estimator %in% c("OLS", "Persistence"),
      structural_id %in% c(selected_ids, "Persistence")
    ) %>%
    dplyr::mutate(
      candidate = ifelse(structural_id == "Persistence", "Persistence", model_family),
      scheme = factor(scheme, c("LOPO", "Temporal", "L2PO"))
    )
  ggplot2::ggplot(
    data,
    ggplot2::aes(x = scheme, y = RMSE_final_cm, color = candidate, group = candidate)
  ) +
    ggplot2::geom_line(linewidth = 0.7) +
    ggplot2::geom_point(size = 2.2) +
    ggplot2::scale_color_manual(
      values = c(kModelColors, "Persistence" = "#777777")
    ) +
    ggplot2::labs(
      x = "Validation design", y = "Pooled RMSE (cm)", color = NULL,
      title = "Predictive performance across validation designs"
    ) +
    kPublicationTheme
}

BuildOosObservedPredicted <- function(predictions, selection, scheme) {
  data <- FilterSelectedPredictions(
    predictions, selection,
    estimator = "OLS", scheme = scheme
  )
  ggplot2::ggplot(
    data,
    ggplot2::aes(
      x = observed_final_dbh_cm, y = predicted_final_dbh_cm,
      color = estimator
    )
  ) +
    ggplot2::geom_abline(slope = 1, intercept = 0, color = "grey30", linewidth = 0.4) +
    ggplot2::geom_point(alpha = 0.18, size = 0.45) +
    ggplot2::coord_equal() +
    ggplot2::facet_wrap(~model_family, ncol = 2) +
    ggplot2::scale_color_manual(values = kEstimatorColors) +
    ggplot2::labs(
      x = "Observed final DBH (cm)", y = "Out-of-sample predicted DBH (cm)",
      color = "Estimator", title = paste(scheme, "out-of-sample predictions")
    ) +
    kPublicationTheme
}

BuildOosResiduals <- function(predictions, selection, scheme) {
  data <- FilterSelectedPredictions(
    predictions, selection,
    estimator = "OLS", scheme = scheme
  )
  ggplot2::ggplot(
    data,
    ggplot2::aes(x = predicted_final_dbh_cm, y = residual_cm, color = estimator)
  ) +
    ggplot2::geom_hline(yintercept = 0, color = "grey30", linewidth = 0.35) +
    ggplot2::geom_point(alpha = 0.18, size = 0.45) +
    ggplot2::geom_smooth(method = "loess", se = FALSE, linewidth = 0.55) +
    ggplot2::facet_wrap(~model_family, ncol = 2) +
    ggplot2::scale_color_manual(values = kEstimatorColors) +
    ggplot2::labs(
      x = "Out-of-sample predicted DBH (cm)", y = "Residual (cm)",
      color = "Estimator", title = paste(scheme, "out-of-sample residuals")
    ) +
    kPublicationTheme
}

BuildErrorSensitivityPlot <- function(validation_summary, selection) {
  selected_ids <- unname(SelectedStructuralIds(selection))
  data <- validation_summary %>%
    dplyr::filter(
      structural_id %in% selected_ids,
      scheme %in% c("LOPO", "Temporal"),
      estimator %in% c("OLS", "Huber", "FGLS", "Student_t"),
      validation_status == "complete"
    )
  ggplot2::ggplot(
    data,
    ggplot2::aes(x = estimator, y = RMSE_final_cm, fill = estimator)
  ) +
    ggplot2::geom_col(width = 0.7) +
    ggplot2::facet_grid(scheme ~ model_family, scales = "free_y") +
    ggplot2::scale_fill_manual(values = kEstimatorColors, guide = "none") +
    ggplot2::labs(
      x = NULL, y = "Pooled out-of-sample RMSE (cm)",
      title = "Sensitivity to robust residual loss"
    ) +
    kPublicationTheme
}

BuildBasalAreaComparisonPlot <- function(validation_summary) {
  data <- validation_summary %>%
    dplyr::filter(scheme == "LOPO", estimator == "OLS", model_family != "Persistence") %>%
    dplyr::mutate(structure = ifelse(uses_basal_area, "With baseline BA", "Without BA"))
  ggplot2::ggplot(
    data,
    ggplot2::aes(x = structure, y = RMSE_final_cm, fill = structure)
  ) +
    ggplot2::geom_col(width = 0.65) +
    ggplot2::facet_wrap(~model_family, scales = "free_y") +
    ggplot2::scale_fill_manual(values = c(
      "Without BA" = "#999999", "With baseline BA" = "#56B4E9"
    ), guide = "none") +
    ggplot2::labs(
      x = NULL, y = "Pooled LOPO RMSE (cm)",
      title = "Predictive contribution of baseline 2013 plot basal area"
    ) +
    kPublicationTheme
}

BuildManagementScenarioPlot <- function(management_scenarios) {
  data <- management_scenarios$family_envelope
  if (!is.data.frame(data) || nrow(data) == 0L) {
    stop("Conditional scenario plot requested without scenario results.")
  }
  ggplot2::ggplot(
    data,
    ggplot2::aes(
      x = projection_year, y = median_projected_increment_cm,
      color = model_family, fill = model_family
    )
  ) +
    ggplot2::geom_ribbon(
      ggplot2::aes(
        ymin = lower_projected_increment_cm,
        ymax = upper_projected_increment_cm
      ),
      alpha = 0.16, color = NA
    ) +
    ggplot2::geom_line(linewidth = 0.7) +
    ggplot2::geom_vline(
      xintercept = kManagementHorizonYears,
      linetype = "dotted", color = "grey45", linewidth = 0.35
    ) +
    ggplot2::facet_wrap(
      ~initial_dbh_cm, ncol = kPublicationMaximumFacetColumns,
      labeller = ggplot2::labeller(
        initial_dbh_cm = function(values) paste("Initial DBH", values, "cm")
      )
    ) +
    ggplot2::scale_color_manual(values = kModelColors, name = "Model family") +
    ggplot2::scale_fill_manual(values = kModelColors, name = "Model family") +
    ggplot2::labs(
      x = "Projection horizon (years)",
      y = "Conditional projected diameter increment (cm)",
      title = "Canonical OLS conditional survivor-DBH sensitivity envelope"
    ) +
    kPublicationTheme
}

BuildScenarioEnvelopeWidthPlot <- function(management_scenarios) {
  data <- dplyr::bind_rows(
    management_scenarios$estimator_envelope %>%
      dplyr::transmute(
        initial_dbh_cm, projection_year,
        envelope_scope = estimator,
        envelope_width_cm
      ),
    management_scenarios$combined_envelope %>%
      dplyr::transmute(
        initial_dbh_cm, projection_year,
        envelope_scope = "Combined",
        envelope_width_cm
      )
  )
  if (!is.data.frame(data) || nrow(data) == 0L) {
    stop("Scenario-divergence plot requested without scenario results.")
  }
  data <- data %>%
    dplyr::mutate(
      initial_dbh_factor = factor(initial_dbh_cm),
      envelope_scope = factor(
        envelope_scope, levels = c("OLS", "Huber", "Combined")
      )
    )
  ggplot2::ggplot(
    data,
    ggplot2::aes(
      x = projection_year, y = envelope_width_cm,
      color = envelope_scope, linetype = envelope_scope,
      group = envelope_scope
    )
  ) +
    ggplot2::annotate(
      "rect", xmin = 50, xmax = 90, ymin = -Inf, ymax = Inf,
      fill = "grey70", alpha = 0.14
    ) +
    ggplot2::geom_line(linewidth = 0.7) +
    ggplot2::geom_vline(
      xintercept = c(25, 35, 50, 90),
      linetype = "dotted", color = "grey45", linewidth = 0.35
    ) +
    ggplot2::facet_wrap(
      ~initial_dbh_factor, ncol = kPublicationMaximumFacetColumns,
      labeller = ggplot2::labeller(
        initial_dbh_factor = function(values) paste("Initial DBH", values, "cm")
      )
    ) +
    ggplot2::scale_color_manual(values = kEnvelopeColors, name = "Envelope") +
    ggplot2::scale_linetype_manual(
      values = c("OLS" = "solid", "Huber" = "dashed", "Combined" = "dotdash"),
      name = "Envelope"
    ) +
    ggplot2::labs(
      x = "Projection horizon (years)",
      y = "Structural scenario-envelope width (cm)",
      title = "Estimator and structural divergence of conditional projections"
    ) +
    kPublicationTheme
}

BuildEstimatorScenarioPlot <- function(management_scenarios) {
  data <- management_scenarios$estimator_envelope
  if (!is.data.frame(data) || nrow(data) == 0L) {
    stop("Estimator-sensitivity plot requested without scenario results.")
  }
  ggplot2::ggplot(
    data,
    ggplot2::aes(
      x = projection_year, y = median_projected_increment_cm,
      color = estimator, fill = estimator, linetype = estimator
    )
  ) +
    ggplot2::geom_ribbon(
      ggplot2::aes(
        ymin = lower_projected_increment_cm,
        ymax = upper_projected_increment_cm
      ),
      alpha = 0.12, color = NA
    ) +
    ggplot2::geom_line(linewidth = 0.75) +
    ggplot2::geom_vline(
      xintercept = c(25, 35, 50, 90),
      linetype = "dotted", color = "grey45", linewidth = 0.3
    ) +
    ggplot2::facet_wrap(
      ~initial_dbh_cm, ncol = kPublicationMaximumFacetColumns,
      labeller = ggplot2::labeller(
        initial_dbh_cm = function(values) paste("Initial DBH", values, "cm")
      )
    ) +
    ggplot2::scale_color_manual(values = kEstimatorColors, name = "Estimator") +
    ggplot2::scale_fill_manual(values = kEstimatorColors, name = "Estimator") +
    ggplot2::scale_linetype_manual(
      values = c("OLS" = "solid", "Huber" = "dashed"), name = "Estimator"
    ) +
    ggplot2::labs(
      x = "Projection horizon (years)",
      y = "Conditional projected diameter increment (cm)",
      title = "OLS and Huber long-horizon estimator sensitivity"
    ) +
    kPublicationTheme
}

BuildDbhClassValidationPlot <- function(dbh_class_validation) {
  data <- dbh_class_validation$combined %>%
    dplyr::filter(
      intervals > 0L,
      estimator %in% c("OLS", "Huber", "Persistence")
    ) %>%
    dplyr::mutate(
      initial_dbh_class = factor(
        initial_dbh_class, levels = kDiameterSupportLabels
      ),
      candidate = ifelse(
        estimator == "Persistence", "Persistence",
        paste(model_family, estimator, sep = " - ")
      )
    ) %>%
    dplyr::select(
      scheme, initial_dbh_class, candidate, intervals,
      RMSE_final_cm, mean_error_final_cm
    ) %>%
    tidyr::pivot_longer(
      cols = c(RMSE_final_cm, mean_error_final_cm),
      names_to = "metric", values_to = "value_cm"
    ) %>%
    dplyr::mutate(
      metric = factor(
        metric,
        levels = c("RMSE_final_cm", "mean_error_final_cm"),
        labels = c("RMSE (cm)", "Mean error (cm)")
      )
    )
  colors <- c(
    "Richards - OLS" = "#0072B2",
    "Richards - Huber" = "#56B4E9",
    "Lundqvist - OLS" = "#D55E00",
    "Lundqvist - Huber" = "#E69F00",
    "Persistence" = "#777777"
  )
  ggplot2::ggplot(
    data,
    ggplot2::aes(
      x = initial_dbh_class, y = value_cm,
      color = candidate, group = candidate
    )
  ) +
    ggplot2::geom_hline(
      yintercept = 0, color = "grey45", linewidth = 0.3
    ) +
    ggplot2::geom_line(linewidth = 0.65) +
    ggplot2::geom_point(size = 1.8) +
    ggplot2::facet_grid(metric ~ scheme, scales = "free_y") +
    ggplot2::scale_color_manual(values = colors, name = NULL) +
    ggplot2::labs(
      x = "Initial DBH class (cm)", y = NULL,
      title = "Out-of-sample performance by initial DBH support class"
    ) +
    kPublicationTheme +
    ggplot2::guides(
      color = ggplot2::guide_legend(nrow = 2, byrow = TRUE)
    ) +
    ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 35, hjust = 1)
    )
}

WriteAllFigures <- function(data, full_outputs, validation, validation_summary,
                            selection, profile, management_scenarios,
                            dbh_class_validation) {
  SavePublicationPlot(
    BuildCommunityStructurePlot(data),
    "Analysis_population_structure_2013_2016.tiff", 8, 6
  )
  SavePublicationPlot(
    BuildCombinedDiagnosticsPlot(full_outputs$predictions, selection),
    "Model_diagnostics_combined.tiff", 8.5, 9
  )
  SavePublicationPlot(
    BuildObservedEstimatedCommunityPlot(full_outputs$predictions, selection),
    "Observed_vs_estimated_analysis_population_combined.tiff", 9, 8
  )
  SavePublicationPlot(
    BuildResidualCommunityPlot(full_outputs$predictions, selection),
    "Residuals_analysis_population_combined.tiff", 9, 8
  )
  SavePublicationPlot(
    BuildObservedPredictedByPlot(full_outputs$predictions, selection),
    "Observed_vs_predicted_by_plot_combined.tiff", 15, 9
  )
  SavePublicationPlot(
    BuildResidualsByPlot(full_outputs$predictions, selection),
    "Residuals_by_plot_combined.tiff", 15, 9
  )
  SavePublicationPlot(
    BuildAsymptoteProfilePlot(profile), "Asymptote_profile.tiff", 10, 6.5
  )
  SavePublicationPlot(
    BuildLopoValidationPlot(validation_summary), "LOPO_validation.tiff", 8, 6
  )
  SavePublicationPlot(
    BuildCrossValidationOverview(validation_summary, selection),
    "Cross_validation_summary.tiff", 9.5, 6.5
  )
  SavePublicationPlot(
    BuildOosObservedPredicted(validation$predictions, selection, "LOPO"),
    "LOPO_observed_vs_predicted_OOS.tiff", 9, 6
  )
  SavePublicationPlot(
    BuildOosResiduals(validation$predictions, selection, "LOPO"),
    "LOPO_residuals_OOS.tiff", 9, 6
  )
  SavePublicationPlot(
    BuildOosObservedPredicted(validation$predictions, selection, "Temporal"),
    "Temporal_observed_vs_predicted_OOS.tiff", 9, 6
  )
  SavePublicationPlot(
    BuildOosResiduals(validation$predictions, selection, "Temporal"),
    "Temporal_residuals_OOS.tiff", 9, 6
  )
  if (isTRUE(kRunHuberSensitivity) ||
      isTRUE(kRunExploratoryErrorSensitivities)) {
    SavePublicationPlot(
      BuildErrorSensitivityPlot(validation_summary, selection),
      "Error_structure_sensitivity.tiff", 10, 7
    )
  }
  SavePublicationPlot(
    BuildBasalAreaComparisonPlot(validation_summary),
    "Basal_area_structural_comparison.tiff", 9, 6
  )
  SavePublicationPlot(
    BuildDbhClassValidationPlot(dbh_class_validation),
    "Out_of_sample_performance_by_initial_DBH_class.tiff", 12, 8.5
  )
  if (nrow(management_scenarios$family_envelope) > 0L) {
    SavePublicationPlot(
      BuildManagementScenarioPlot(management_scenarios),
      "Conditional_5_90_year_survivor_DBH_scenarios.tiff", 14, 9
    )
    SavePublicationPlot(
      BuildEstimatorScenarioPlot(management_scenarios),
      "Conditional_OLS_Huber_survivor_DBH_sensitivity.tiff", 14, 9
    )
    SavePublicationPlot(
      BuildScenarioEnvelopeWidthPlot(management_scenarios),
      "Conditional_projection_structural_divergence_5_90_years.tiff", 14, 9
    )
  }

  for (family in c("Richards", "Lundqvist")) {
    family_dir <- GetFamilyDirectory(family)
    SavePublicationPlot(
      BuildObservedEstimatedCommunityPlot(full_outputs$predictions, selection, family),
      paste0(family, "_observed_vs_estimated_analysis_population.tiff"),
      width = 8.5, height = 6.5, directory = family_dir
    )
    SavePublicationPlot(
      BuildResidualCommunityPlot(full_outputs$predictions, selection, family),
      paste0(family, "_residuals_analysis_population.tiff"),
      width = 8.5, height = 6.5, directory = family_dir
    )
    SavePublicationPlot(
      BuildObservedPredictedByPlot(full_outputs$predictions, selection, family),
      paste0(family, "_observed_vs_predicted_by_plot.tiff"),
      width = 14, height = 6, directory = family_dir
    )
    SavePublicationPlot(
      BuildResidualsByPlot(full_outputs$predictions, selection, family),
      paste0(family, "_residuals_by_plot.tiff"),
      width = 14, height = 6, directory = family_dir
    )
  }
}

# 12. EXPORT AND REPRODUCIBILITY ----------------------------------------------

SanitizeForExport <- function(data) {
  if (!is.data.frame(data)) {
    data <- as.data.frame(data)
  }
  for (column in names(data)) {
    if (is.numeric(data[[column]])) {
      data[[column]][!is.finite(data[[column]])] <- NA_real_
    }
  }
  data
}

WriteCsv <- function(data, filename) {
  utils::write.csv(
    SanitizeForExport(data),
    file.path(kOutputDirectory, "Tables", filename),
    row.names = FALSE, na = ""
  )
}

WriteWorkbook <- function(sheets, path) {
  sheets <- lapply(sheets, SanitizeForExport)
  names(sheets) <- make.unique(substr(names(sheets), 1, 31), sep = "_")
  writexl::write_xlsx(sheets, path = path)
  invisible(path)
}

WriteTextCapture <- function(expression, path) {
  output <- utils::capture.output(expression)
  writeLines(output, con = path, useBytes = TRUE)
  invisible(path)
}

BuildRunManifest <- function(signature, started_at, completed_at, status) {
  script_path <- GetScriptPath()
  data.frame(
    field = c(
      "status", "started_at", "completed_at", "model_specification_version",
      "analysis_signature", "script_path", "script_md5", "input_path",
      "input_md5", "growth_data_sheet", "commercial_registry_sheet",
      "data_curation_audit_sheet",
      "R_version", "platform", "working_directory",
      "analysis_scope", "validation_scope", "robust_loss_scope",
      "prediction_domain_control", "data_curation_provenance_policy",
      "diameter_support_scope",
      "long_horizon_scope"
    ),
    value = c(
      status, format(started_at, "%Y-%m-%d %H:%M:%S %Z"),
      format(completed_at, "%Y-%m-%d %H:%M:%S %Z"), kModelSpecVersion,
      signature, script_path,
      if (!is.na(script_path) && file.exists(script_path)) {
        unname(tools::md5sum(script_path))
      } else NA_character_,
      normalizePath(kDataFile, mustWork = FALSE),
      if (file.exists(kDataFile)) unname(tools::md5sum(kDataFile)) else NA_character_,
      kDataSheet, kCommercialSpeciesSheet, kCurationAuditSheet,
      paste(R.version$major, R.version$minor, sep = "."), R.version$platform,
      normalizePath(getwd(), mustWork = FALSE), AnalysisScopeLabel(),
      "internal spatially blocked LOPO; progressive temporal; L2PO stress test",
      paste0(
        "direct fixed-OLS-scale Huber sensitivity in LOPO, temporal and full ",
        "data, plus fixed-asymptote long-horizon profiles; never used for ",
        "structural selection"
      ),
      paste0(
        "predeclared asymptote floor ", kPredictionDomainAsymptoteFloorCm,
        " cm in all folds; independent of held-out values"
      ),
      paste0(
        "read ", kCurationAuditSheet,
        " when present; never label undocumented observations as verified"
      ),
      paste0(
        "LOPO and temporal metrics by initial-DBH class with ",
        "interval/tree/species/plot counts and broad/limited/sparse flags"
      ),
      paste0(
        "conditional OLS/Huber 5-90-year stationary survivor-DBH sensitivity only; ",
        "50-90 years are assumption-driven structural stress tests"
      )
    ),
    stringsAsFactors = FALSE
  )
}

WriteValidationOnlyOutputs <- function(raw_data, prepared, reconciliation,
                                       signature, started_at) {
  audit <- BuildDataAudit(raw_data, prepared)
  species_composition <- BuildSpeciesCompositionAudit(prepared)
  inference_scope <- BuildInferenceScopeTable(prepared$data)
  scenario_literature <- BuildScenarioLiteratureBasisTable()
  diameter_support <- BuildDiameterSupportAudit(prepared$data)
  prediction_domain_audit <- ValidatePredictionDomainControl(prepared$data)
  curation <- prepared$data_curation_provenance
  WriteCsv(audit$summary, "data_audit_summary.csv")
  WriteCsv(audit$by_plot_period, "data_audit_by_plot_period.csv")
  WriteCsv(species_composition, "species_composition_audit.csv")
  WriteCsv(prepared$excluded_period_audit,
           "excluded_placeholder_period_audit.csv")
  WriteCsv(inference_scope, "inference_scope.csv")
  WriteCsv(scenario_literature, "scenario_literature_basis.csv")
  WriteCsv(diameter_support, "initial_DBH_empirical_support.csv")
  WriteCsv(prediction_domain_audit, "prediction_domain_control.csv")
  WriteCsv(curation$records, "data_curation_audit_records.csv")
  WriteCsv(curation$provenance, "data_curation_provenance.csv")
  WriteCsv(curation$checkpoint, "data_curation_checkpoint.csv")
  WriteCsv(curation$template, "Data_curation_audit_template.csv")
  WriteCsv(curation$zero_increment_diagnostic, "zero_increment_diagnostic.csv")
  WriteCsv(curation$documentation_requirements, "curation_documentation_requirements.csv")
  WriteCsv(prepared$continuity, "diameter_continuity_checks.csv")
  WriteCsv(kBasalArea2013ByPlot, "baseline_basal_area_2013.csv")
  WriteCsv(reconciliation, "dataset_reconciliation.csv")
  WriteCsv(BuildModelSpecificationTable(), "model_specification.csv")
  WriteCsv(BuildConfigurationTable(), "analysis_configuration.csv")
  WriteCsv(
    BuildFigureExportSpecification(), "figure_export_specification.csv"
  )
  WriteCsv(GetPackageManifest(), "package_manifest.csv")
  manifest <- BuildRunManifest(
    signature, started_at, Sys.time(),
    if (isTRUE(curation$publication_ready)) {
      "validation_only_success"
    } else {
      "validation_only_success_curation_provenance_pending"
    }
  )
  WriteCsv(manifest, "run_manifest.csv")
  WriteWorkbook(
    list(
      Data_audit = audit$summary,
      Plot_period_audit = audit$by_plot_period,
      Species_composition = species_composition,
      Excluded_period_audit = prepared$excluded_period_audit,
      Inference_scope = inference_scope,
      Scenario_literature = scenario_literature,
      DBH_support = diameter_support,
      Prediction_domain = prediction_domain_audit,
      Curation_provenance = curation$provenance,
      Curation_checkpoint = curation$checkpoint,
      Zero_increment_diagnostic = curation$zero_increment_diagnostic,
      Curation_requirements = curation$documentation_requirements,
      Reconciliation = reconciliation,
      Basal_area_2013 = kBasalArea2013ByPlot,
      Model_specification = BuildModelSpecificationTable(),
      Configuration = BuildConfigurationTable(),
      Figure_export = BuildFigureExportSpecification(),
      Package_manifest = GetPackageManifest(),
      Run_manifest = manifest
    ),
    file.path(kOutputDirectory, "Validation_only_audit.xlsx")
  )
  WriteTextCapture(utils::sessionInfo(), file.path(kOutputDirectory, "session_info.txt"))
}

WriteAnalysisOutputs <- function(raw_data, prepared, reconciliation,
                                 validation, validation_summary, selection,
                                 family_equivalence, species_diagnostics,
                                 species_group_robustness,
                                 regulatory_stratum_diagnostics,
                                 temporal_fold_contrasts,
                                 lopo_bootstrap, residual_dependence,
                                 plot_residual_diagnostics,
                                 robust_loss_sensitivity,
                                 extreme_residual_audit,
                                 dbh_class_validation,
                                 full_fits, full_outputs, profile,
                                 huber_profile, asymptote_identification,
                                 management_scenarios, inference_scope,
                                 signature, started_at) {
  audit <- BuildDataAudit(raw_data, prepared)
  species_composition <- BuildSpeciesCompositionAudit(prepared)
  configuration <- BuildConfigurationTable()
  specification <- BuildModelSpecificationTable()
  package_manifest <- GetPackageManifest()
  scenario_literature <- BuildScenarioLiteratureBasisTable()
  prediction_domain_audit <- ValidatePredictionDomainControl(prepared$data)
  curation <- prepared$data_curation_provenance
  manifest <- BuildRunManifest(
    signature, started_at, Sys.time(),
    if (isTRUE(curation$publication_ready)) {
      "success"
    } else {
      "success_curation_provenance_pending"
    }
  )

  tables <- list(
    data_audit_summary = audit$summary,
    data_audit_by_plot_period = audit$by_plot_period,
    excluded_placeholder_period_audit = prepared$excluded_period_audit,
    species_composition_audit = species_composition,
    inference_scope = inference_scope,
    dataset_reconciliation = reconciliation,
    baseline_basal_area_2013 = kBasalArea2013ByPlot,
    model_specification = specification,
    analysis_configuration = configuration,
    figure_export_specification = BuildFigureExportSpecification(),
    prediction_domain_control = prediction_domain_audit,
    data_curation_audit_records = curation$records,
    data_curation_provenance = curation$provenance,
    data_curation_checkpoint = curation$checkpoint,
    zero_increment_diagnostic = curation$zero_increment_diagnostic,
    curation_documentation_requirements = curation$documentation_requirements,
    validation_design_audit = validation$design_audit,
    validation_summary = validation_summary,
    validation_fold_summary = validation$fold_summary,
    structural_selection = selection,
    family_structural_equivalence = family_equivalence,
    species_LOPO_diagnostics = species_diagnostics,
    species_group_robustness = species_group_robustness,
    regulatory_stratum_LOPO = regulatory_stratum_diagnostics,
    temporal_fold_contrasts = temporal_fold_contrasts,
    LOPO_cluster_bootstrap = lopo_bootstrap$summary,
    residual_dependence = residual_dependence,
    plot_residual_diagnostics = plot_residual_diagnostics,
    Huber_metric_sensitivity =
      robust_loss_sensitivity$metric_comparison,
    Huber_fold_completeness =
      robust_loss_sensitivity$fold_completeness,
    Huber_prediction_shift =
      robust_loss_sensitivity$prediction_shift,
    LOPO_extreme_residual_summary = extreme_residual_audit$summary,
    LOPO_extreme_residual_rows = extreme_residual_audit$rows,
    LOPO_metrics_by_initial_DBH_class = dbh_class_validation$LOPO,
    Temporal_metrics_by_initial_DBH_class = dbh_class_validation$Temporal,
    DBH_class_validation_checkpoint = dbh_class_validation$checkpoint,
    DBH_class_count_reconciliation =
      dbh_class_validation$count_reconciliation,
    full_fit_summary = full_outputs$summary,
    full_coefficients = full_outputs$coefficients,
    identifiability = full_outputs$identifiability,
    singular_values = full_outputs$singular_values,
    boundary_diagnostics = full_outputs$boundary_diagnostics,
    asymptote_profile = profile,
    Huber_asymptote_profile = huber_profile,
    asymptote_identification_summary =
      asymptote_identification$summary,
    asymptote_identification_checkpoint =
      asymptote_identification$checkpoint,
    conditional_scenario_assumptions = management_scenarios$assumptions,
    initial_DBH_empirical_support =
      management_scenarios$empirical_diameter_support,
    conditional_scenario_start_support =
      management_scenarios$scenario_start_support,
    scenario_literature_basis = scenario_literature,
    projection_step_invariance_audit = management_scenarios$invariance_audit,
    Huber_long_horizon_checkpoint =
      management_scenarios$Huber_long_horizon_checkpoint,
    conditional_scenario_horizons = management_scenarios$horizon_summary,
    conditional_horizon_envelope_diagnostics =
      management_scenarios$horizon_envelope_diagnostics,
    conditional_large_diameter_crossings =
      management_scenarios$diameter_threshold_crossings,
    conditional_scenario_family_envelope =
      management_scenarios$family_envelope,
    conditional_scenario_overall_envelope =
      management_scenarios$overall_envelope,
    conditional_estimator_envelope =
      management_scenarios$estimator_envelope,
    conditional_combined_envelope =
      management_scenarios$combined_envelope,
    conditional_estimator_sensitivity =
      management_scenarios$estimator_sensitivity,
    conditional_Huber_trajectories =
      management_scenarios$Huber_trajectories,
    conditional_OLS_trajectories =
      management_scenarios$OLS_trajectories,
    conditional_scenario_trajectories = management_scenarios$trajectories,
    package_manifest = package_manifest,
    run_manifest = manifest
  )
  purrr::iwalk(tables, function(table, name) {
    WriteCsv(table, paste0(name, ".csv"))
  })
  WriteCsv(curation$template, "Data_curation_audit_template.csv")
  WriteCsv(validation$coefficients, "validation_fold_coefficients.csv")
  WriteCsv(validation$optimizer_diagnostics, "validation_optimizer_diagnostics.csv")
  WriteCsv(full_outputs$optimizer_diagnostics, "full_fit_optimizer_diagnostics.csv")
  WriteCsv(full_outputs$predictions, "full_data_predictions.csv")
  WriteCsv(prepared$continuity, "diameter_continuity_checks.csv")
  WriteCsv(
    lopo_bootstrap$replicates,
    "LOPO_plot_cluster_bootstrap_replicates.csv"
  )

  for (scheme_name in c("LOPO", "Temporal", "L2PO")) {
    WriteCsv(
      validation$predictions %>%
        dplyr::filter(.data$scheme == .env$scheme_name),
      paste0("out_of_sample_predictions_", scheme_name, ".csv")
    )
  }

  WriteWorkbook(
    list(
      Data_audit = audit$summary,
      Plot_period_audit = audit$by_plot_period,
      Excluded_period_audit = prepared$excluded_period_audit,
      Species_composition = species_composition,
      Inference_scope = inference_scope,
      Reconciliation = reconciliation,
      Basal_area_2013 = kBasalArea2013ByPlot,
      Model_specification = specification,
      Configuration = configuration,
      Figure_export = BuildFigureExportSpecification(),
      Prediction_domain = prediction_domain_audit,
      Curation_provenance = curation$provenance,
      Curation_checkpoint = curation$checkpoint,
      Zero_increment_diagnostic = curation$zero_increment_diagnostic,
      Curation_requirements = curation$documentation_requirements,
      Validation_design = validation$design_audit,
      Structural_selection = selection,
      Family_equivalence = family_equivalence,
      LOPO_cluster_bootstrap = lopo_bootstrap$summary,
      Species_LOPO = species_diagnostics,
      Species_robustness = species_group_robustness,
      Regulatory_LOPO = regulatory_stratum_diagnostics,
      Temporal_contrasts = temporal_fold_contrasts,
      Residual_dependence = residual_dependence,
      Plot_residuals = plot_residual_diagnostics,
      Huber_sensitivity = robust_loss_sensitivity$metric_comparison,
      Huber_completeness = robust_loss_sensitivity$fold_completeness,
      Huber_prediction_shift = robust_loss_sensitivity$prediction_shift,
      Extreme_residuals = extreme_residual_audit$summary,
      LOPO_by_DBH_class = dbh_class_validation$LOPO,
      Temporal_by_DBH_class = dbh_class_validation$Temporal,
      DBH_class_checkpoint = dbh_class_validation$checkpoint,
      Initial_DBH_support = management_scenarios$empirical_diameter_support,
      Scenario_start_support = management_scenarios$scenario_start_support,
      Validation_summary = validation_summary,
      Fold_summary = validation$fold_summary,
      Full_fit_summary = full_outputs$summary,
      Full_coefficients = full_outputs$coefficients,
      Identifiability = full_outputs$identifiability,
      Boundary_diagnostics = full_outputs$boundary_diagnostics,
      Asymptote_profile = profile,
      Huber_A_profile = huber_profile,
      Asymptote_identification = asymptote_identification$summary,
      Scenario_assumptions = management_scenarios$assumptions,
      Scenario_literature = scenario_literature,
      Scenario_invariance = management_scenarios$invariance_audit,
      Huber_horizon_checkpoint =
        management_scenarios$Huber_long_horizon_checkpoint,
      Estimator_sensitivity = management_scenarios$estimator_sensitivity,
      Combined_envelope = management_scenarios$combined_envelope,
      Scenario_horizons = management_scenarios$horizon_summary,
      Scenario_envelope = management_scenarios$horizon_envelope_diagnostics,
      Large_DBH_crossings = management_scenarios$diameter_threshold_crossings,
      Package_manifest = package_manifest,
      Run_manifest = manifest
    ),
    file.path(kOutputDirectory, "Audit_results.xlsx")
  )
  WriteWorkbook(
    list(Full_data_predictions = full_outputs$predictions),
    file.path(kOutputDirectory, "Audited_predictions.xlsx")
  )

  selected <- SelectedStructuralIds(selection)
  for (family in c("Richards", "Lundqvist")) {
    family_dir <- GetFamilyDirectory(family)
    family_summary <- validation_summary %>%
      dplyr::filter(.data$model_family == .env$family)
    family_fold <- validation$fold_summary %>%
      dplyr::filter(.data$model_family == .env$family)
    family_full <- full_outputs$summary %>%
      dplyr::filter(.data$model_family == .env$family)
    family_coef <- full_outputs$coefficients %>%
      dplyr::filter(.data$model_family == .env$family)
    family_identifiability <- full_outputs$identifiability %>%
      dplyr::filter(.data$model_family == .env$family)
    family_profile <- profile %>%
      dplyr::filter(.data$model_family == .env$family)
    family_huber_profile <- huber_profile %>%
      dplyr::filter(.data$model_family == .env$family)
    family_asymptote_identification <-
      asymptote_identification$summary %>%
      dplyr::filter(.data$model_family == .env$family)
    family_species <- species_diagnostics %>%
      dplyr::filter(.data$model_family == .env$family)
    family_scenarios <- management_scenarios$horizon_summary %>%
      dplyr::filter(.data$model_family == .env$family)
    family_crossings <- management_scenarios$diameter_threshold_crossings %>%
      dplyr::filter(.data$model_family == .env$family)
    family_regulatory <- regulatory_stratum_diagnostics %>%
      dplyr::filter(.data$model_family == .env$family)
    family_predictions <- full_outputs$predictions %>%
      dplyr::filter(.data$model_family == .env$family)
    family_huber_sensitivity <- robust_loss_sensitivity$metric_comparison %>%
      dplyr::filter(.data$model_family == .env$family)
    family_extreme_residuals <- extreme_residual_audit$summary %>%
      dplyr::filter(.data$model_family == .env$family)
    family_dbh_class <- dbh_class_validation$combined %>%
      dplyr::filter(
        .data$model_family %in% c(.env$family, "Persistence")
      )
    WriteWorkbook(
      list(
        Validation_summary = family_summary,
        Fold_summary = family_fold,
        Full_fit_summary = family_full,
        Coefficients = family_coef,
        Identifiability = family_identifiability,
        Asymptote_profile = family_profile,
        Huber_A_profile = family_huber_profile,
        Asymptote_identification = family_asymptote_identification,
        Species_LOPO = family_species,
        Regulatory_LOPO = family_regulatory,
        Huber_sensitivity = family_huber_sensitivity,
        Extreme_residuals = family_extreme_residuals,
        Validation_by_DBH_class = family_dbh_class,
        Initial_DBH_support = management_scenarios$empirical_diameter_support,
        Scenario_horizons = family_scenarios,
        Large_DBH_crossings = family_crossings,
        Selection = selection %>%
          dplyr::filter(.data$model_family == .env$family)
      ),
      file.path(family_dir, paste0(family, "_results.xlsx"))
    )
    WriteWorkbook(
      list(Full_predictions = family_predictions),
      file.path(family_dir, paste0(family, "_predictions.xlsx"))
    )
    selected_fit <- full_fits[[unname(selected[family])]]$OLS
    saveRDS(
      list(
        signature = signature,
        selected_structural_id = unname(selected[family]),
        interpretation_scope = paste0(
          "empirically evaluated for short-interval survivor-DBH prediction; ",
          "5-90-year use is conditional sensitivity only; 50-90 years are ",
          "long-term structural stress tests and exclude cutting-cycle inference"
        ),
        fit = selected_fit,
        Huber_sensitivity_fit = if (
          "Huber" %in% names(full_fits[[unname(selected[family])]])
        ) {
          full_fits[[unname(selected[family])]]$Huber
        } else {
          NULL
        },
        saved_at = Sys.time()
      ),
      file.path(family_dir, paste0(family, "_model_robust.rds"))
    )
  }
  WriteTextCapture(utils::sessionInfo(), file.path(kOutputDirectory, "session_info.txt"))
}

BuildScopeSampleSummary <- function(prepared) {
  data <- prepared$data
  data.frame(
    analysis_scope_id = prepared$analysis_scope_id,
    analysis_scope = prepared$analysis_scope,
    intervals = nrow(data),
    unique_trees = dplyr::n_distinct(data$tree_id),
    species = dplyr::n_distinct(data$species_id),
    plots = dplyr::n_distinct(data$plot_id),
    periods = dplyr::n_distinct(data$period_label),
    permitted_intervals = sum(
      data$commercial_permission_class == "permitted"
    ),
    protected_intervals = sum(
      data$commercial_permission_class == "protected"
    ),
    minimum_observed_dbh_cm = min(c(data$initial_dbh, data$dbh_final)),
    maximum_observed_dbh_cm = max(c(data$initial_dbh, data$dbh_final)),
    maximum_empirical_interval_years = max(data$interval_years_value),
    stringsAsFactors = FALSE
  )
}

WriteCommercialRegistryAudit <- function(registry_audit, control_table) {
  SetRootOutputContext()
  tables <- list(
    commercial_registry_source_rows = registry_audit$source,
    commercial_registry_resolved_taxa = registry_audit$resolved,
    commercial_registry_inventory_reconciliation = registry_audit$reconciliation,
    commercial_registry_conflicts = registry_audit$conflicts,
    commercial_registry_unmatched_taxa = registry_audit$unmatched,
    commercial_registry_exact_controls = control_table
  )
  purrr::iwalk(tables, function(table, name) {
    WriteCsv(table, paste0(name, ".csv"))
  })
  WriteWorkbook(
    list(
      Source_rows = registry_audit$source,
      Resolved_taxa = registry_audit$resolved,
      Inventory_reconciliation = registry_audit$reconciliation,
      Status_conflicts = registry_audit$conflicts,
      Unmatched_taxa = registry_audit$unmatched,
      Exact_controls = control_table
    ),
    file.path(kRootOutputDirectory, "Commercial_species_registry_audit.xlsx")
  )
}

WriteCrossScopeOutputs <- function(scope_results) {
  SetRootOutputContext()
  AddScope <- function(table, scope_id) {
    if (!is.data.frame(table)) return(data.frame())
    dplyr::mutate(table, analysis_scope_id = scope_id, .before = 1)
  }
  samples <- dplyr::bind_rows(lapply(scope_results, function(result) {
    result$sample_summary
  }))
  validation <- dplyr::bind_rows(lapply(names(scope_results), function(scope_id) {
    AddScope(scope_results[[scope_id]]$validation_summary, scope_id)
  }))
  selection <- dplyr::bind_rows(lapply(names(scope_results), function(scope_id) {
    AddScope(scope_results[[scope_id]]$selection, scope_id)
  }))
  equivalence <- dplyr::bind_rows(lapply(names(scope_results), function(scope_id) {
    AddScope(scope_results[[scope_id]]$family_equivalence, scope_id)
  }))
  regulatory <- dplyr::bind_rows(lapply(names(scope_results), function(scope_id) {
    AddScope(scope_results[[scope_id]]$regulatory_stratum_diagnostics, scope_id)
  }))
  huber_sensitivity <- dplyr::bind_rows(lapply(
    names(scope_results), function(scope_id) {
      AddScope(
        scope_results[[scope_id]]$robust_loss_sensitivity$metric_comparison,
        scope_id
      )
    }
  ))
  diameter_support <- dplyr::bind_rows(lapply(
    names(scope_results), function(scope_id) {
      AddScope(
        scope_results[[scope_id]]$conditional_management_scenarios[[
          "empirical_diameter_support"
        ]],
        scope_id
      )
    }
  ))
  DBH_class_performance <- dplyr::bind_rows(lapply(
    names(scope_results), function(scope_id) {
      AddScope(
        scope_results[[scope_id]]$DBH_class_validation$combined,
        scope_id
      )
    }
  ))
  estimator_sensitivity <- dplyr::bind_rows(lapply(
    names(scope_results), function(scope_id) {
      AddScope(
        scope_results[[scope_id]]$conditional_management_scenarios[[
          "estimator_sensitivity"
        ]],
        scope_id
      )
    }
  ))
  asymptote_identification <- dplyr::bind_rows(lapply(
    names(scope_results), function(scope_id) {
      AddScope(
        scope_results[[scope_id]]$asymptote_identification$summary,
        scope_id
      )
    }
  ))
  extreme_residuals <- dplyr::bind_rows(lapply(
    names(scope_results), function(scope_id) {
      AddScope(
        scope_results[[scope_id]]$extreme_residual_audit$summary,
        scope_id
      )
    }
  ))
  prediction_domain <- dplyr::bind_rows(lapply(
    names(scope_results), function(scope_id) {
      AddScope(scope_results[[scope_id]]$prediction_domain_audit, scope_id)
    }
  ))
  literature <- BuildScenarioLiteratureBasisTable()
  tables <- list(
    cross_scope_sample_summary = samples,
    cross_scope_validation_summary = validation,
    cross_scope_structural_selection = selection,
    cross_scope_family_equivalence = equivalence,
    cross_scope_regulatory_stratum_LOPO = regulatory,
    cross_scope_Huber_sensitivity = huber_sensitivity,
    cross_scope_initial_DBH_support = diameter_support,
    cross_scope_DBH_class_performance = DBH_class_performance,
    cross_scope_conditional_estimator_sensitivity = estimator_sensitivity,
    cross_scope_asymptote_identification = asymptote_identification,
    cross_scope_extreme_residuals = extreme_residuals,
    cross_scope_prediction_domain = prediction_domain,
    scenario_literature_basis = literature
  )
  purrr::iwalk(tables, function(table, name) {
    WriteCsv(table, paste0(name, ".csv"))
  })
  WriteWorkbook(
    list(
      Scope_samples = samples,
      Validation_summary = validation,
      Structural_selection = selection,
      Family_equivalence = equivalence,
      Regulatory_LOPO = regulatory,
      Huber_sensitivity = huber_sensitivity,
      Initial_DBH_support = diameter_support,
      DBH_class_performance = DBH_class_performance,
      Estimator_sensitivity = estimator_sensitivity,
      Asymptote_identification = asymptote_identification,
      Extreme_residuals = extreme_residuals,
      Prediction_domain = prediction_domain,
      Scenario_literature = literature
    ),
    file.path(kRootOutputDirectory, "Cross_scope_summary.xlsx")
  )
  invisible(tables)
}

# 13. UNIT AND INTEGRATION TESTS ----------------------------------------------

RunUnitTests <- function() {
  failures <- character()
  checks <- list()
  RecordCheck <- function(name, expression) {
    success <- tryCatch(isTRUE(force(expression)), error = function(error) FALSE)
    checks[[length(checks) + 1L]] <<- data.frame(
      check = name, status = ifelse(success, "PASS", "FAIL"),
      stringsAsFactors = FALSE
    )
    LogMessage(
      if (success) "INFO" else "ERROR",
      paste("Unit check", name, if (success) "passed." else "failed."),
      log_file = kUnitTestLogFile
    )
    if (!success) failures <<- c(failures, name)
    invisible(success)
  }

  synthetic <- data.frame(
    plot_id = c(1L, 1L, 2L, 2L),
    initial_dbh = c(20, 30, 20, 30),
    dbh_final = c(21, 31, 21.2, 31.2),
    interval_years_value = c(1, 1, 1, 1),
    basal_area_2013_m2_ha = c(20, 20, 30, 30),
    stringsAsFactors = FALSE
  )
  scaler <- ComputeBasalAreaScaler(synthetic)
  duplicated_synthetic <- dplyr::bind_rows(synthetic, synthetic[1, , drop = FALSE])
  duplicated_scaler <- ComputeBasalAreaScaler(duplicated_synthetic)
  RecordCheck(
    "basal_area_scaler_uses_unique_plots",
    all.equal(scaler$center, 25, tolerance = 1e-12) == TRUE &&
      all.equal(scaler$center, duplicated_scaler$center, tolerance = 1e-12) == TRUE
  )

  for (structural_id in kStructuralSpecifications$structural_id) {
    specification <- GetSpecification(structural_id)
    prepared <- ApplyBasalAreaScaler(synthetic, scaler, specification$uses_basal_area)
    parameters <- if (specification$uses_basal_area) {
      c(asymptote = 250, log_rate = -5, basal_area_log_rate_effect = 0.2,
        shape = ifelse(specification$model_family == "Richards", 0.7, 1.2))
    } else {
      c(asymptote = 250, log_rate = -5,
        shape = ifelse(specification$model_family == "Richards", 0.7, 1.2))
    }
    prediction <- PredictFromParameters(parameters, prepared, specification)
    RecordCheck(
      paste0(structural_id, "_finite_monotone_prediction"),
      all(is.finite(prediction)) && all(prediction >= prepared$initial_dbh)
    )
    zero_time <- prepared
    zero_time$interval_years_value <- 0
    zero_prediction <- PredictFromParameters(parameters, zero_time, specification)
    RecordCheck(
      paste0(structural_id, "_zero_time_identity"),
      isTRUE(all.equal(zero_prediction, zero_time$initial_dbh, tolerance = 1e-8))
    )
    formula_names <- all.vars(ModelFormula(specification))
    RecordCheck(
      paste0(structural_id, "_formula_has_required_variables"),
      all(c("dbh_final", "initial_dbh", "interval_years_value") %in% formula_names)
    )
    evaluation_data <- as.list(prepared)
    for (parameter_name in names(parameters)) {
      evaluation_data[[parameter_name]] <- unname(parameters[parameter_name])
    }
    formula_prediction <- eval(
      ModelFormula(specification)[[3]], envir = evaluation_data
    )
    RecordCheck(
      paste0(structural_id, "_nls_formula_matches_prediction_function"),
      isTRUE(all.equal(prediction, formula_prediction, tolerance = 1e-10))
    )
  }

  no_ba_spec <- GetSpecification("Richards_noBA")
  no_ba_data <- ApplyBasalAreaScaler(synthetic, scaler, FALSE)
  no_ba_parameters <- c(asymptote = 250, log_rate = -5, shape = 0.7)
  prediction_one <- PredictFromParameters(no_ba_parameters, no_ba_data, no_ba_spec)
  no_ba_data$basal_area_z <- c(-100, 100, -50, 50)
  prediction_two <- PredictFromParameters(no_ba_parameters, no_ba_data, no_ba_spec)
  RecordCheck(
    "noBA_candidate_is_invariant_to_basal_area",
    isTRUE(all.equal(prediction_one, prediction_two, tolerance = 1e-12))
  )

  RecordCheck(
    "taxon_normalization_preserves_explicit_and_fills_missing_values",
    identical(
      NormalizeTaxonComponent(c(" Hura ", "", NA), "Unidentified"),
      c("Hura", "Unidentified", "Unidentified")
    )
  )
  RecordCheck(
    "commercial_scientific_name_normalization_uses_genus_and_epithet",
    identical(
      NormalizeRegistryScientificName(c(
        "Virola surinamensis (Rol. ex Rottb.) Warb.",
        "Platymiscium pinnatum var. ulei (Harms) Klitg.",
        "Copaifera sp."
      )),
      c("Virola surinamensis", "Platymiscium pinnatum", "Copaifera sp.")
    )
  )
  registry_test_raw <- data.frame(
    V1 = c("Status", "Listed species", "Protected species"),
    V2 = c("Legal basis", "Harvest permitted", "Federal law"),
    V3 = c("Species", "Virola surinamensis A.", "Virola surinamensis A."),
    stringsAsFactors = FALSE
  )
  registry_test <- ResolveCommercialRegistryRows(
    ParseCommercialSpeciesRegistry(registry_test_raw)
  )
  RecordCheck(
    "protected_registry_status_overrides_conflicting_permission",
    nrow(registry_test) == 1L &&
      registry_test$commercial_permission_class == "protected" &&
      registry_test$regulatory_status_conflict
  )
  placeholder_test <- data.frame(
    period_pair = rep(kExcludedPlaceholderPeriods[1], 3),
    status_code = c(kTargetClass, kTargetClass, "1"),
    source_initial_dbh = c(20, 30, 40), source_final_dbh = c(20, 30, 0),
    stringsAsFactors = FALSE
  )
  placeholder_audit <- tryCatch(
    AuditExcludedPlaceholderPeriods(placeholder_test),
    error = function(error) error
  )
  RecordCheck(
    "all_zero_survivor_placeholder_period_is_audited",
    !inherits(placeholder_audit, "error") &&
      placeholder_audit$survivor_rows == 2L &&
      placeholder_audit$survivor_nonzero_increments == 0L
  )
  invalid_placeholder_test <- placeholder_test
  invalid_placeholder_test$source_final_dbh[1] <- invalid_placeholder_test$source_initial_dbh[1] + 0.2
  invalid_placeholder_result <- tryCatch(
    AuditExcludedPlaceholderPeriods(invalid_placeholder_test),
    error = function(error) error
  )
  RecordCheck(
    "measured_period_cannot_be_silently_excluded_as_placeholder",
    inherits(invalid_placeholder_result, "error")
  )
  curation_test_raw <- data.frame(
    source_plot_id = c(6L, 6L, 6L),
    tree_tag = c("T_high", "T_zero", "T_placeholder"),
    period_pair = c(
      kModelingPeriods[1], kModelingPeriods[1],
      kExcludedPlaceholderPeriods[1]
    ),
    status_code = rep(kTargetClass, 3),
    source_initial_dbh = c(20, 25, 30),
    source_final_dbh = c(26, 25, 30),
    source_interval_years = c(1, 3, 1),
    stringsAsFactors = FALSE
  )
  curation_test <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = FALSE,
      records = DataCurationAuditTemplate(),
      message = "test audit sheet absent"
    )
  )
  RecordCheck(
    "missing_curation_evidence_uses_neutral_nonverified_language",
    all(
      curation_test$provenance$curation_status[
        curation_test$provenance$publication_freeze_required
      ] == "NOT_DOCUMENTED"
    ) &&
      all(!grepl(
        "field-verified|field verified",
        curation_test$provenance$permissible_claim,
        ignore.case = TRUE
      )) &&
      any(curation_test$checkpoint$status == "FAIL") &&
      !curation_test$publication_ready
  )

  RecordCheck(
    "incomplete_curation_blocks_freeze_but_not_analytical_execution",
    isTRUE(kRequireDocumentedCurationAudit) &&
      !isTRUE(kBlockModelFittingWhenCurationIncomplete) &&
      !curation_test$publication_ready
  )

  prefill_test <- BuildDataCurationAuditPrefill(curation_test_raw)
  RecordCheck(
    "curation_prefill_contains_only_frozen_required_components",
    setequal(
      unique(prefill_test$event_type),
      c(
        "negative_increment_removed_upstream",
        "high_annual_increment_retained",
        "placeholder_period_exclusion"
      )
    ) &&
      !"zero_increment_retained" %in% prefill_test$event_type
  )

  documented_curation_records <- prefill_test
  documented_curation_records$justification <- "unit-test documented decision"
  documented_curation_records$verification_source <- "unit-test source"
  documented_curation_records$reviewer <- "unit-test reviewer"
  documented_curation_records$verification_date <- "2026-08-15"
  documented_curation_records$affected_rows[
    documented_curation_records$event_type ==
      "negative_increment_removed_upstream"
  ] <- 4L
  documented_curation <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = documented_curation_records,
      message = "three frozen curation components supplied"
    )
  )
  RecordCheck(
    "documented_curation_requires_exact_frozen_requirement_reconciliation",
    documented_curation$publication_ready &&
      all(
        documented_curation$provenance$curation_status[
          documented_curation$provenance$publication_freeze_required
        ] == "DOCUMENTED"
      ) &&
      all(
        documented_curation$provenance$count_reconciled[
          documented_curation$provenance$publication_freeze_required
        ] %in% TRUE
      )
  )

  zero_component <- documented_curation$provenance %>%
    dplyr::filter(expected_event_type == "zero_increment_retained")
  RecordCheck(
    "zero_increment_documentation_is_diagnostic_not_freeze_required",
    nrow(zero_component) == 1L &&
      !zero_component$publication_freeze_required &&
      zero_component$curation_status == "OPTIONAL_NOT_REQUIRED" &&
      documented_curation$publication_ready
  )

  generic_source_records <- documented_curation_records
  generic_source_records$verification_source[
    generic_source_records$event_type == "high_annual_increment_retained"
  ] <- "verified and retained"
  generic_source_test <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = generic_source_records,
      message = "generic source test"
    )
  )
  RecordCheck(
    "generic_verification_language_is_not_accepted_as_documentary_source",
    !generic_source_test$publication_ready &&
      any(generic_source_test$provenance$curation_status ==
            "INCOMPLETE_DOCUMENTATION")
  )

  count_mismatch_records <- documented_curation_records
  count_mismatch_records$affected_rows[
    count_mismatch_records$event_type == "high_annual_increment_retained"
  ] <- 2L
  count_mismatch <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = count_mismatch_records,
      message = "count mismatch test"
    )
  )
  RecordCheck(
    "curation_count_mismatch_blocks_publication",
    !count_mismatch$publication_ready &&
      any(count_mismatch$provenance$curation_status == "INVALID_AFFECTED_ROWS")
  )

  row_mismatch_records <- documented_curation_records
  row_mismatch_records$tree_tag[
    row_mismatch_records$event_type == "high_annual_increment_retained"
  ] <- "wrong_tree"
  row_mismatch <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = row_mismatch_records,
      message = "row identity mismatch test"
    )
  )
  RecordCheck(
    "high_increment_row_identity_mismatch_blocks_publication",
    !row_mismatch$publication_ready &&
      any(row_mismatch$provenance$curation_status == "ROW_IDENTITY_MISMATCH")
  )

  placeholder_count_mismatch_records <- documented_curation_records
  placeholder_count_mismatch_records$affected_rows[
    placeholder_count_mismatch_records$event_type == "placeholder_period_exclusion"
  ] <- 2L
  placeholder_count_mismatch <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = placeholder_count_mismatch_records,
      message = "placeholder count mismatch test"
    )
  )
  RecordCheck(
    "placeholder_aggregate_count_mismatch_blocks_publication",
    !placeholder_count_mismatch$publication_ready &&
      any(placeholder_count_mismatch$provenance$curation_status == "COUNT_MISMATCH")
  )

  placeholder_period_mismatch_records <- documented_curation_records
  placeholder_period_mismatch_records$period[
    placeholder_period_mismatch_records$event_type == "placeholder_period_exclusion"
  ] <- "wrong-period"
  placeholder_period_mismatch <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = placeholder_period_mismatch_records,
      message = "placeholder period mismatch test"
    )
  )
  RecordCheck(
    "placeholder_period_identity_mismatch_blocks_publication",
    !placeholder_period_mismatch$publication_ready &&
      any(placeholder_period_mismatch$provenance$curation_status == "PERIOD_IDENTITY_MISMATCH")
  )

  unsupported_missing_upstream_count_records <- documented_curation_records
  unsupported_missing_upstream_count_records$affected_rows[
    unsupported_missing_upstream_count_records$event_type ==
      "negative_increment_removed_upstream"
  ] <- NA_integer_
  unsupported_missing_upstream_count <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = unsupported_missing_upstream_count_records,
      message = "unsupported missing upstream count test"
    )
  )
  RecordCheck(
    "unsupported_missing_upstream_negative_count_still_blocks_publication",
    !unsupported_missing_upstream_count$publication_ready &&
      any(unsupported_missing_upstream_count$provenance$curation_status ==
            "INVALID_AFFECTED_ROWS")
  )

  documented_unavailable_count_records <- documented_curation_records
  negative_index <- documented_unavailable_count_records$event_type ==
    "negative_increment_removed_upstream"
  documented_unavailable_count_records$affected_rows[negative_index] <- NA_integer_
  documented_unavailable_count_records$justification[negative_index] <- paste0(
    "The original upstream negative-increment count cannot be reconstructed from ",
    "the analytical workbook; this is an explicit limitation of the closed protocol."
  )
  documented_unavailable_count_records$verification_source[negative_index] <-
    "PROTOCOLO_METODOLOGICO.md, Section 2, closed methodological protocol"
  documented_unavailable_count <- BuildDataCurationProvenance(
    curation_test_raw,
    list(
      sheet_present = TRUE,
      records = documented_unavailable_count_records,
      message = "documented unavailable upstream count test"
    )
  )
  RecordCheck(
    "closed_protocol_documented_nonreconstructable_upstream_count_is_accepted",
    documented_unavailable_count$publication_ready &&
      any(documented_unavailable_count$provenance$curation_status ==
            "DOCUMENTED_LIMITATION") &&
      any(documented_unavailable_count$provenance$
            upstream_count_documented_unavailable %in% TRUE)
  )

  zero_diagnostic_test <- BuildZeroIncrementDiagnostic(curation_test_raw)
  RecordCheck(
    "zero_increment_diagnostic_is_exportable_without_audit_evidence",
    nrow(zero_diagnostic_test) == 1L &&
      zero_diagnostic_test$tree_tag == "T_zero" &&
      grepl("diagnostic_only", zero_diagnostic_test$freeze_requirement)
  )

  filter_test_selection <- data.frame(
    model_family = c("Richards", "Lundqvist"),
    selected_structural_id = c("Richards_noBA", "Lundqvist_noBA"),
    stringsAsFactors = FALSE
  )
  filter_test_predictions <- expand.grid(
    structural_id = c(
      "Richards_noBA", "Lundqvist_noBA", "Richards_BA2013"
    ),
    estimator = c("OLS", "Student_t"),
    scheme = c("LOPO", "Temporal"),
    KEEP.OUT.ATTRS = FALSE,
    stringsAsFactors = FALSE
  )
  filtered_test <- FilterSelectedPredictions(
    filter_test_predictions, filter_test_selection,
    estimator = "OLS", scheme = "LOPO"
  )
  RecordCheck(
    "selected_prediction_filter_respects_scheme_estimator_and_structure",
    nrow(filtered_test) == 2L &&
      all(filtered_test$scheme == "LOPO") &&
      all(filtered_test$estimator == "OLS") &&
      setequal(
        filtered_test$structural_id,
        filter_test_selection$selected_structural_id
      )
  )

  selection_test_summary <- data.frame(
    scheme = "LOPO", estimator = "OLS",
    model_family = rep(c("Richards", "Lundqvist"), each = 2),
    uses_basal_area = rep(c(FALSE, TRUE), 2),
    structural_id = c(
      "Richards_noBA", "Richards_BA2013",
      "Lundqvist_noBA", "Lundqvist_BA2013"
    ),
    RMSE_final_cm = c(1.00, 1.10, 1.01, 1.11),
    stringsAsFactors = FALSE
  )
  selection_test_folds <- expand.grid(
    model_family = c("Richards", "Lundqvist"),
    uses_basal_area = c(FALSE, TRUE),
    fold_id = paste0("plot_", kTargetPlots),
    KEEP.OUT.ATTRS = FALSE,
    stringsAsFactors = FALSE
  ) %>%
    dplyr::mutate(
      scheme = "LOPO", estimator = "OLS", status = "success",
      RMSE_final_cm = ifelse(.data$uses_basal_area, 1.10, 1.00)
    )
  selection_test <- tryCatch(
    SelectBasalAreaStructures(selection_test_summary, selection_test_folds),
    error = function(error) error
  )
  RecordCheck(
    "structural_selection_is_separated_by_model_family",
    !inherits(selection_test, "error") && nrow(selection_test) == 2L &&
      setequal(
        selection_test$selected_structural_id,
        c("Richards_noBA", "Lundqvist_noBA")
      )
  )

  DBH_class_test_support <- expand.grid(
    scheme = c("LOPO", "Temporal"),
    class_order = seq_along(kDiameterSupportLabels),
    replicate = seq_len(kDbhClassMinimumIntervalsForComparativeDescription),
    KEEP.OUT.ATTRS = FALSE,
    stringsAsFactors = FALSE
  ) %>%
    dplyr::mutate(
      initial_dbh_cm = c(10, 30, 50, 70, 90, 120, 170, 210)[class_order],
      analysis_row_id = dplyr::row_number(),
      tree_id = paste0("tree_", class_order, "_", replicate),
      species_id = paste0("Species_", (replicate - 1L) %% 5L + 1L),
      plot_id = kTargetPlots[(replicate - 1L) %% length(kTargetPlots) + 1L],
      period_label = kModelingPeriods[(replicate - 1L) %%
                                        length(kModelingPeriods) + 1L],
      interval_years = 1,
      observed_final_dbh_cm = initial_dbh_cm + 1
    )
  DBH_class_test_models <- dplyr::bind_rows(
    tidyr::crossing(
      structural_id = filter_test_selection$selected_structural_id,
      estimator = c("OLS", "Huber")
    ) %>%
      dplyr::mutate(
        model_family = ifelse(
          grepl("Richards", structural_id), "Richards", "Lundqvist"
        ),
        uses_basal_area = FALSE
      ),
    data.frame(
      structural_id = "Persistence", estimator = "Persistence",
      model_family = "Persistence", uses_basal_area = FALSE,
      stringsAsFactors = FALSE
    )
  )
  DBH_class_test_predictions <- tidyr::crossing(
    DBH_class_test_support, DBH_class_test_models
  ) %>%
    dplyr::mutate(
      residual_cm = dplyr::case_when(
        estimator == "Persistence" ~ 1,
        estimator == "Huber" ~ 0.4,
        TRUE ~ 0.5
      ),
      predicted_final_dbh_cm = observed_final_dbh_cm - residual_cm,
      annualized_residual_cm_yr = residual_cm
    )
  DBH_class_test <- tryCatch(
    BuildDbhClassValidation(
      list(predictions = DBH_class_test_predictions), filter_test_selection
    ),
    error = function(error) error
  )
  RecordCheck(
    "DBH_class_validation_is_complete_and_reconciled",
    !inherits(DBH_class_test, "error") &&
      nrow(DBH_class_test$combined) ==
        2L * 5L * length(kDiameterSupportLabels) &&
      all(DBH_class_test$checkpoint$status == "PASS") &&
      all(DBH_class_test$count_reconciliation$reconciled)
  )

  for (structural_id in c("Richards_noBA", "Lundqvist_noBA")) {
    specification <- GetSpecification(structural_id)
    parameters <- c(
      asymptote = 300, log_rate = -5,
      shape = ifelse(specification$model_family == "Richards", 0.7, 1.2)
    )
    direct_data <- data.frame(
      initial_dbh = 30, interval_years_value = 90, basal_area_z = 0
    )
    direct_prediction <- PredictFromParameters(
      parameters, direct_data, specification
    )
    repeated_prediction <- ProjectRepeatedAnnualSteps(
      parameters, 30, 90, specification
    )
    RecordCheck(
      paste0(structural_id, "_90_year_step_invariance"),
      isTRUE(all.equal(
        direct_prediction, repeated_prediction,
        tolerance = kProjectionStepInvarianceToleranceCm
      ))
    )
  }

  scenario_test_profile <- expand.grid(
    structural_id = c("Richards_noBA", "Lundqvist_noBA"),
    fixed_asymptote_cm = kManagementScenarioAsymptotesCm,
    KEEP.OUT.ATTRS = FALSE,
    stringsAsFactors = FALSE
  ) %>%
    dplyr::mutate(
      model_family = ifelse(
        grepl("Richards", .data$structural_id), "Richards", "Lundqvist"
      ),
      uses_basal_area = FALSE, estimator = "OLS",
      status = "success", SSE = 1,
      optimization_solution_accepted = TRUE,
      log_rate = -5, basal_area_log_rate_effect = 0,
      shape = ifelse(.data$model_family == "Richards", 0.7, 1.2),
      relative_support = 1
    )
  scenario_test_huber_profile <- scenario_test_profile %>%
    dplyr::mutate(
      estimator = "Huber", Huber_objective = 1,
      fixed_OLS_scale_cm = 1,
      Huber_tuning_constant = kHuberTuningConstant,
      delta_AIC_fixed_profile = NA_real_, relative_support = NA_real_
    )
  scenario_test_data <- data.frame(
    initial_dbh = c(10, 80), dbh_final = c(11, 82),
    interval_years_value = c(1, 3.67),
    tree_id = c("6:1", "7:2"),
    species_id = c("Species one", "Species two"),
    plot_id = c(6L, 7L),
    period_label = c("2013-2016", "2018-2021"),
    stringsAsFactors = FALSE
  )
  scenario_test <- tryCatch(
    BuildConditionalManagementScenarios(
      scenario_test_data, filter_test_selection, scenario_test_profile,
      scenario_test_huber_profile
    ),
    error = function(error) error
  )
  scenario_test_valid <- if (inherits(scenario_test, "error")) {
    FALSE
  } else if (isTRUE(kEnableConditionalManagementScenarios)) {
    expected_estimator_count <- if (isTRUE(kRunHuberSensitivity)) 2L else 1L
    nrow(scenario_test$trajectories) ==
      expected_estimator_count * 2L * length(kManagementScenarioAsymptotesCm) *
      length(kManagementScenarioInitialDbhCm) *
      length(kManagementTrajectoryYears) &&
    nrow(scenario_test$horizon_summary) ==
      expected_estimator_count * 2L * length(kManagementScenarioAsymptotesCm) *
      length(kManagementScenarioInitialDbhCm) *
      length(kManagementHorizonYears) &&
      nrow(scenario_test$horizon_envelope_diagnostics) ==
      length(kManagementScenarioInitialDbhCm) *
      length(kManagementHorizonYears) &&
    nrow(scenario_test$diameter_threshold_crossings) ==
      expected_estimator_count * 2L * length(kManagementScenarioAsymptotesCm) *
      length(kManagementScenarioInitialDbhCm) *
      length(kLargeDiameterThresholdsCm) &&
      all(
        scenario_test$horizon_summary$projection_horizon_class[
          scenario_test$horizon_summary$projection_year == 90L
        ] == "long_term_structural_sensitivity"
      ) &&
      nrow(scenario_test$empirical_diameter_support) ==
        length(kDiameterSupportLabels) &&
      all(!is.na(
        scenario_test$trajectories$empirical_support_level
      )) &&
      scenario_test$invariance_audit$status == "PASS" &&
      all(scenario_test$Huber_long_horizon_checkpoint$status == "PASS") &&
      nrow(scenario_test$combined_envelope) ==
        length(kManagementScenarioInitialDbhCm) *
          length(kManagementTrajectoryYears)
  } else {
    nrow(scenario_test$trajectories) == 0L
  }
  RecordCheck(
    "conditional_scenario_grid_is_complete_and_step_invariant",
    scenario_test_valid
  )

  support_test <- BuildDiameterSupportAudit(scenario_test_data)
  RecordCheck(
    "diameter_support_audit_retains_all_predeclared_classes",
    nrow(support_test) == length(kDiameterSupportLabels) &&
      sum(support_test$intervals) == nrow(scenario_test_data) &&
      all(support_test$empirical_support_level %in%
            c("broad", "limited", "sparse"))
  )

  # Integration test: the predeclared prediction-domain bound must remain valid
  # when held-out trees are larger than those in the training subset.
  prediction_domain_training <- no_ba_data
  prediction_domain_training$initial_dbh <- c(20, 40, 60, 80)
  prediction_domain_training$dbh_final <- c(21, 41, 61, 81)
  prediction_domain_bounds <- GetBounds(
    no_ba_spec, prediction_domain_training
  )
  held_out_large_tree <- data.frame(
    initial_dbh = 220, interval_years_value = 1, basal_area_z = 0
  )
  held_out_prediction <- PredictFromParameters(
    c(
      asymptote = prediction_domain_bounds$lower["asymptote"],
      log_rate = -5, shape = 0.7
    ),
    held_out_large_tree, no_ba_spec
  )
  RecordCheck(
    "predeclared_asymptote_floor_protects_held_out_prediction_domain",
    isTRUE(all.equal(
      unname(prediction_domain_bounds$lower["asymptote"]),
      kPredictionDomainAsymptoteFloorCm,
      tolerance = 1e-12
    )) && is.finite(held_out_prediction)
  )
  prediction_domain_unit_audit <- ValidatePredictionDomainControl(
    scenario_test_data
  )
  RecordCheck(
    "full_prediction_domain_control_passes_before_fold_construction",
    prediction_domain_unit_audit$status == "PASS" &&
      kPredictionDomainAsymptoteFloorCm >
        kExpectedMaximumObservedDbhCm &&
      kPredictionDomainAsymptoteFloorCm >
        max(kManagementScenarioInitialDbhCm)
  )

  huber_test_residuals <- c(-0.2, 0, 0.2, 20)
  huber_test_scale <- ComputeRobustResidualScale(huber_test_residuals)
  RecordCheck(
    "Huber_scale_and_influence_rule_are_finite",
    is.finite(huber_test_scale) && huber_test_scale >= kHuberMinimumScaleCm &&
      kHuberTuningConstant / abs(20 / huber_test_scale) < 1
  )

  # Integration test: bound-aware local refinement must accept a valid optimum
  # near the common upper asymptote bound when the objective agreement rule
  # holds.
  local_test_raw <- expand.grid(
    plot_id = 1:3,
    initial_dbh = c(15, 30, 60),
    interval_years_value = c(0.92, 1, 2.5),
    KEEP.OUT.ATTRS = FALSE,
    stringsAsFactors = FALSE
  )
  local_test_raw$basal_area_2013_m2_ha <- c(20, 25, 30)[
    match(local_test_raw$plot_id, 1:3)
  ]
  local_test_raw$dbh_final <- local_test_raw$initial_dbh
  local_test_scaler <- ComputeBasalAreaScaler(local_test_raw)
  for (structural_id in kStructuralSpecifications$structural_id) {
    specification <- GetSpecification(structural_id)
    local_test_data <- ApplyBasalAreaScaler(
      local_test_raw, local_test_scaler, specification$uses_basal_area
    )
    generating_parameters <- if (specification$uses_basal_area) {
      c(
        asymptote = 250, log_rate = -5,
        basal_area_log_rate_effect = 0.15,
        shape = ifelse(specification$model_family == "Richards", 0.7, 1.2)
      )
    } else {
      c(
        asymptote = 250, log_rate = -5,
        shape = ifelse(specification$model_family == "Richards", 0.7, 1.2)
      )
    }
    local_test_data$dbh_final <- PredictFromParameters(
      generating_parameters, local_test_data, specification
    )
    difficult_start <- generating_parameters
    difficult_start["asymptote"] <- 0.95 * kAsymptoteUpper
    difficult_start["log_rate"] <- -5.2
    refinement <- tryCatch(
      RefineBoundedObjective(specification, difficult_start, local_test_data),
      error = function(error) error
    )
    RecordCheck(
      paste0(structural_id, "_bounded_local_refinement_is_usable"),
      !inherits(refinement, "error") && isTRUE(refinement$converged) &&
        all(is.finite(refinement$coefficients)) &&
      is.finite(refinement$objective)
    )
  }

  formal_optimizer_trace <- data.frame(
    local_method = "L-BFGS-B", local_optimizer_converged = TRUE,
    local_usable = TRUE, local_objective = 99, de_objective = 100,
    selected = TRUE, stringsAsFactors = FALSE
  )
  agreement_optimizer_trace <- data.frame(
    local_method = c("L-BFGS-B", "nlminb"),
    local_optimizer_converged = c(FALSE, FALSE),
    local_usable = c(TRUE, TRUE),
    local_objective = c(100, 100), de_objective = c(100, 100),
    selected = c(TRUE, FALSE), stringsAsFactors = FALSE
  )
  one_method_warning_trace <- agreement_optimizer_trace[1, , drop = FALSE]
  divergent_warning_trace <- agreement_optimizer_trace
  divergent_warning_trace$local_objective[2] <- 100.1
  RecordCheck(
    "formal_local_convergence_is_accepted",
    AssessOlsOptimizationAcceptance(formal_optimizer_trace)$accepted
  )
  RecordCheck(
    "independent_exact_objective_agreement_is_accepted",
    AssessOlsOptimizationAcceptance(agreement_optimizer_trace)$accepted
  )
  RecordCheck(
    "one_nonconverged_local_method_is_not_accepted",
    !AssessOlsOptimizationAcceptance(one_method_warning_trace)$accepted
  )
  RecordCheck(
    "divergent_nonconverged_objectives_are_not_accepted",
    !AssessOlsOptimizationAcceptance(divergent_warning_trace)$accepted
  )
  huber_agreement_trace <- agreement_optimizer_trace %>%
    dplyr::select(-de_objective)
  huber_acceptance_contract <-
    AssessHuberOptimizationAcceptance(huber_agreement_trace)
  RecordCheck(
    "independent_Huber_objective_agreement_is_accepted",
    huber_acceptance_contract$accepted
  )
  RecordCheck(
    "Huber_profile_optimizer_metadata_contract_is_scalar",
    length(huber_acceptance_contract$independent_usable_methods) == 1L &&
      is.finite(huber_acceptance_contract$independent_usable_methods)
  )

  lundqvist_spec <- GetSpecification("Lundqvist_BA2013")
  lundqvist_data <- ApplyBasalAreaScaler(synthetic, scaler, TRUE)
  lundqvist_parameters <- c(
    asymptote = 250, log_rate = log(0.004),
    basal_area_log_rate_effect = 0.1, shape = 1.3
  )
  stable_prediction <- PredictFromParameters(
    lundqvist_parameters, lundqvist_data, lundqvist_spec
  )
  expanded <- ExpandParameters(lundqvist_parameters, lundqvist_spec)
  rho <- exp(
    expanded["log_rate"] +
      expanded["basal_area_log_rate_effect"] * lundqvist_data$basal_area_z
  )
  raw_k <- rho^(-expanded["shape"])
  ratio <- lundqvist_data$initial_dbh / expanded["asymptote"]
  original_prediction <- expanded["asymptote"] * exp(
    -raw_k /
      ((-raw_k / log(ratio))^(1 / expanded["shape"]) +
         lundqvist_data$interval_years_value)^expanded["shape"]
  )
  RecordCheck(
    "Lundqvist_stable_parameterization_is_algebraically_equivalent",
    isTRUE(all.equal(stable_prediction, original_prediction, tolerance = 1e-9))
  )

  observed <- c(21, 32)
  predicted <- c(20.8, 31.5)
  initial <- c(20, 30)
  RecordCheck(
    "final_DBH_and_increment_residuals_are_identical",
    isTRUE(all.equal(observed - predicted,
                     (observed - initial) - (predicted - initial),
                     tolerance = 1e-14))
  )
  RecordCheck(
    "all_profile_asymptotes_are_positive",
    all(is.finite(kAsymptoteProfile)) && all(kAsymptoteProfile > 0)
  )
  RecordCheck(
    "scenario_grid_uses_complete_predeclared_asymptote_profile",
    identical(kManagementScenarioAsymptotesCm, kAsymptoteProfile)
  )
  RecordCheck(
    "analysis_scope_mode_and_species_vector_are_consistent",
    (identical(kAnalysisScopeMode, "eligible_community") &&
       length(kTargetSpecies) == 0L) ||
      (identical(kAnalysisScopeMode, "explicit_species_group") &&
         length(kTargetSpecies) > 0L)
  )
  RecordCheck(
    "dual_scope_plan_contains_community_and_commercial_group",
    identical(kPlannedAnalysisScopes, c("community", "commercial_group"))
  )
  RecordCheck(
    "scenario_checkpoints_cover_short_management_and_long_horizons",
    all(c(5L, 10L, 25L, 30L, 35L, 50L, 70L, 90L) %in%
          kManagementHorizonYears) &&
      max(kManagementTrajectoryYears) == 90L
  )
  figure_wrap_test <- WrapPublicationPlotText(
    ggplot2::ggplot() + ggplot2::labs(
      subtitle = paste(rep("publication subtitle wrapping test", 12), collapse = " ")
    ),
    width_inches = 8
  )
  RecordCheck(
    "publication_figure_subtitles_are_wrapped_before_export",
    grepl("\\n", figure_wrap_test$labels$subtitle) &&
      isTRUE(grepl("PDF", BuildConfigurationTable()$value[
        BuildConfigurationTable()$setting == "publication_figure_exports"
      ]))
  )
  RecordCheck(
    "publication_figure_dimensions_and_resolution_follow_full_width_artwork_rules",
    isTRUE(all.equal(
      kPublicationDoubleColumnWidthIn, 190 / 25.4, tolerance = 1e-12
    )) &&
      isTRUE(all.equal(
        kPublicationMaximumHeightIn, 230 / 25.4, tolerance = 1e-12
      )) &&
      kPublicationFigureDpi >= 500L &&
      kPublicationBaseFontSizePt >= 7 &&
      kPublicationMaximumFacetColumns <= 3L
  )

  results <- dplyr::bind_rows(checks)
  utils::write.csv(
    results, file.path(kOutputDirectory, "Tables", "unit_test_results.csv"),
    row.names = FALSE
  )
  if (length(failures) > 0L) {
    stop("Unit tests failed: ", paste(failures, collapse = ", "))
  }
  LogMessage(
    "INFO",
    sprintf("All %d unit checks passed; see the separate unit-test log.", nrow(results))
  )
  invisible(results)
}

# 14. PIPELINE ORCHESTRATION --------------------------------------------------

RunAnalysisScopePipeline <- function(raw_data, base_prepared, reconciliation,
                                     scope_id, commercial_species) {
  scope_directory_name <- if (identical(scope_id, "community")) {
    "Community"
  } else {
    "Commercially_listed_species_group"
  }
  SetAnalysisScope(scope_id, commercial_species)
  SetOutputContext(file.path(kRootOutputDirectory, scope_directory_name))
  InitializeDirectories(scope_output = TRUE)
  started_at <- Sys.time()
  LogMessage(
    "INFO",
    paste("Starting scope", scope_id, "under", kModelSpecVersion)
  )
  prepared <- BuildPreparedAnalysisScope(
    base_prepared, scope_id, commercial_species
  )
  prediction_domain_audit <- ValidatePredictionDomainControl(prepared$data)
  signature <- BuildAnalysisSignature()
  WriteCsv(
    prediction_domain_audit,
    "prediction_domain_control_checkpoint.csv"
  )

  if (kValidateOnly) {
    WriteValidationOnlyOutputs(
      raw_data, prepared, reconciliation, signature, started_at
    )
    LogMessage("INFO", paste("Validation-only scope completed:", scope_id))
    return(invisible(list(
      prepared = prepared,
      sample_summary = BuildScopeSampleSummary(prepared),
      reconciliation = reconciliation,
      validation_summary = data.frame(note = "not run: kValidateOnly=TRUE"),
      selection = data.frame(note = "not run: kValidateOnly=TRUE"),
      family_equivalence = data.frame(note = "not run: kValidateOnly=TRUE"),
      regulatory_stratum_diagnostics = data.frame(
        note = "not run: kValidateOnly=TRUE"
      ),
      robust_loss_sensitivity = list(
        metric_comparison = data.frame(note = "not run: kValidateOnly=TRUE")
      ),
      extreme_residual_audit = list(
        summary = data.frame(note = "not run: kValidateOnly=TRUE")
      ),
      DBH_class_validation = list(
        combined = data.frame(note = "not run: kValidateOnly=TRUE")
      ),
      conditional_management_scenarios = list(
        empirical_diameter_support = BuildDiameterSupportAudit(prepared$data),
        estimator_sensitivity = data.frame(
          note = "not run: kValidateOnly=TRUE"
        )
      ),
      asymptote_identification = list(
        summary = data.frame(note = "not run: kValidateOnly=TRUE")
      ),
      prediction_domain_audit = prediction_domain_audit,
      signature = signature
    )))
  }

  LogMessage("INFO", "Beginning strict plot-blocked and temporal validation.")
  validation <- RunStrictValidation(prepared$data, signature)
  validation_summary <- SummarizeValidation(validation)
  # Compact checkpoint tables precede structural selection so an interrupted
  # scope remains diagnosable without reopening caches or repeating all folds.
  WriteCsv(validation$design_audit, "validation_design_audit_checkpoint.csv")
  WriteCsv(validation$fold_summary, "validation_fold_summary_checkpoint.csv")
  WriteCsv(validation_summary, "validation_summary_checkpoint.csv")
  WriteCsv(validation$coefficients, "validation_coefficients_checkpoint.csv")
  WriteCsv(
    validation$optimizer_diagnostics,
    "validation_optimizer_diagnostics_checkpoint.csv"
  )
  selection <- SelectBasalAreaStructures(
    validation_summary, validation$fold_summary
  )
  family_equivalence <- AssessFamilyEquivalence(
    validation_summary, selection
  )
  species_diagnostics <- ComputeSpeciesOosDiagnostics(validation, selection)
  species_group_robustness <- SummarizeSpeciesGroupRobustness(
    species_diagnostics
  )
  regulatory_stratum_diagnostics <-
    ComputeRegulatoryStratumOosDiagnostics(validation, selection)
  WriteCsv(
    regulatory_stratum_diagnostics,
    "regulatory_stratum_LOPO_checkpoint.csv"
  )
  temporal_fold_contrasts <- ComputeTemporalFoldContrasts(
    validation$fold_summary, selection
  )
  lopo_bootstrap <- BootstrapLopoClusterContrasts(validation, selection)
  robust_loss_sensitivity <- BuildRobustLossSensitivity(
    validation, validation_summary, selection
  )
  dbh_class_validation <- BuildDbhClassValidation(validation, selection)
  extreme_residual_audit <- BuildExtremeResidualAudit(
    validation, selection
  )
  WriteCsv(
    robust_loss_sensitivity$metric_comparison,
    "Huber_metric_sensitivity_checkpoint.csv"
  )
  WriteCsv(
    robust_loss_sensitivity$fold_completeness,
    "Huber_fold_completeness_checkpoint.csv"
  )
  WriteCsv(
    robust_loss_sensitivity$prediction_shift,
    "Huber_prediction_shift_checkpoint.csv"
  )
  WriteCsv(
    dbh_class_validation$LOPO,
    "LOPO_metrics_by_initial_DBH_class_checkpoint.csv"
  )
  WriteCsv(
    dbh_class_validation$Temporal,
    "Temporal_metrics_by_initial_DBH_class_checkpoint.csv"
  )
  WriteCsv(
    dbh_class_validation$checkpoint,
    "DBH_class_validation_checkpoint.csv"
  )
  WriteCsv(
    extreme_residual_audit$summary,
    "LOPO_extreme_residual_summary_checkpoint.csv"
  )
  WriteCsv(
    extreme_residual_audit$rows,
    "LOPO_extreme_residual_rows_checkpoint.csv"
  )
  if (any(validation_summary$validation_status != "complete")) {
    LogMessage(
      "WARN",
      "At least one validation result is partial; inspect fold failures before interpretation."
    )
  }

  full_fits <- FitAllFullCandidates(prepared$data, signature)
  full_outputs <- BuildFullFitOutputs(prepared$data, full_fits)
  profiles <- list()
  for (structural_id in kStructuralSpecifications$structural_id) {
    profiles[[structural_id]] <- ProfileAsymptote(
      prepared$data, GetSpecification(structural_id),
      full_fits[[structural_id]]$OLS, signature
    )
  }
  profile <- dplyr::bind_rows(profiles)
  huber_profiles <- list()
  if (isTRUE(kRunHuberSensitivity)) {
    for (structural_id in unname(SelectedStructuralIds(selection))) {
      huber_profiles[[structural_id]] <- ProfileHuberAsymptote(
        prepared$data, GetSpecification(structural_id), profile, signature
      )
    }
  }
  huber_profile <- dplyr::bind_rows(huber_profiles)
  asymptote_identification <- BuildAsymptoteIdentificationSummary(
    full_outputs, profile, selection
  )
  WriteCsv(huber_profile, "Huber_asymptote_profile_checkpoint.csv")
  WriteCsv(
    asymptote_identification$summary,
    "asymptote_identification_summary_checkpoint.csv"
  )
  WriteCsv(
    asymptote_identification$checkpoint,
    "asymptote_identification_checkpoint.csv"
  )
  management_scenarios <- BuildConditionalManagementScenarios(
    prepared$data, selection, profile, huber_profile
  )
  WriteCsv(
    management_scenarios$Huber_long_horizon_checkpoint,
    "Huber_long_horizon_checkpoint.csv"
  )
  WriteCsv(
    management_scenarios$empirical_diameter_support,
    "initial_DBH_empirical_support_checkpoint.csv"
  )
  WriteCsv(
    management_scenarios$scenario_start_support,
    "conditional_scenario_start_support_checkpoint.csv"
  )
  inference_scope <- BuildInferenceScopeTable(prepared$data)
  combined_predictions <- dplyr::bind_rows(
    full_outputs$predictions, validation$predictions
  )
  residual_dependence <- ComputeResidualDependence(combined_predictions)
  plot_residual_diagnostics <- ComputePlotResidualDiagnostics(combined_predictions)

  WriteAllFigures(
    prepared$data, full_outputs, validation, validation_summary,
    selection, profile, management_scenarios, dbh_class_validation
  )
  WriteAnalysisOutputs(
    raw_data, prepared, reconciliation, validation, validation_summary,
    selection, family_equivalence, species_diagnostics,
    species_group_robustness, regulatory_stratum_diagnostics,
    temporal_fold_contrasts, lopo_bootstrap, residual_dependence,
    plot_residual_diagnostics, robust_loss_sensitivity,
    extreme_residual_audit, dbh_class_validation,
    full_fits, full_outputs, profile, huber_profile,
    asymptote_identification, management_scenarios, inference_scope,
    signature, started_at
  )
  LogMessage(
    "INFO",
    sprintf(
      "Scope %s completed successfully in %.2f hours.",
      scope_id,
      as.numeric(difftime(Sys.time(), started_at, units = "hours"))
    )
  )
  invisible(list(
    prepared = prepared,
    sample_summary = BuildScopeSampleSummary(prepared),
    validation = validation,
    validation_summary = validation_summary,
    selection = selection,
    family_equivalence = family_equivalence,
    species_LOPO_diagnostics = species_diagnostics,
    species_group_robustness = species_group_robustness,
    regulatory_stratum_diagnostics = regulatory_stratum_diagnostics,
    temporal_fold_contrasts = temporal_fold_contrasts,
    LOPO_cluster_bootstrap = lopo_bootstrap,
    robust_loss_sensitivity = robust_loss_sensitivity,
    DBH_class_validation = dbh_class_validation,
    extreme_residual_audit = extreme_residual_audit,
    residual_dependence = residual_dependence,
    full_fits = full_fits,
    full_outputs = full_outputs,
    asymptote_profile = profile,
    Huber_asymptote_profile = huber_profile,
    asymptote_identification = asymptote_identification,
    conditional_management_scenarios = management_scenarios,
    inference_scope = inference_scope,
    prediction_domain_audit = prediction_domain_audit,
    signature = signature
  ))
}

ExecutePipeline <- function() {
  SetRootOutputContext()
  InitializeDirectories(scope_output = FALSE)
  started_at <- Sys.time()
  LogMessage("INFO", paste("Starting single-workbook dual-scope robust pipeline", kModelSpecVersion))
  LogMessage("INFO", paste("Input workbook:", normalizePath(kDataFile, mustWork = FALSE)))
  LogMessage(
    "INFO",
    paste(
      "Analytical sheets:", kDataSheet, ",", kCommercialSpeciesSheet,
      "and publication-freeze audit", kCurationAuditSheet
    )
  )
  if (!file.exists(kDataFile)) {
    stop("Input workbook not found: ", kDataFile)
  }

  SetAnalysisScope("community")
  RunUnitTests()
  raw_data <- ReadGrowthIntervalSheet(kDataFile)
  curation_audit <- ReadDataCurationAudit(kDataFile)
  curation_provenance <- BuildDataCurationProvenance(
    raw_data, curation_audit
  )
  WriteCsv(curation_provenance$records, "data_curation_audit_records.csv")
  WriteCsv(curation_provenance$provenance, "data_curation_provenance.csv")
  WriteCsv(curation_provenance$checkpoint, "data_curation_checkpoint.csv")
  WriteCsv(
    curation_provenance$template, "Data_curation_audit_template.csv"
  )
  WriteCsv(
    curation_provenance$template, "Data_curation_audit_prefilled.csv"
  )
  WriteCsv(
    curation_provenance$zero_increment_diagnostic, "zero_increment_diagnostic.csv"
  )
  WriteCsv(
    curation_provenance$documentation_requirements,
    "curation_documentation_requirements.csv"
  )
  if (!isTRUE(curation_provenance$publication_ready)) {
    curation_message <- paste0(
      "Data-curation provenance is incomplete for publication/freezing. ",
      "The pipeline exported data_curation_checkpoint.csv, ",
      "Data_curation_audit_prefilled.csv, zero_increment_diagnostic.csv, and ",
      "curation_documentation_requirements.csv. Full analytical execution will ",
      "continue, but the run must remain NOT RELEASED for publication/freezing ",
      "until the '", kCurationAuditSheet, "' worksheet is complete and reconciled."
    )
    if (isTRUE(kBlockModelFittingWhenCurationIncomplete)) {
      LogMessage("ERROR", curation_message)
      stop(curation_message)
    }
    LogMessage("WARN", curation_message)
  }
  base_prepared <- PrepareGrowthData(raw_data, curation_provenance)
  reconciliation <- ValidatePreparedReconciliation(raw_data, base_prepared)
  registry <- ReadCommercialSpeciesRegistry(kDataFile)
  registry_audit <- ReconcileCommercialRegistry(
    registry, base_prepared$eligible_community_data
  )
  registry_controls <- ValidateCommercialRegistryReconciliation(registry_audit)
  base_prepared <- AttachCommercialRegistryToPrepared(
    base_prepared, registry_audit
  )
  WriteCommercialRegistryAudit(registry_audit, registry_controls)
  commercial_species <- sort(unique(registry_audit$matched$species_id))

  scope_results <- list()
  for (scope_id in kPlannedAnalysisScopes) {
    scope_results[[scope_id]] <- RunAnalysisScopePipeline(
      raw_data, base_prepared, reconciliation,
      scope_id, commercial_species
    )
  }
  cross_scope_outputs <- WriteCrossScopeOutputs(scope_results)
  SetRootOutputContext()
  analytical_hours <- as.numeric(difftime(Sys.time(), started_at, units = "hours"))
  freeze_released <- isTRUE(curation_provenance$publication_ready)
  publication_freeze_status <- data.frame(
    component = c(
      "computational_execution", "analytical_evaluation",
      "data_curation_provenance", "publication_freeze"
    ),
    status = c(
      "PASS", "PASS",
      if (freeze_released) "PASS" else "PENDING",
      if (freeze_released) "RELEASED" else "BLOCKED"
    ),
    interpretation = c(
      "The complete dual-scope statistical pipeline finished without a fatal computational error.",
      "Analytical outputs were produced under the frozen FEM-10 statistical specification.",
      if (freeze_released) {
        "All three frozen FEM-10 curation requirements are documented and reconcile exactly."
      } else {
        paste0(
          "Curation provenance is incomplete; see data_curation_checkpoint.csv and ",
          "Data_curation_audit_prefilled.csv. This does not invalidate the analytical execution."
        )
      },
      if (freeze_released) {
        "The curation gate is satisfied; publication/freezing may be evaluated against all remaining FEM-10 criteria."
      } else {
        "NOT RELEASED for publication or freezing until the curation-provenance checkpoint passes."
      }
    ),
    stringsAsFactors = FALSE
  )
  WriteCsv(publication_freeze_status, "publication_freeze_status.csv")
  if (freeze_released) {
    LogMessage(
      "INFO",
      sprintf(
        paste0(
          "Single-workbook dual-scope pipeline completed analytically in %.2f hours; ",
          "the data-curation publication-freeze gate passed."
        ),
        analytical_hours
      )
    )
  } else {
    LogMessage(
      "WARN",
      sprintf(
        paste0(
          "Single-workbook dual-scope pipeline completed analytically in %.2f hours, ",
          "but publication/freezing remains BLOCKED because data-curation provenance is incomplete."
        ),
        analytical_hours
      )
    )
  }
  invisible(list(
    commercial_registry_audit = registry_audit,
    commercial_registry_controls = registry_controls,
    scopes = scope_results,
    cross_scope_outputs = cross_scope_outputs,
    publication_freeze_status = publication_freeze_status
  ))
}

# 15. PIPELINE EXECUTION ENTRY POINT ------------------------------------------

# Sourcing this file runs the complete pipeline and retains the returned object
# as RStudioPipelineResult for reproducibility and post-run inspection.
if (interactive()) {
  RStudioPipelineResult <- tryCatch(
    ExecutePipeline(),
    error = function(error) {
      if (dir.exists(kRootOutputDirectory)) {
        try(
          LogMessage("ERROR", error$message, log_file = kRootLogFile),
          silent = TRUE
        )
      }
      message("\nPIPELINE INTERRUPTED: ", conditionMessage(error))
      message("See the root and scope pipeline logs in: ", kRootOutputDirectory)
      stop(error)
    }
  )
} else {
  message(
    "This version is intended for RStudio. Open the file in RStudio and click Source."
  )
}