diff --git a/NAMESPACE b/NAMESPACE index eca1187..c9c5b37 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,6 +9,7 @@ export(DEoptimIterative2) export(DEoptimProgress) export(clusterSetup) export(currentCluster) +export(deoptimConvergence) export(dirNew) export(freeCoresLessReserved) export(getHostCombination) diff --git a/NEWS.md b/NEWS.md index 88a55a8..4dd7269 100644 --- a/NEWS.md +++ b/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"`, diff --git a/R/DEoptim.R b/R/DEoptim.R index a8c4495..b2c956a 100644 --- a/R/DEoptim.R +++ b/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_.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) + diff --git a/R/optionDefaults.R b/R/optionDefaults.R index 35f100c..b1c19e5 100644 --- a/R/optionDefaults.R +++ b/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]]) diff --git a/man/DEoptimIterative.Rd b/man/DEoptimIterative.Rd index 0910bc2..367aa45 100644 --- a/man/DEoptimIterative.Rd +++ b/man/DEoptimIterative.Rd @@ -17,7 +17,8 @@ DEoptimIterative( runName = 1, .verbose = TRUE, plotEvery = 25L, - progressFile = NULL + progressFile = NULL, + convergence = NULL ) DEoptimIterative2(...) @@ -53,6 +54,14 @@ for the objective (\code{variable = "objective"}) and one per parameter, and a \ returns. \code{NULL} (the default) writes \verb{DEoptimProgress_.csv} in \code{figurePath}, or in the working directory when \code{figurePath} is \code{FALSE}; \code{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.} + +\item{convergence}{The early-stop settings: a list with any of \code{window} (generations over which the +population median must have stopped improving), \code{minGenerations} (never stop before this many), +\code{se} (the improvement allowed, in standard errors of the median) and \code{sdChange} (the change in spread +allowed, as a fraction of the earlier spread). What is missing comes from +\code{options(clusters.deoptimConvergenceWindow, clusters.deoptimMinGenerations, clusters.deoptimConvergenceSE, clusters.deoptimConvergenceSDChange)}, then the defaults (300, 350, 1, 0.1); see \link{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.} } \value{ A list with one \code{\link[DEoptim:DEoptim]{DEoptim::DEoptim()}} result per chunk run, in order. diff --git a/man/deoptimConvergence.Rd b/man/deoptimConvergence.Rd new file mode 100644 index 0000000..9614c04 --- /dev/null +++ b/man/deoptimConvergence.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/DEoptim.R +\name{deoptimConvergence} +\alias{deoptimConvergence} +\title{The DEoptim early-stop settings, in full} +\usage{ +deoptimConvergence(convergence = NULL) +} +\arguments{ +\item{convergence}{\code{NULL}, or a list with any of \code{window}, \code{minGenerations}, \code{se}, \code{sdChange} +(see \code{\link[=DEoptimIterative]{DEoptimIterative()}}).} +} +\value{ +A list with \code{window}, \code{minGenerations}, \code{se} and \code{sdChange}. +} +\description{ +Resolves the settings that decide when \code{\link[=DEoptimIterative]{DEoptimIterative()}} stops a fit that has stopped improving: +an element of \code{convergence} wins, else the matching \verb{clusters.*} option, else the default. +A caller that caches a whole fit can put the result in its cache key. +} diff --git a/tests/testthat/test-DEoptimConvergenceArg.R b/tests/testthat/test-DEoptimConvergenceArg.R new file mode 100644 index 0000000..c0053d1 --- /dev/null +++ b/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) +})