DEoptimIterative(convergence =): stopping rule as an argument, outside the chunk cache keys

NAMESPACE

@@ -9,6 +9,7 @@ export(DEoptimIterative2)
 export(DEoptimProgress)
 export(clusterSetup)
 export(currentCluster)
+export(deoptimConvergence)
 export(dirNew)
 export(freeCoresLessReserved)
 export(getHostCombination)

NEWS.md

@@ -1,5 +1,7 @@
 # clusters (development version)
 
+* `DEoptimIterative()` gains `convergence`, a list with any of `window`, `minGenerations`, `se`, `sdChange`; what is missing comes from the `clusters.deoptim*` options, then the unchanged defaults (300, 350, 1, 0.1). `deoptimConvergence()` returns the full list. The settings are not in any chunk's cache key, so a fit that stopped early resumes from its cached generations and continues under a stricter rule. The defaults of those four options are now in `.optionDefaults`.
+
 * `DEoptimDashboard()` and `DEoptimDashboardApp()` gain `initialIteration` (default `5L`): the plots start at that generation, so very poor first generations do not flatten them.
 
 * `DEoptimProgress()`, `DEoptimDashboard()` and `DEoptimDashboardApp()` take `which`, any of `"running"`, `"stopped"`,

R/DEoptim.R

@@ -192,6 +192,27 @@
   if (is.null(cl)) apply(pop, 1, f) else parallel::parApply(cl, pop, 1, f)
 }
 
+#' The DEoptim early-stop settings, in full
+#'
+#' Resolves the settings that decide when [DEoptimIterative()] stops a fit that has stopped improving:
+#' an element of `convergence` wins, else the matching `clusters.*` option, else the default.
+#' A caller that caches a whole fit can put the result in its cache key.
+#'
+#' @param convergence `NULL`, or a list with any of `window`, `minGenerations`, `se`, `sdChange`
+#'   (see [DEoptimIterative()]).
+#' @return A list with `window`, `minGenerations`, `se` and `sdChange`.
+#' @export
+deoptimConvergence <- function(convergence = NULL) {
+  map <- c(window = "deoptimConvergenceWindow", minGenerations = "deoptimMinGenerations",
+           se = "deoptimConvergenceSE", sdChange = "deoptimConvergenceSDChange")
+  unknown <- setdiff(names(convergence), names(map))
+  if (length(unknown))
+    stop("convergence has unknown element(s): ", paste(unknown, collapse = ", "),
+         "; use any of ", paste(names(map), collapse = ", "))
+  lapply(stats::setNames(names(map), names(map)), function(nm)
+    if (is.null(convergence[[nm]])) .clustersOption(map[[nm]]) else convergence[[nm]])
+}
+
 #' Run DEoptim in cached chunks of generations
 #'
 #' Runs [DEoptim::DEoptim()] a few generations at a time (`iterStep` in `...`, default 1),
@@ -218,6 +239,14 @@
 #'   returns. `NULL` (the default) writes `DEoptimProgress_<runName>.csv` in `figurePath`, or in the working
 #'   directory when `figurePath` is `FALSE`; `FALSE` writes none; a character path is that file. The file is
 #'   emptied when the call starts, so a fit resumed from the cache rewrites its history.
+#' @param convergence The early-stop settings: a list with any of `window` (generations over which the
+#'   population median must have stopped improving), `minGenerations` (never stop before this many),
+#'   `se` (the improvement allowed, in standard errors of the median) and `sdChange` (the change in spread
+#'   allowed, as a fraction of the earlier spread). What is missing comes from
+#'   `options(clusters.deoptimConvergenceWindow, clusters.deoptimMinGenerations, clusters.deoptimConvergenceSE,
+#'   clusters.deoptimConvergenceSDChange)`, then the defaults (300, 350, 1, 0.1); see [deoptimConvergence].
+#'   These are not in the cache key of any chunk, so a fit that stopped early resumes from its cached
+#'   generations and continues when rerun with a stricter rule.
 #' @param plotEvery Generations between progress figures: a chunk's figures are drawn when its
 #'   generations include a multiple of `plotEvery`. The final chunk's figures are always drawn, even
 #'   when that chunk is replayed from the cache. `1` draws them after every chunk.
@@ -228,8 +257,9 @@ DEoptimIterative <- function(fn, lower, upper, control, ...,
                               # formulaToFit, covMinMax, tests, maxFireSpread, mutuallyExclusive,
                               # doObjFunAssertions, Nreps, objFunCoresInternal, thresh, rep,
                               .plots, figurePath, cachePath, runName = 1, .verbose = TRUE,
-                              plotEvery = 25L, progressFile = NULL) {
+                              plotEvery = 25L, progressFile = NULL, convergence = NULL) {
   DE <- list()
+  convergence <- deoptimConvergence(convergence)
   progressFile <- .progressStart(progressFile, figurePath, runName)
   ranEvaluations <- list()   # evaluations computed in this call, not replayed from the cache
   ## Progress figures are drawn by the master while every worker waits: 8.3 s of each 53 s generation
@@ -447,7 +477,9 @@ DEoptimIterative <- function(fn, lower, upper, control, ...,
     ## the slope of a line through `bestvalit` (a step function: it could never fire) nor "no new best
     ## for 200 generations" (a lucky record restarts it) answers that.
     popvalsAll <- lapply(DE, function(x) x$member$popval)
-    converged <- .deoptimPopulationConverged(popvalsAll, chunkEnds[seq_along(DE)])
+    converged <- .deoptimPopulationConverged(popvalsAll, chunkEnds[seq_along(DE)], window = convergence$window,
+                                             minGenerations = convergence$minGenerations,
+                                             seMultiplier = convergence$se, sdChange = convergence$sdChange)
     ## Plot chunks computed in this session, not ones replayed from the cache, when each chunk (`iterStep`
     ## generations) finishes. Plotting used to require reproducible::isUpdated(), which is
     ## FALSE whenever nested Cache() is skipped (spades.useCache = "eventsOnly"), so no progress plots
@@ -470,7 +502,8 @@ DEoptimIterative <- function(fn, lower, upper, control, ...,
       texts <- c("objFun/", "lines_mean_AllPoints/", "lines_mean/", "lines_dif/", "lines_variance/", "hists/")
       withCallingHandlers({
         SpaDES.core::Plots(ggPlotFnPopulation(.populationByGeneration(popvalsAll, chunkEnds[seq_along(DE)]),
-                                              .populationConvergenceStats(popvalsAll, chunkEnds[seq_along(DE)])),
+                                              .populationConvergenceStats(popvalsAll, chunkEnds[seq_along(DE)], convergence$window),
+                                              convergence),
               types = .plots,
               filename = ggDEoptimFilename(figurePath, dots$rep, subfolder = "", text = texts[1]))
         SpaDES.core::Plots(dfForGGplotAllPoints, ggPlotFnMeansAllPoints, types = .plots,
@@ -502,10 +535,10 @@ DEoptimIterative <- function(fn, lower, upper, control, ...,
     # indistinguishable from a crash in the log
     if (converged) {
       message(cli::col_green(
-        "Converged: over the last ", getOption("clusters.deoptimConvergenceWindow", 300L),
+        "Converged: over the last ", convergence$window,
         " generations the population median improved by less than ",
-        getOption("clusters.deoptimConvergenceSE", 1), " standard error(s) and its spread changed by less than ",
-        100 * getOption("clusters.deoptimConvergenceSDChange", 0.1), "% (", nGenerations,
+        convergence$se, " standard error(s) and its spread changed by less than ",
+        100 * convergence$sdChange, "% (", nGenerations,
         " run); stopping before itermax"))
       break
     }
@@ -555,10 +588,10 @@ DEoptimIterative <- function(fn, lower, upper, control, ...,
 #' @keywords internal
 #' @noRd
 .deoptimPopulationConverged <- function(popvals, gens,
-                                        window = getOption("clusters.deoptimConvergenceWindow", 300L),
-                                        minGenerations = getOption("clusters.deoptimMinGenerations", 350L),
-                                        seMultiplier = getOption("clusters.deoptimConvergenceSE", 1),
-                                        sdChange = getOption("clusters.deoptimConvergenceSDChange", 0.1)) {
+                                        window = .clustersOption("deoptimConvergenceWindow"),
+                                        minGenerations = .clustersOption("deoptimMinGenerations"),
+                                        seMultiplier = .clustersOption("deoptimConvergenceSE"),
+                                        sdChange = .clustersOption("deoptimConvergenceSDChange")) {
   if (!length(popvals)) return(FALSE)
   if (gens[length(popvals)] <= minGenerations) return(FALSE)
   st <- .populationConvergenceStats(popvals, gens, window)
@@ -571,7 +604,7 @@ DEoptimIterative <- function(fn, lower, upper, control, ...,
 ## member with a lucky record moves the SD by itself, and would hold open a population that has otherwise
 ## stopped). NULL with fewer than four usable values in either population, or none `window` back.
 .populationConvergenceStats <- function(popvals, gens,
-                                        window = getOption("clusters.deoptimConvergenceWindow", 300L)) {
+                                        window = .clustersOption("deoptimConvergenceWindow")) {
   if (!length(popvals)) return(NULL)
   now <- length(popvals)
   ref <- which(gens <= gens[now] - window)
@@ -731,7 +764,7 @@ termsInDEoptim <- function(fireSense_spreadFormula, thresh, numParams) {
 ## The objective-function figure: the population's best, 10th percentile and median by generation, scaled
 ## to the generations after the first tenth (the first ones are far above the rest), with what the early
 ## stop sees in the subtitle (2026-10-02, replacing bestvalit with a smoother and 200-generation slopes)
-ggPlotFnPopulation <- function(pop, stats = NULL) {
+ggPlotFnPopulation <- function(pop, stats = NULL, convergence = deoptimConvergence()) {
   long <- rbind(data.frame(gen = pop$gen, value = pop$best, line = "best"),
                 data.frame(gen = pop$gen, value = pop$q10, line = "10th percentile"),
                 data.frame(gen = pop$gen, value = pop$median, line = "median"))
@@ -745,8 +778,8 @@ ggPlotFnPopulation <- function(pop, stats = NULL) {
   } else {
     sprintf(paste0("Over the last %d generations: median improved %.2f SE (stops below %s),\n",
                    "spread changed %.0f%% (stops below %.0f%%)"),
-            as.integer(stats$window), stats$medianDropSE, getOption("clusters.deoptimConvergenceSE", 1),
-            100 * stats$spreadChange, 100 * getOption("clusters.deoptimConvergenceSDChange", 0.1))
+            as.integer(stats$window), stats$medianDropSE, convergence$se,
+            100 * stats$spreadChange, 100 * convergence$sdChange)
   }
   ggplot(long, aes(.data$gen, .data$value, colour = .data$line, linetype = .data$line)) +
     geom_line(linewidth = 0.7) +

R/optionDefaults.R

@@ -3,7 +3,11 @@
 .optionDefaults <- list(
   deoptimRescoreEvery = 10L,   # re-score the DEoptim population every k generations; 0 never
   onBadHost = "drop",          # a host failing verification is dropped; "stop" kills the job
-  waitForCores = 8 * 3600      # seconds to wait for cores held by other live builds; 0 no waiting
+  waitForCores = 8 * 3600,     # seconds to wait for cores held by other live builds; 0 no waiting
+  deoptimConvergenceWindow = 300L,   # DEoptim early stop: generations over which the median must stop improving
+  deoptimMinGenerations = 350L,      # never stop early before this many generations
+  deoptimConvergenceSE = 1,          # improvement allowed, in standard errors of the median
+  deoptimConvergenceSDChange = 0.1   # change in spread (MAD) allowed, as a fraction of the earlier spread
 )
 
 .clustersOption <- function(name) getOption(paste0("clusters.", name), .optionDefaults[[name]])

tests/testthat/test-DEoptimConvergenceArg.R

@@ -0,0 +1,49 @@
+## The early-stop settings of DEoptimIterative() are an argument, so a caller can put them in its own
+## cache key. They are NOT in the per-chunk cache keys: a fit that stopped early under a lax rule
+## resumes from its cached generations, and continues, when rerun with a stricter rule.
+
+skip_if_not_installed("DEoptim")
+
+test_that("deoptimConvergence(): argument beats option beats default", {
+  withr::local_options(clusters.deoptimConvergenceWindow = NULL, clusters.deoptimMinGenerations = NULL,
+                       clusters.deoptimConvergenceSE = NULL, clusters.deoptimConvergenceSDChange = NULL)
+  expect_identical(deoptimConvergence(),
+                   list(window = 300L, minGenerations = 350L, se = 1, sdChange = 0.1))
+  withr::local_options(clusters.deoptimMinGenerations = 500L, clusters.deoptimConvergenceSE = 2)
+  expect_identical(deoptimConvergence(),
+                   list(window = 300L, minGenerations = 500L, se = 2, sdChange = 0.1))
+  expect_identical(deoptimConvergence(list(minGenerations = 700L, sdChange = 0.5)),
+                   list(window = 300L, minGenerations = 700L, se = 2, sdChange = 0.5))
+  expect_error(deoptimConvergence(list(bogus = 1)), "bogus")
+})
+
+test_that("a fit stopped early resumes from its cached generations when rerun with a stricter rule", {
+  lower <- c(a = 0, b = 0); upper <- c(a = 1, b = 1)
+  calls <- new.env(); calls$n <- 0L
+  fn <- function(par) { calls$n <- calls$n + 1L; sum((par - 0.3)^2) }
+  ## lax rule: stop as soon as past minGenerations (the improvement and spread limits are huge)
+  rule <- function(minGenerations) list(window = 2L, minGenerations = minGenerations, se = 1e9, sdChange = 1e9)
+  fit <- function(cachePath, minGenerations) {
+    calls$n <- 0L
+    set.seed(1)
+    withr::local_options(reproducible.cachePath = cachePath, reproducible.useCache = FALSE,
+                         clusters.cacheDEoptimIterations = TRUE, clusters.deoptimRescoreEvery = 0L)
+    DE <- suppressMessages(suppressWarnings(
+      DEoptimIterative(fn, lower = lower, upper = upper,
+                       control = list(NP = 8L, strategy = 2L, itermax = 30, trace = FALSE),
+                       iterStep = 1L, figurePath = FALSE, progressFile = FALSE, .plots = NULL,
+                       cachePath = cachePath, runName = "resume", .verbose = -1,
+                       convergence = rule(minGenerations))))
+    list(DE = DE, calls = calls$n)
+  }
+  cp <- withr::local_tempdir()
+  lax <- fit(cp, minGenerations = 4L)
+  expect_lt(length(lax$DE), 30)
+  strict <- fit(cp, minGenerations = 8L)                            # same cache: resume
+  fresh <- fit(withr::local_tempdir(), minGenerations = 8L)         # the stricter fit with no cache
+  expect_gt(length(strict$DE), length(lax$DE))                      # it continued ...
+  expect_identical(length(strict$DE), length(fresh$DE))
+  ## ... evaluating only the new generations: NP = 8 objective calls each, where the cache-less fit needs all
+  expect_identical(strict$calls, 8L * (length(strict$DE) - length(lax$DE)))
+  expect_lt(strict$calls, fresh$calls)
+})