diff --git a/COPYING b/COPYING deleted file mode 100644 index 1beb83b..0000000 --- a/COPYING +++ /dev/null @@ -1,29 +0,0 @@ -COPYRIGHT AND PERMISSION NOTICE - -Copyright (c) 2005 Charles J. Geyer -Copyright (c) 2026 Matthew Fidler - -All rights reserved. - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, and/or sell copies of the -Software, and to permit persons to whom the Software is furnished to do so, -provided that the above copyright notice(s) and this permission notice appear -in all copies of the Software and that both the above copyright notice(s) and -this permission notice appear in supporting documentation. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF THIRD PARTY RIGHTS. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE -BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES, -OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, -WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, -ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - -Except as contained in this notice, the name of a copyright holder shall -not be used in advertising or otherwise to promote the sale, use or other -dealings in this Software without prior written authorization of the copyright -holder. diff --git a/DESCRIPTION b/DESCRIPTION index 1df227d..38be22a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,21 +1,42 @@ Package: RcppTrust Type: Package -Title: Thread-Safe C++ Port of the 'trust' Trust Region Optimizer -Version: 0.1.0 +Title: Thread-Safe C++ Trust Region Optimizers +Version: 0.2.0 Authors@R: c( - person(given = c("Charles", "J."), family = "Geyer", role = "aut", + person(given = c("Charles", "J."), family = "Geyer", role = c("aut", "cph"), email = "geyer@umn.edu", comment = c(ORCID = "0000-0003-1471-1703")), person(given = "Matthew", family = "Fidler", role = c("aut", "cre"), - email = "matthew.fidler@gmail.com", comment = c(ORCID = "0000-0001-8538-6691"))) -Description: Does local optimization using two derivatives and trust - regions. Guaranteed to converge to a local minimum of the objective - function. This is a thread-safe C++ port of the algorithm in the - 'trust' package by Charles J. Geyer, exposed both as a drop-in R - function and as a C-callable, thread-safe entry point (with function + email = "matthew.fidler@gmail.com", comment = c(ORCID = "0000-0001-8538-6691")), + person(given = c("Michael", "J.", "D."), family = "Powell", role = "aut", + comment = "BOBYQA and NEWUOA algorithms and original Fortran 77 code"), + person(given = "Douglas", family = "Bates", role = c("ctb", "cph"), + comment = "minqa"), + person(given = c("Katharine", "M."), family = "Mullen", role = c("ctb", "cph"), + comment = "minqa"), + person(given = c("John", "C."), family = "Nash", role = c("ctb", "cph"), + comment = "minqa"), + person(given = "Ravi", family = "Varadhan", role = c("ctb", "cph"), + comment = "minqa"), + person(given = "Johan", family = "Larsson", role = c("ctb", "cph"), + comment = "basin trust-region / Steihaug implementation")) +Description: Thread-safe C++ trust region optimizers, each exposed + both as an R function and as a C-callable entry point (with function pointers registered for other packages to call without linking - against this package's shared library) so it can be used from - parallel C++ code such as in 'nlmixr2est'. -License: MIT + file LICENSE + against this package's shared library) so they can be used from + parallel C++ code such as in 'nlmixr2est'. Includes a port of the + two-derivative trust region algorithm in the 'trust' package by + Charles J. Geyer; a port of the Steihaug truncated conjugate-gradient + trust region method from the 'basin' Rust crate (Steihaug (1983) + ); and ports of M. J. D. Powell's + derivative-free BOBYQA (Powell (2009), Report DAMTP 2009/NA06) and + NEWUOA (Powell (2006) ) Fortran 77 + code , + as modified and distributed in the 'minqa' package, whose R + interface is reproduced. +License: GPL-2 +Copyright: See inst/COPYRIGHTS for the sources, copyright holders and + licenses of code ported from 'trust', 'basin', 'minqa' and Powell's + Fortran. URL: https://github.com/nlmixr2/RcppTrust/, https://nlmixr2.github.io/RcppTrust/, http://www.stat.umn.edu/geyer/trust/ @@ -23,7 +44,7 @@ Encoding: UTF-8 Depends: R (>= 4.2.0) Imports: Rcpp LinkingTo: Rcpp, RcppArmadillo, BH -Suggests: testthat (>= 3.0.0), stats, knitr, rmarkdown, trust, +Suggests: testthat (>= 3.0.0), stats, knitr, rmarkdown, trust, minqa, microbenchmark Config/testthat/edition: 3 SystemRequirements: C++17 diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 6cb5c49..0000000 --- a/LICENSE +++ /dev/null @@ -1,5 +0,0 @@ -YEAR: 2005, 2008 (original R algorithm and code, trust package) -COPYRIGHT HOLDER: Charles J. Geyer - -YEAR: 2026 (C++ port) -COPYRIGHT HOLDER: Matthew Fidler diff --git a/NAMESPACE b/NAMESPACE index 3557dd1..204090a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,4 +1,10 @@ -useDynLib(RcppTrust, .registration = TRUE) -importFrom(Rcpp, sourceCpp) -export(trust) +# Generated by roxygen2: do not edit by hand + +S3method(print,minqa) export(.RcppTrustPtr) +export(bobyqa) +export(newuoa) +export(steihaug) +export(trust) +importFrom(Rcpp,sourceCpp) +useDynLib(RcppTrust, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 0000000..ad0b459 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,29 @@ +# RcppTrust 0.2.0 + +* The package license is now GPL-2, because the BOBYQA/NEWUOA ports and + their R wrappers derive from the GPL-2 package 'minqa'. + +* M. J. D. Powell is added as an author for the BOBYQA/NEWUOA algorithms + and original Fortran code; sources and notices for all ported code + ('trust', 'basin', 'minqa', Powell's Fortran) are listed in `inst/COPYRIGHTS`. + +* New `steihaug()`: a Steihaug truncated conjugate-gradient trust-region + Newton minimizer ported from the Rust crate 'basin', with exact-Hessian + and matrix-free (Hessian-vector product) modes, and a thread-safe C + entry point `steihaug_solve_c()`. + +* New `bobyqa()` and `newuoa()`: thread-safe C++ ports of Powell's + derivative-free BOBYQA and NEWUOA from 'minqa' 1.2.8, drop-in + replacements for `minqa::bobyqa()`/`minqa::newuoa()`, with C entry points + `bobyqa_solve_c()`/`newuoa_solve_c()`. BOBYQA's `RESCUE` step evaluates + the intended point rather than minqa's uninitialized one. + +* `.RcppTrustPtr()` and `RcppTrust.h` gain appended slots for the new C + entry points and their result-free functions. + +* New vignette `vignette("trust-region-methods")`. + + +# RcppTrust 0.1.0 + +* Original release of RcppTRust only containing the port of trust::trust() diff --git a/R/RcppExports.R b/R/RcppExports.R index e1983ea..fd86517 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,6 +1,26 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 +minqa_bobyqa_r <- function(par, lower, upper, ctrl, fn) { + .Call(`_RcppTrust_minqa_bobyqa_r`, par, lower, upper, ctrl, fn) +} + +minqa_newuoa_r <- function(par, ctrl, fn) { + .Call(`_RcppTrust_minqa_newuoa_r`, par, ctrl, fn) +} + +solver_openmp_stress_test <- function(solver, n, nStarts, nThreadsRequested) { + .Call(`_RcppTrust_solver_openmp_stress_test`, solver, n, nStarts, nThreadsRequested) +} + +solver_c_api_edge_test <- function() { + .Call(`_RcppTrust_solver_c_api_edge_test`) +} + +steihaug_solve_r <- function(par, fn, gr, hess, hessvec, control) { + .Call(`_RcppTrust_steihaug_solve_r`, par, fn, gr, hess, hessvec, control) +} + trust_solve_r <- function(objfun1, tryEval, parinit, rinit, rmax, parscale, iterlim, fterm, mterm, minimize, blather) { .Call(`_RcppTrust_trust_solve_r`, objfun1, tryEval, parinit, rinit, rmax, parscale, iterlim, fterm, mterm, minimize, blather) } diff --git a/R/c-api.R b/R/c-api.R new file mode 100644 index 0000000..9519aaa --- /dev/null +++ b/R/c-api.R @@ -0,0 +1,28 @@ +#' Thread-safe C interfaces +#' +#' Every optimizer in this package is implemented as a C-callable core with +#' no R API calls and no global state, so each can run concurrently from +#' OpenMP/parallel C++ code (e.g. as an inner or outer optimizer in +#' \code{nlmixr2est}). The R functions [trust()], [steihaug()], [bobyqa()] +#' and [newuoa()] are thin wrappers around these same cores. +#' +#' \tabular{lll}{ +#' \strong{Solver} \tab \strong{Header} \tab \strong{Entry point / free} \cr +#' trust \tab \code{trust_types.h} \tab \code{trust_solve_c} / \code{trust_result_free} \cr +#' BOBYQA \tab \code{minqa_types.h} \tab \code{bobyqa_solve_c} / \code{minqa_result_free} \cr +#' NEWUOA \tab \code{minqa_types.h} \tab \code{newuoa_solve_c} / \code{minqa_result_free} \cr +#' Steihaug \tab \code{steihaug_types.h} \tab \code{steihaug_solve_c} / \code{steihaug_result_free} \cr +#' } +#' +#' A consuming package adds \code{RcppTrust} to \code{LinkingTo} and +#' \code{Imports}, includes \code{RcppTrust.h}, and resolves the pointers at +#' load time from [.RcppTrustPtr()] (slots, in order: \code{trust_solve_c}, +#' \code{trust_result_free}, \code{bobyqa_solve_c}, \code{newuoa_solve_c}, +#' \code{minqa_result_free}, \code{steihaug_solve_c}, +#' \code{steihaug_result_free}). See \code{vignette("RcppTrust")} for a +#' worked example. +#' +#' @name minqa_c_api +#' @aliases steihaug_c_api trust_c_api +#' @keywords internal +NULL diff --git a/R/minqa.R b/R/minqa.R new file mode 100644 index 0000000..e0cf70f --- /dev/null +++ b/R/minqa.R @@ -0,0 +1,232 @@ +# R shims for the thread-safe C++ ports of Powell's BOBYQA and NEWUOA. +# These reproduce minqa 1.2.8's R/minqa.R argument handling, +# defaults, warnings and return values line for line; only the .Call +# target differs (the ported solvers in src/minqa_*.cpp instead of the +# Fortran). + +# minqa's commonArgs(): establishes control defaults, assigning `n` and an +# attribute-free `par` into the caller's frame exactly as minqa does. +.minqaCommonArgs <- function(par, fn, ctrl, rho) { + rho$n <- n <- length(rho$par <- as.double(par)) + stopifnot(all(is.finite(par)), + is.function(fn), + length(formals(fn)) >= 1) + cc <- do.call(function(npt = min(n+2L, 2L * n), rhobeg = NA, + rhoend = NA, iprint = 0L, maxfun=10000L, + obstop=TRUE, force.start=FALSE,...) { + if (length(list(...))>0) warning("unused control arguments ignored") + list(npt = npt, rhobeg = rhobeg, rhoend = rhoend, + iprint = iprint, maxfun = maxfun, obstop = obstop, + force.start = force.start) + }, ctrl) + + ctrl <- new.env(parent = emptyenv()) + lapply(names(cc), function(nm) assign(nm, cc[[nm]], envir = ctrl)) + + ctrl$npt <- as.integer(max(n + 2L, min(ctrl$npt, ((n+1L)*(n+2L)) %/% 2L))) + if (ctrl$npt > (2 * n + 1)) + warning("Setting npt > 2 * length(par) + 1 is not recommended.") + + if (is.na(ctrl$rhobeg)) + ctrl$rhobeg <- min(0.95, 0.2 * max(abs(par))) + if (is.na(ctrl$rhoend)) ctrl$rhoend <- 1.0e-6 * ctrl$rhobeg + stopifnot(0 < ctrl$rhoend, ctrl$rhoend <= ctrl$rhobeg) + + if (ctrl$maxfun < 10 * n^2) + warning("maxfun < 10 * length(par)^2 is not recommended.") + ctrl +} + +#' Nonlinear optimization with box constraints (BOBYQA) +#' +#' Thread-safe C++ port of \code{minqa::bobyqa()}: minimizes a function of +#' many variables subject to box constraints by a trust region method that +#' forms quadratic models by interpolation, using M. J. D. Powell's BOBYQA +#' algorithm. Arguments, defaults, and return value are those of +#' \code{minqa::bobyqa()}; see its documentation for details. +#' +#' @param par numeric vector of starting parameters. +#' @param fn function to be minimized; its first argument must be the +#' parameter vector and it must return a scalar numeric value. +#' @param lower,upper numeric vectors of lower and upper bounds (recycled +#' when of length 1). +#' @param control a list of control settings: \code{npt}, \code{rhobeg}, +#' \code{rhoend}, \code{iprint}, \code{maxfun}, \code{obstop} and +#' \code{force.start}, as in \code{minqa::bobyqa()}. +#' @param ... further arguments passed to \code{fn}. +#' +#' @return A list of class \code{c("bobyqa", "minqa")} with components +#' \code{par}, \code{fval}, \code{feval}, \code{ierr} and \code{msg}. +#' @references M. J. D. Powell (2009), "The BOBYQA algorithm for bound +#' constrained optimization without derivatives", Report No. DAMTP +#' 2009/NA06, Centre for Mathematical Sciences, University of Cambridge. +#' @source M. J. D. Powell's original Fortran 77 BOBYQA code, archived at +#' \url{https://github.com/libprima/prima/tree/main/fortran/original/bobyqa}; +#' R interface following the \pkg{minqa} package. +#' @seealso [newuoa()], and [minqa_c_api] for calling the +#' solvers from parallel C/C++ code. +#' @examples +#' fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +#' bobyqa(c(1, 2), fr, lower = c(0, 0), upper = c(4, 4)) +#' @export +bobyqa <- function(par, fn, lower = -Inf, upper = Inf, control = list(), ...) +{ + nn <- names(par) + ctrl <- .minqaCommonArgs(par, fn, control, environment()) + n <- length(par) + fn1 <- function(x) { + names(x) <- nn + fn(x, ...) + } + checkObj <- fn1(par) + if(length(checkObj) > 1 || !is.numeric(checkObj)) + stop("Objective function must return a single numeric value.") + lower <- as.double(lower); upper <- as.double(upper) + if (length(lower) == 1) lower <- rep(lower, n) + if (length(upper) == 1) upper <- rep(upper, n) + stopifnot(length(lower) == n, length(upper) == n, all(lower < upper)) + if (any(par < lower | par > upper)) { + if (ctrl$obstop) + stop("Starting values violate bounds") + else { + # kept verbatim from minqa (including its pmax(par, upper)) + par <- pmax(lower, pmax(par, upper)) + warning("Some parameters adjusted to nearest bound") + } + } + rng <- upper - lower + + if (any(rng < 2 * ctrl$rhobeg)) { + warning("All upper - lower must be >= 2*rhobeg. Changing rhobeg") + ctrl$rhobeg <- 0.2 * min(rng) + } + + verb <- 1 < (ctrl$iprint <- as.integer(ctrl$iprint)) + if (all(is.finite(upper)) && all(is.finite(lower)) && + all(par >= lower) && all(par <= upper) ) { + if (verb) cat("ctrl$force.start = ", ctrl$force.start,"\n") + if (!ctrl$force.start) { + i <- rng < ctrl$rhobeg + if (any(i)) { + par[i] <- lower[i] + ctrl$rhobeg + warning("Some parameters adjusted away from lower bound") + } + i <- rng < ctrl$rhobeg + if (any(i)) { + par[i] <- upper[i] - ctrl$rhobeg + warning("Some parameters adjusted away from upper bound") + } + } + } + if (verb) { + cat("npt =", ctrl$npt, ", n = ",n,"\n") + cat("rhobeg = ", ctrl$rhobeg,", rhoend = ", ctrl$rhoend, "\n") + } + if(ctrl$iprint > 0) + cat("start par. = ", par, "fn = ", checkObj, "\n") + + retlst <- .Call(`_RcppTrust_minqa_bobyqa_r`, as.double(par), lower, upper, + ctrl, fn1) + if (retlst$ierr > 0){ + if (retlst$ierr == 10) { + retlst$ierr<-2 + retlst$msg<-"bobyqa -- NPT is not in the required interval" + } else if (retlst$ierr == 320) { + retlst$ierr<-5 + retlst$msg<-"bobyqa detected too much cancellation in denominator" + } else if (retlst$ierr == 390) { + retlst$ierr<-1 + retlst$msg<-"bobyqa -- maximum number of function evaluations exceeded" + } else if (retlst$ierr == 430) { + retlst$ierr<-3 + retlst$msg<-"bobyqa -- a trust region step failed to reduce q" + } else if (retlst$ierr == 20) { + retlst$ierr<-4 + retlst$msg<-"bobyqa -- one of the box constraint ranges is too small (< 2*RHOBEG)" + } + } else { + retlst$msg<-"Normal exit from bobyqa" + } + retlst +} + +#' Unconstrained derivative-free optimization (NEWUOA) +#' +#' Thread-safe C++ port of \code{minqa::newuoa()}: minimizes a function of +#' many variables by a trust region method that forms quadratic models by +#' interpolation, using M. J. D. Powell's NEWUOA algorithm. +#' +#' @inheritParams bobyqa +#' @param control a list of control settings: \code{npt}, \code{rhobeg}, +#' \code{rhoend}, \code{iprint} and \code{maxfun}, as in +#' \code{minqa::newuoa()}. +#' +#' @return A list of class \code{c("newuoa", "minqa")} with components +#' \code{par}, \code{fval}, \code{feval}, \code{ierr} and \code{msg}. +#' @references M. J. D. Powell (2006), "The NEWUOA software for +#' unconstrained optimization without derivatives", in Large-Scale +#' Nonlinear Optimization, Springer, 255-297. +#' \doi{10.1007/0-387-30065-1_16} +#' @source M. J. D. Powell's original Fortran 77 NEWUOA code, archived at +#' \url{https://github.com/libprima/prima/tree/main/fortran/original/newuoa}; +#' R interface following the \pkg{minqa} package. +#' @seealso [bobyqa()], [minqa_c_api] +#' @examples +#' fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +#' newuoa(c(1, 2), fr) +#' @export +newuoa <- function(par, fn, control = list(), ...) +{ + nn <- names(par) + ctrl <- .minqaCommonArgs(par + 0, fn, control, environment()) + n <- length(par) + fn1 <- function(x) { + names(x) <- nn + fn(x, ...) + } + checkObj <- fn1(par) + if(length(checkObj) > 1 || !is.numeric(checkObj)) + stop("Objective function must return a single numeric value.") + verb <- 1 < (ctrl$iprint <- as.integer(ctrl$iprint)) + if (verb) { + cat("npt =", ctrl$npt, ", n = ",n,"\n") + cat("rhobeg = ", ctrl$rhobeg,", rhoend = ", ctrl$rhoend, "\n") + } + if(ctrl$iprint > 0) + cat("start par. = ", par, "fn = ", checkObj, "\n") + + retlst <- .Call(`_RcppTrust_minqa_newuoa_r`, as.double(par), ctrl, fn1) + if (retlst$ierr > 0){ + if (retlst$ierr == 10) { + retlst$ierr<-2 + retlst$msg<-"newuoa -- NPT is not in the required interval" + } else if (retlst$ierr == 320) { + retlst$ierr<-5 + retlst$msg<-"newuoa detected too much cancellation in denominator" + } else if (retlst$ierr == 390) { + retlst$ierr<-1 + retlst$msg<-"newuoa -- maximum number of function evaluations exceeded" + } else if (retlst$ierr == 3701) { + retlst$ierr<-3 + retlst$msg<-"newuoa -- a trust region step failed to reduce q" + } + } else { + retlst$msg<-"Normal exit from newuoa" + } + retlst +} + +#' Print method for minqa objects +#' +#' @param x an object inheriting from class \code{minqa}. +#' @param digits unused; kept for compatibility with \code{minqa}. +#' @param ... unused. +#' @return \code{invisible(x)} +#' @export +print.minqa <- function(x, digits = max(3, getOption("digits") - 3), ...) +{ + cat("parameter estimates:", toString(x$par), "\n") + cat("objective:", toString(x$fval), "\n") + cat("number of function evaluations:", toString(x$feval), "\n") + invisible(x) +} diff --git a/R/steihaug.R b/R/steihaug.R new file mode 100644 index 0000000..b8063a7 --- /dev/null +++ b/R/steihaug.R @@ -0,0 +1,152 @@ +#' Steihaug truncated-CG trust-region Newton minimization +#' +#' Thread-safe C++ port of the trust-region Newton minimizer with the +#' Steihaug truncated conjugate-gradient subproblem from the Rust crate +#' \href{https://github.com/jolars/basin}{basin} (\code{TrustRegion} with +#' its default \code{Steihaug} subproblem, driven by basin's executor). Each +#' iteration approximately minimizes the quadratic model +#' \eqn{m(p) = f + g^T p + \frac{1}{2} p^T B p}{m(p) = f + g'p + p'Bp/2} +#' over \eqn{\|p\| \le \Delta}{||p|| <= Delta} by conjugate gradients, +#' stopping at the boundary on negative curvature. Unlike [trust()] it never +#' factorizes the Hessian, and with \code{hessvec} it never forms it at all +#' (basin's matrix-free mode). +#' +#' Evaluation pattern (identical to basin): \code{fn} and \code{gr} once at +#' the start; \code{hess} once per outer iteration (exact mode) or +#' \code{hessvec} once per CG product (matrix-free mode); \code{fn} at each +#' trial point; \code{gr} after each accepted step. \code{fn} may return +#' \code{Inf} (or \code{NaN}) at a trial point to reject it. +#' +#' @param par numeric vector of starting parameters. +#' @param fn objective function of the parameter vector returning a scalar. +#' @param gr gradient function returning a numeric vector of length +#' \code{length(par)}. +#' @param hess Hessian function returning a symmetric +#' \code{length(par)} by \code{length(par)} matrix. May be \code{NULL} when +#' \code{hessvec} is supplied. +#' @param hessvec optional Hessian-vector product \code{function(x, v)} +#' returning \eqn{H(x) v}{H(x) \%*\% v}. When supplied, the matrix-free mode +#' is used and \code{hess} is never called. +#' @param control a list of control settings (defaults in brackets; a +#' \code{NULL} tolerance or budget is disabled): +#' \describe{ +#' \item{rinit}{initial trust region radius [1]} +#' \item{rmax}{maximum trust region radius [100]} +#' \item{eta}{step acceptance threshold on the reduction ratio, in +#' \eqn{[0, 1/4)} [0.125]} +#' \item{maxInner}{radius reductions (re-solves) per outer iteration [10]} +#' \item{cgMaxit}{CG iteration cap per subproblem; 0 means +#' \code{length(par)} [0]} +#' \item{kappa, theta}{CG forcing rule: stop when +#' \eqn{\|r\| < \min(\kappa, \|g\|^\theta)\|g\|}{||r|| < min(kappa, ||g||^theta) ||g||} +#' [0.5, 0.5]} +#' \item{maxit}{maximum outer iterations [100]} +#' \item{maxCostEvals, maxGradEvals}{evaluation budgets [NULL]} +#' \item{targetCost}{stop once the objective is at or below this [NULL]} +#' \item{gradTol}{absolute gradient tolerance on +#' \eqn{\|g\|_2}{||g||_2} [1e-8]} +#' \item{relGradTol}{gradient tolerance relative to the initial gradient +#' norm [NULL]} +#' \item{stepTol, relStepTol}{absolute / relative step tolerance [NULL]} +#' \item{costTol, relCostTol}{absolute / relative objective change +#' tolerance [NULL]} +#' \item{trace}{if \code{TRUE}, return a per-attempt trace [FALSE]} +#' } +#' @param ... further arguments passed to \code{fn}, \code{gr}, \code{hess} +#' and \code{hessvec}. +#' +#' @return A list with components \code{par}, \code{value}, \code{gradient}, +#' \code{iterations}, \code{converged}, \code{status} (integer), +#' \code{message} (the basin termination reason, e.g. +#' \code{"GradientTolerance"}, \code{"MaxIter"}), \code{radius} (final +#' trust radius), \code{counts} (evaluations of \code{fn}, \code{gr}, +#' \code{hess}, \code{hessvec}), and, when \code{control$trace} is +#' \code{TRUE}, \code{trace}, a data frame with one row per subproblem +#' attempt. +#' @references Steihaug, T. (1983). The conjugate gradient method and trust +#' regions in large scale optimization. SIAM Journal on Numerical Analysis, +#' 20(3), 626-637. +#' +#' Nocedal, J. and Wright, S. J. (2006). Numerical Optimization (2nd ed.), +#' Algorithms 4.1 and 7.2. Springer. +#' @seealso [trust()], [bobyqa()], [newuoa()] +#' @examples +#' fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +#' grr <- function(x) c(-400 * x[1] * (x[2] - x[1]^2) - 2 * (1 - x[1]), +#' 200 * (x[2] - x[1]^2)) +#' hr <- function(x) matrix(c(1200 * x[1]^2 - 400 * x[2] + 2, -400 * x[1], +#' -400 * x[1], 200), 2, 2) +#' steihaug(c(-1.2, 1), fr, grr, hr) +#' +#' # matrix-free: only Hessian-vector products +#' hv <- function(x, v) drop(hr(x) %*% v) +#' steihaug(c(-1.2, 1), fr, grr, hessvec = hv)$counts +#' @export +steihaug <- function(par, fn, gr, hess = NULL, hessvec = NULL, + control = list(), ...) { + if (!is.numeric(par) || length(par) < 1) stop("par must be a non-empty numeric vector") + if (!all(is.finite(par))) stop("par not all finite") + if (!is.function(fn)) stop("fn must be a function") + if (!is.function(gr)) stop("gr must be a function") + if (is.null(hess) && is.null(hessvec)) + stop("one of 'hess' or 'hessvec' must be supplied") + if (!is.null(hess) && !is.function(hess)) stop("hess must be a function") + if (!is.null(hessvec) && !is.function(hessvec)) + stop("hessvec must be a function") + + ctrl <- list(rinit = 1, rmax = 100, eta = 0.125, maxInner = 10L, + cgMaxit = 0L, kappa = 0.5, theta = 0.5, maxit = 100L, + maxCostEvals = NULL, maxGradEvals = NULL, targetCost = NULL, + gradTol = 1e-8, relGradTol = NULL, stepTol = NULL, + relStepTol = NULL, costTol = NULL, relCostTol = NULL, + trace = FALSE) + if (!is.list(control)) stop("control must be a list") + unused <- setdiff(names(control), names(ctrl)) + if (length(unused)) + warning("unused control arguments ignored: ", + paste(unused, collapse = ", ")) + for (nm in intersect(names(control), names(ctrl))) { + ctrl[nm] <- list(control[[nm]]) + } + + for (nm in c("rinit", "rmax", "eta", "kappa", "theta")) { + if (!is.numeric(ctrl[[nm]]) || length(ctrl[[nm]]) != 1 || + !is.finite(ctrl[[nm]])) + stop("control$", nm, " must be a single finite number") + } + for (nm in c("maxInner", "cgMaxit", "maxit", "maxCostEvals", "maxGradEvals")) { + v <- ctrl[[nm]] + if (is.null(v) && nm %in% c("maxCostEvals", "maxGradEvals")) next + if (!is.numeric(v) || length(v) != 1 || !is.finite(v) || v < 0 || + v > .Machine$integer.max) + stop("control$", nm, " must be a single non-negative finite count") + } + for (nm in c("targetCost", "gradTol", "relGradTol", "stepTol", "relStepTol", + "costTol", "relCostTol")) { + v <- ctrl[[nm]] + if (!is.null(v) && (!is.numeric(v) || length(v) != 1 || !is.finite(v))) + stop("control$", nm, " must be NULL or a single finite number") + } + + nn <- names(par) + dots <- list(...) + wrap1 <- function(f) { + force(f) + function(x) { + names(x) <- nn + do.call(f, c(list(x), dots)) + } + } + hv1 <- NULL + if (!is.null(hessvec)) { + hv1 <- function(x, v) { + names(x) <- nn + do.call(hessvec, c(list(x, v), dots)) + } + } + ret <- .Call(`_RcppTrust_steihaug_solve_r`, as.double(par), wrap1(fn), + wrap1(gr), if (is.null(hess)) NULL else wrap1(hess), hv1, ctrl) + names(ret$par) <- nn + names(ret$gradient) <- nn + ret +} diff --git a/README.Rmd b/README.Rmd index fc83af4..ee80c84 100644 --- a/README.Rmd +++ b/README.Rmd @@ -40,6 +40,19 @@ criteria -- and exposes it three ways: library -- the same pattern `rxode2`/`n1qn1`/`lbfgsb3c` use across the nlmixr2 ecosystem. +It also includes three more trust-region optimizers built the same way, +each with an R function and a thread-safe C entry point: + +| R function | Ported from | Needs | C entry point | +|---|---|---|---| +| `steihaug()` | [basin](https://github.com/jolars/basin) (Rust) | gradient + Hessian or Hessian-vector products | `steihaug_solve_c()` | +| `bobyqa()` | Powell's [BOBYQA Fortran](https://github.com/libprima/prima/tree/main/fortran/original/bobyqa), via [`minqa`](https://cran.r-project.org/package=minqa) | function values only; box bounds | `bobyqa_solve_c()` | +| `newuoa()` | Powell's [NEWUOA Fortran](https://github.com/libprima/prima/tree/main/fortran/original/newuoa), via [`minqa`](https://cran.r-project.org/package=minqa) | function values only | `newuoa_solve_c()` | + +`bobyqa()`/`newuoa()` are drop-in replacements for their `minqa` +counterparts and give bitwise-identical results; `steihaug()` reproduces +basin's iterates bit for bit. See `vignette("trust-region-methods")`. + See `vignette("RcppTrust")` for what's the same as upstream `trust`, what's different, and a worked example of the C interface and the registration pattern. @@ -83,4 +96,10 @@ out[c("value", "argument", "converged", "iterations")] - Charles J. Geyer -- original algorithm and R implementation (`trust`) -- Matthew Fidler -- thread-safe C++ port (`RcppTrust`) +- M. J. D. Powell -- BOBYQA and NEWUOA algorithms and original Fortran 77 + code +- Douglas Bates, Katharine M. Mullen, John C. Nash, Ravi Varadhan -- + `minqa`, the R distribution of Powell's code this port follows +- Johan Larsson and basin contributors -- basin's Steihaug trust-region + implementation +- Matthew Fidler -- thread-safe C++ ports (`RcppTrust`) diff --git a/README.md b/README.md index 39f2d72..dfbd813 100644 --- a/README.md +++ b/README.md @@ -33,6 +33,19 @@ three ways: library – the same pattern `rxode2`/`n1qn1`/`lbfgsb3c` use across the nlmixr2 ecosystem. +It also includes three more trust-region optimizers built the same way, +each with an R function and a thread-safe C entry point: + +| R function | Ported from | Needs | C entry point | +|--------------|---------------------------------------------------------------------------------------------------------------------------------------------------------|-----------------------------------------------|----------------------| +| `steihaug()` | [basin](https://github.com/jolars/basin) (Rust) | gradient + Hessian or Hessian-vector products | `steihaug_solve_c()` | +| `bobyqa()` | Powell’s [BOBYQA Fortran](https://github.com/libprima/prima/tree/main/fortran/original/bobyqa), via [`minqa`](https://cran.r-project.org/package=minqa) | function values only; box bounds | `bobyqa_solve_c()` | +| `newuoa()` | Powell’s [NEWUOA Fortran](https://github.com/libprima/prima/tree/main/fortran/original/newuoa), via [`minqa`](https://cran.r-project.org/package=minqa) | function values only | `newuoa_solve_c()` | + +`bobyqa()`/`newuoa()` are drop-in replacements for their `minqa` +counterparts and give bitwise-identical results; `steihaug()` reproduces +basin’s iterates bit for bit. See `vignette("trust-region-methods")`. + See `vignette("RcppTrust")` for what’s the same as upstream `trust`, what’s different, and a worked example of the C interface and the registration pattern. @@ -86,4 +99,10 @@ out[c("value", "argument", "converged", "iterations")] ## Authors - Charles J. Geyer – original algorithm and R implementation (`trust`) -- Matthew Fidler – thread-safe C++ port (`RcppTrust`) +- M. J. D. Powell – BOBYQA and NEWUOA algorithms and original Fortran 77 + code +- Douglas Bates, Katharine M. Mullen, John C. Nash, Ravi Varadhan – + `minqa`, the R distribution of Powell’s code this port follows +- Johan Larsson and basin contributors – basin’s Steihaug trust-region + implementation +- Matthew Fidler – thread-safe C++ ports (`RcppTrust`) diff --git a/cran-comments.md b/cran-comments.md index 2061b4f..5e8b17b 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -2,4 +2,4 @@ 0 errors | 0 warnings | 1 note -* This is a new release. +* This release adds the Steihaug, BOBYQA and NEWUOA optimizers and changes the license to GPL-2 (see NEWS.md). diff --git a/inst/COPYRIGHTS b/inst/COPYRIGHTS new file mode 100644 index 0000000..7f51fc7 --- /dev/null +++ b/inst/COPYRIGHTS @@ -0,0 +1,87 @@ +RcppTrust is distributed under the GNU General Public License, version 2 +(GPL-2), because its BOBYQA/NEWUOA ports and R wrappers derive from the +GPL-2 package 'minqa'. It includes code ported from the following sources, +whose notices are retained below. + +trust (src/trust_*, R/trust.R) + Ported from the R package 'trust' by Charles J. Geyer, distributed under + the following permissive (X11-style) license: + + COPYRIGHT AND PERMISSION NOTICE + + Copyright (c) 2005 Charles J. Geyer + Copyright (c) 2026 Matthew Fidler + + All rights reserved. + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, and/or sell copies of the + Software, and to permit persons to whom the Software is furnished to do so, + provided that the above copyright notice(s) and this permission notice appear + in all copies of the Software and that both the above copyright notice(s) and + this permission notice appear in supporting documentation. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF THIRD PARTY RIGHTS. + IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE + BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES, + OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, + WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, + ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + + Except as contained in this notice, the name of a copyright holder shall + not be used in advertising or otherwise to promote the sale, use or other + dealings in this Software without prior written authorization of the copyright + holder. + +Steihaug trust region (src/steihaug_core.cpp, inst/include/steihaug_types.h) + Ported from the Rust crate 'basin' (https://github.com/jolars/basin), + commit 86cc0d6: solver/trust_region.rs, solver/trust_region/steihaug.rs + and the executor/convergence machinery. basin is copyright its + contributors and licensed under either of the Apache License, Version 2.0 + or the MIT license, at your option; used here under the MIT license: + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS + OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +BOBYQA and NEWUOA (src/minqa_*.cpp, R/minqa.R, inst/include/minqa_types.h) + Ported from M. J. D. Powell's original Fortran 77 BOBYQA (2009) and + NEWUOA (2004) code, which Powell released without a license. The + unmodified originals are archived at + https://github.com/libprima/prima/tree/main/fortran/original/bobyqa + https://github.com/libprima/prima/tree/main/fortran/original/newuoa + (see also https://www.zhangzk.net/software.html). + + The C++ is translated from the versions of that Fortran modified and + distributed in the R package 'minqa' 1.2.8 (copyright Douglas Bates, + Katharine M. Mullen, John C. Nash, Ravi Varadhan; GPL-2), keeping its + error-code and printing edits, and R/minqa.R and the print glue in + src/minqa_common.h follow minqa's R/minqa.R and src/minqa.cpp. + + References: + M. J. D. Powell (2006), "The NEWUOA software for unconstrained + optimization without derivatives", in G. Di Pillo and M. Roma (eds), + Large-Scale Nonlinear Optimization, Springer, 255-297. + doi:10.1007/0-387-30065-1_16 + M. J. D. Powell (2009), "The BOBYQA algorithm for bound constrained + optimization without derivatives", Report DAMTP 2009/NA06, Centre for + Mathematical Sciences, University of Cambridge. diff --git a/inst/include/RcppTrust.h b/inst/include/RcppTrust.h index febf776..37de577 100644 --- a/inst/include/RcppTrust.h +++ b/inst/include/RcppTrust.h @@ -45,6 +45,8 @@ #include #include #include "trust_types.h" +#include "minqa_types.h" +#include "steihaug_types.h" #if defined(__cplusplus) extern "C" { @@ -54,25 +56,61 @@ typedef int (*trust_solve_c_t)(int n, const double *parinit, trust_c_objfun_t ob void *userdata, const trust_options_t *opts, trust_result_t *result); typedef void (*trust_result_free_t)(trust_result_t *res); +typedef int (*bobyqa_solve_c_t)(int n, const double *par, const double *lower, + const double *upper, minqa_c_objfun_t objfun, + void *userdata, const minqa_options_t *opts, + minqa_result_t *result); +typedef int (*newuoa_solve_c_t)(int n, const double *par, + minqa_c_objfun_t objfun, void *userdata, + const minqa_options_t *opts, + minqa_result_t *result); +typedef void (*minqa_result_free_t)(minqa_result_t *res); +typedef int (*steihaug_solve_c_t)(int n, const double *parinit, + steihaug_c_objfun_t objfun, + steihaug_c_hessvec_t hessvec_or_null, + void *userdata, + const steihaug_options_t *opts, + steihaug_result_t *result); +typedef void (*steihaug_result_free_t)(steihaug_result_t *res); extern trust_solve_c_t trust_solve_c_ptr; extern trust_result_free_t trust_result_free_ptr; +extern bobyqa_solve_c_t bobyqa_solve_c_ptr; +extern newuoa_solve_c_t newuoa_solve_c_ptr; +extern minqa_result_free_t minqa_result_free_ptr; +extern steihaug_solve_c_t steihaug_solve_c_ptr; +extern steihaug_result_free_t steihaug_result_free_ptr; + +/* Slots beyond the list's length (an older RcppTrust) are left NULL, so a + * consumer should check e.g. `steihaug_solve_c_ptr != NULL` before use. */ +static inline DL_FUNC iniRcppTrustSlot0(SEXP p, R_xlen_t i) { + return Rf_xlength(p) > i ? R_ExternalPtrAddrFn(VECTOR_ELT(p, i)) : NULL; +} static inline SEXP iniRcppTrustPtrs0(SEXP p) { if (trust_solve_c_ptr == NULL) { - trust_solve_c_ptr = (trust_solve_c_t)R_ExternalPtrAddrFn(VECTOR_ELT(p, 0)); - trust_result_free_ptr = - (trust_result_free_t)R_ExternalPtrAddrFn(VECTOR_ELT(p, 1)); + trust_solve_c_ptr = (trust_solve_c_t)iniRcppTrustSlot0(p, 0); + trust_result_free_ptr = (trust_result_free_t)iniRcppTrustSlot0(p, 1); + bobyqa_solve_c_ptr = (bobyqa_solve_c_t)iniRcppTrustSlot0(p, 2); + newuoa_solve_c_ptr = (newuoa_solve_c_t)iniRcppTrustSlot0(p, 3); + minqa_result_free_ptr = (minqa_result_free_t)iniRcppTrustSlot0(p, 4); + steihaug_solve_c_ptr = (steihaug_solve_c_t)iniRcppTrustSlot0(p, 5); + steihaug_result_free_ptr = (steihaug_result_free_t)iniRcppTrustSlot0(p, 6); } return R_NilValue; } -#define iniRcppTrust \ - trust_solve_c_t trust_solve_c_ptr = NULL; \ - trust_result_free_t trust_result_free_ptr = NULL; \ - SEXP iniRcppTrustPtrs(SEXP p) { \ - iniRcppTrustPtrs0(p); \ - return R_NilValue; \ +#define iniRcppTrust \ + trust_solve_c_t trust_solve_c_ptr = NULL; \ + trust_result_free_t trust_result_free_ptr = NULL; \ + bobyqa_solve_c_t bobyqa_solve_c_ptr = NULL; \ + newuoa_solve_c_t newuoa_solve_c_ptr = NULL; \ + minqa_result_free_t minqa_result_free_ptr = NULL; \ + steihaug_solve_c_t steihaug_solve_c_ptr = NULL; \ + steihaug_result_free_t steihaug_result_free_ptr = NULL; \ + SEXP iniRcppTrustPtrs(SEXP p) { \ + iniRcppTrustPtrs0(p); \ + return R_NilValue; \ } #if defined(__cplusplus) diff --git a/inst/include/minqa_types.h b/inst/include/minqa_types.h new file mode 100644 index 0000000..1b3dac7 --- /dev/null +++ b/inst/include/minqa_types.h @@ -0,0 +1,138 @@ +#ifndef MINQA_TYPES_H +#define MINQA_TYPES_H + +/* Plain C types for the thread-safe ports of M. J. D. Powell's + * derivative-free quadratic-model optimizers BOBYQA and NEWUOA, + * as distributed (with R-specific edits) in the CRAN package 'minqa'. + * No R API and no C++ types appear here so this header can be included + * from a consumer's plain C code as well. */ + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +/* Objective function contract for the thread-safe minqa solvers. + * + * n : number of parameters + * x : parameter vector, length n (input, never non-finite) + * f : output, the objective value at x. A non-finite value is + * replaced by DBL_MAX exactly as minqa's calfun() does. + * userdata : opaque pointer passed through unchanged + * + * Return value: 0 on success, <0 to abort the optimization (the solver + * returns immediately with result->ierr == MINQA_ERR_OBJFUN). */ +typedef int (*minqa_c_objfun_t)(int n, const double *x, double *f, + void *userdata); + +/* Optional sink for iprint output. Called with one NUL-terminated, + * newline-terminated line at a time. NULL disables all printing (the + * default for the thread-safe path, where Rprintf() must not be used). */ +typedef void (*minqa_print_t)(const char *line, void *print_userdata); + +typedef struct { + int npt; /* number of interpolation points */ + double rhobeg; /* initial trust region radius, > 0 */ + double rhoend; /* final trust region radius, > 0 (normally <= rhobeg) */ + int iprint; /* 0..3 as in minqa (>3: print every iprint-th eval) */ + int maxfun; /* maximum number of objective evaluations */ + minqa_print_t print; /* NULL = no printing */ + void *print_userdata; +} minqa_options_t; + +/* Initializer mirroring minqa's commonArgs() defaults for a problem with + * n parameters starting at par (rhobeg = min(0.95, 0.2 * max(abs(par))), + * rhoend = 1e-6 * rhobeg -- both 0, hence invalid, when every par is 0, + * exactly as minqa rejects that start -- npt = max(n + 2, min(min(n + 2, 2n), + * (n + 1)(n + 2) / 2)), iprint = 0, maxfun = 10000). */ +static inline minqa_options_t minqa_options_default(int n, const double *par) { + minqa_options_t opts; + double mx = 0.0; + int i, npt, nptmax; + for (i = 0; i < n; i++) { + double a = par[i] < 0 ? -par[i] : par[i]; + if (i == 0 || a > mx) mx = a; + } + opts.rhobeg = 0.2 * mx; + if (opts.rhobeg > 0.95) opts.rhobeg = 0.95; + opts.rhoend = 1.0e-6 * opts.rhobeg; + npt = n + 2 < 2 * n ? n + 2 : 2 * n; + nptmax = ((n + 1) * (n + 2)) / 2; + if (npt > nptmax) npt = nptmax; + if (npt < n + 2) npt = n + 2; + opts.npt = npt; + opts.iprint = 0; + opts.maxfun = 10000; + opts.print = NULL; + opts.print_userdata = NULL; + return opts; +} + +/* result->ierr codes. Non-negative codes are exactly the codes minqa's + * R wrappers report (after their remapping of the raw Fortran IERR): + * 0 normal exit + * 1 maximum number of function evaluations exceeded (Fortran 390) + * 2 NPT is not in the required interval (Fortran 10) + * 3 a trust region step failed to reduce q (430/3701) + * 4 a box constraint range is too small (< 2*rhobeg) (Fortran 20) + * 5 too much cancellation in a denominator (BOBYQA only, Fortran 320) + * Negative codes are failures specific to this C interface. */ +#define MINQA_OK 0 +#define MINQA_ERR_MAXFUN 1 +#define MINQA_ERR_NPT 2 +#define MINQA_ERR_NO_REDUCTION 3 +#define MINQA_ERR_RANGE 4 +#define MINQA_ERR_CANCELLATION 5 +#define MINQA_ERR_OBJFUN -1 /* objfun returned < 0 */ +#define MINQA_ERR_NONFINITE_X -2 /* calfun received non-finite x (minqa stops) */ +#define MINQA_ERR_INVALID -3 /* n < 0, NULL par/objfun, or rhobeg/rhoend + * not both > 0. rhoend > rhobeg is allowed, as + * minqa's bobyqa() can itself produce it when it + * shrinks rhobeg for tight bounds. */ +#define MINQA_ERR_NOMEM -4 +#define MINQA_ERR_INTERNAL -99 + +typedef struct { + int n; + int ierr; /* see codes above */ + int raw_ierr; /* the untranslated Fortran IERR (0, 10, 20, 320, ...) */ + int feval; /* number of objective evaluations made by the solver */ + double fval; /* objective at par, re-evaluated after the solver + * returns (not counted in feval, not DBL_MAX-clamped), + * as minqa's rval() does */ + double *par; /* length n, owned by this struct (malloc) */ +} minqa_result_t; + +/* Zero-initializes a minqa_result_t (does not allocate). */ +void minqa_result_zero(minqa_result_t *res); + +/* Frees the buffers owned by *res (safe on a zeroed result) and zeroes it. */ +void minqa_result_free(minqa_result_t *res); + +/* Thread-safe solvers: no R API, no global/static mutable state; each call + * allocates its own workspace. Return value == result->ierr + * (result == NULL returns MINQA_ERR_INVALID without writing anything). + * + * opts may be NULL, meaning minqa_options_default(n, par). For bobyqa, + * lower/upper may be NULL, meaning -Inf/+Inf for every parameter. + * + * Deviation from minqa 1.2.8: minqa's rescue.f calls CALFUN(N,X,IPRINT) + * with X undeclared in RESCUE (an uninitialized scalar), so BOBYQA's + * RESCUE step evaluates the objective at garbage memory. This port uses + * Powell's original CALFUN(N,W,F), i.e. the intended point W(1..N). All + * runs that never enter RESCUE match minqa bit for bit. */ +int bobyqa_solve_c(int n, const double *par, const double *lower, + const double *upper, minqa_c_objfun_t objfun, + void *userdata, const minqa_options_t *opts, + minqa_result_t *result); + +int newuoa_solve_c(int n, const double *par, minqa_c_objfun_t objfun, + void *userdata, const minqa_options_t *opts, + minqa_result_t *result); + +#ifdef __cplusplus +} +#endif + +#endif /* MINQA_TYPES_H */ diff --git a/inst/include/steihaug_types.h b/inst/include/steihaug_types.h new file mode 100644 index 0000000..d2d4e79 --- /dev/null +++ b/inst/include/steihaug_types.h @@ -0,0 +1,198 @@ +#ifndef STEIHAUG_TYPES_H +#define STEIHAUG_TYPES_H + +/* Plain C types for the thread-safe port of the Steihaug (truncated + * conjugate-gradient) trust-region Newton minimizer from the Rust crate + * 'basin' (https://github.com/jolars/basin, MIT OR Apache-2.0, ported + * from commit 86cc0d6: TrustRegion / TrustRegion::matrix_free() + * driven by basin's Executor). No R API and no C++ types appear here so + * this header can be included from a consumer's plain C code as well. */ + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +/* Objective function contract. + * + * n : number of parameters + * x : parameter vector, length n (input) + * value : output objective value, or NULL when not requested + * gradient : output buffer of length n, or NULL when not requested + * hessian : output buffer of length n*n, row-major (symmetric, so + * column-major storage is equivalent), or NULL when not + * requested + * userdata : opaque pointer passed through unchanged + * + * The solver requests exactly what basin's problem calls request, one + * callback per basin call, so evaluation counts match basin: + * - value + gradient once at initialization (cost_and_gradient) + * - hessian only once per outer iteration (exact mode only) + * - value only once per trial step + * - gradient only once after each accepted step + * A non-finite value is allowed (it is treated as a rejected step, as in + * basin). Return 0 on success, <0 to abort the run (basin propagates a + * problem error as Err): the solver returns STEIHAUG_ERR_OBJFUN. */ +typedef int (*steihaug_c_objfun_t)(int n, const double *x, double *value, + double *gradient, double *hessian, + void *userdata); + +/* Optional Hessian-vector product hv = H(x) v (both length n). Passing a + * non-NULL function selects basin's MatrixFree mode: the Hessian is never + * requested from objfun. Return 0 on success, <0 to abort the run + * (STEIHAUG_ERR_HESSVEC). */ +typedef int (*steihaug_c_hessvec_t)(int n, const double *x, const double *v, + double *hv, void *userdata); + +/* Tolerance sentinel: a tolerance field set to any NEGATIVE value (use + * STEIHAUG_DISABLED) is disabled. Enabled tolerances must be finite and + * >= 0 (basin's optional_tolerance assertion); NaN or +Inf is rejected + * with STEIHAUG_ERR_INVALID_OPTIONS. */ +#define STEIHAUG_DISABLED (-1.0) + +typedef struct { + /* --- TrustRegion solver settings (basin defaults) --- */ + double initial_radius; /* Delta_0, default 1; must be > 0 */ + double max_radius; /* Delta_max, default 100; must be > 0 */ + double eta; /* acceptance threshold, default 0.125, [0,1/4) */ + int max_inner; /* radius reductions per outer iteration, + default 10, >= 1 */ + /* --- Steihaug CG settings --- */ + int cg_max_iter; /* CG iteration cap, 0 = n (default), else >= 1 */ + double kappa; /* forcing: stop when ||r|| < min(kappa, */ + double theta; /* ||g||^theta) ||g||; defaults 0.5 / 0.5. + kappa finite in [0,1), theta finite >= 0 */ + + /* --- Executor run controls (checked before every iteration, in this + * order: max_iter, max_cost_evals, max_gradient_evals, target) --- */ + int max_iter; /* default 100 (basin's executor: 1000); >= 0 */ + long long max_cost_evals; /* < 0 disables (default) */ + long long max_gradient_evals; /* < 0 disables (default); counts only + gradient evaluations, like basin */ + int has_target_cost; /* 0/1, default 0 */ + double target_cost; /* stop when best cost <= target; finite */ + + /* --- Solver convergence checks (after the run controls, in this order: + * absolute gradient, relative gradient, absolute step, relative + * step, absolute cost change, relative cost change). Negative = + * disabled. --- */ + double abs_gradient_tol; /* ||g||_2 <= tol. Default 1e-8 (basin: off) */ + double rel_gradient_tol; /* ||g||_2 <= tol ||g_0||_2, anchored on the + first finite gradient checked. Default off */ + double abs_step_tol; /* ||x_k - x_{k-1}||_2 <= tol. Default off. + NB: an iteration whose inner attempts all + fail leaves x unchanged and fires this. */ + double rel_step_tol; /* ||x_k - x_{k-1}|| <= tol ||x_k||. Off */ + double abs_cost_change_tol; /* |f_{k-1} - f_k| <= tol. Default off */ + double rel_cost_change_tol; /* |f_{k-1} - f_k| <= tol |f_{k-1}|. Off */ + + int trace; /* 1 = record one trace row per subproblem attempt */ +} steihaug_options_t; + +static inline steihaug_options_t steihaug_options_default(void) { + steihaug_options_t o; + o.initial_radius = 1.0; + o.max_radius = 100.0; + o.eta = 0.125; + o.max_inner = 10; + o.cg_max_iter = 0; + o.kappa = 0.5; + o.theta = 0.5; + o.max_iter = 100; + o.max_cost_evals = -1; + o.max_gradient_evals = -1; + o.has_target_cost = 0; + o.target_cost = 0.0; + o.abs_gradient_tol = 1e-8; + o.rel_gradient_tol = STEIHAUG_DISABLED; + o.abs_step_tol = STEIHAUG_DISABLED; + o.rel_step_tol = STEIHAUG_DISABLED; + o.abs_cost_change_tol = STEIHAUG_DISABLED; + o.rel_cost_change_tol = STEIHAUG_DISABLED; + o.trace = 0; + return o; +} + +/* Termination reasons (>= 0, mirroring basin's TerminationReason variants + * reachable by this solver) and errors (< 0). */ +typedef enum { + STEIHAUG_MAX_ITER = 0, + STEIHAUG_MAX_COST_EVALS = 1, + STEIHAUG_MAX_GRADIENT_EVALS = 2, + STEIHAUG_TARGET_COST = 3, + STEIHAUG_GRADIENT_TOLERANCE = 4, + STEIHAUG_RELATIVE_GRADIENT_TOLERANCE = 5, + STEIHAUG_PARAM_TOLERANCE = 6, /* absolute step tolerance */ + STEIHAUG_RELATIVE_PARAM_TOLERANCE = 7, /* relative step tolerance */ + STEIHAUG_COST_TOLERANCE = 8, /* absolute cost change */ + STEIHAUG_RELATIVE_COST_TOLERANCE = 9, /* relative cost change */ + STEIHAUG_SOLVER_CONVERGED = 10, /* predicted reduction <= 0 (g == 0) */ + STEIHAUG_SOLVER_FAILED = 11, /* non-finite predicted reduction */ + + STEIHAUG_ERR_OBJFUN = -1, /* objfun returned < 0 */ + STEIHAUG_ERR_HESSVEC = -2, /* hessvec returned < 0 */ + STEIHAUG_ERR_INVALID_OPTIONS = -3, /* n < 1, NULL pointers, bad opts */ + STEIHAUG_ERR_NOMEM = -4, /* allocation failure */ + STEIHAUG_ERR_INTERNAL = -99 +} steihaug_status_t; + +typedef struct { + int n; + int status; /* steihaug_status_t */ + int converged; /* 1 for the tolerance / target / SolverConverged + reasons (4..10 and 3), else 0 */ + int iterations; /* basin's state.iter: completed outer iterations + (a SolverConverged/SolverFailed stop does not count) */ + + /* Final state (basin's state.param / state.cost / state.gradient). On + * an ERR_OBJFUN/ERR_HESSVEC abort these hold the state at the start of + * the failing outer iteration (basin itself discards the state). */ + double value; + double *argument; /* length n, malloc-owned */ + double *gradient; /* length n, malloc-owned */ + double radius; /* trust radius after the run */ + + /* Evaluation counts, incremented before each call like basin's Problem + * wrapper (so a failing call is counted). */ + long long cost_evals; /* calls that requested value */ + long long gradient_evals; /* calls that requested gradient */ + long long hessian_evals; + long long hessvec_evals; + + /* Trace (trace = 1): one row per subproblem attempt, length trace_len. + * All arrays malloc-owned. */ + int trace_len; + int *trace_iter; /* outer iteration index (state.iter) */ + double *trace_radius; /* radius used for this attempt */ + double *trace_cost; /* cost at the current iterate */ + double *trace_gradnorm; /* ||g||_2 at the current iterate */ + double *trace_trial_cost; /* cost at x + d (NaN if not evaluated) */ + double *trace_pred; /* predicted reduction m(0) - m(d) */ + double *trace_rho; /* reduction ratio (NaN if not evaluated) */ + double *trace_step_norm; /* ||d||_2 (NaN if not evaluated) */ + int *trace_accept; /* 0/1 */ + int *trace_hit_boundary; /* 0/1 */ + int *trace_cg_iter; /* CG iterations performed in this attempt */ +} steihaug_result_t; + +/* Zero-initializes a result (does not allocate). */ +void steihaug_result_zero(steihaug_result_t *res); + +/* Frees every malloc-owned buffer and zeroes the struct. Safe on a zeroed + * or partially filled result, from any thread. */ +void steihaug_result_free(steihaug_result_t *res); + +/* Thread-safe solver: no R API, no globals or statics; all buffers are + * owned by the call. `result` is zeroed on entry (free any previous + * contents first). Returns result->status. */ +int steihaug_solve_c(int n, const double *parinit, steihaug_c_objfun_t objfun, + steihaug_c_hessvec_t hessvec_or_null, void *userdata, + const steihaug_options_t *opts, + steihaug_result_t *result); + +#ifdef __cplusplus +} +#endif + +#endif /* STEIHAUG_TYPES_H */ diff --git a/man/bobyqa.Rd b/man/bobyqa.Rd new file mode 100644 index 0000000..7d35ab9 --- /dev/null +++ b/man/bobyqa.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/minqa.R +\name{bobyqa} +\alias{bobyqa} +\title{Nonlinear optimization with box constraints (BOBYQA)} +\source{ +M. J. D. Powell's original Fortran 77 BOBYQA code, archived at + \url{https://github.com/libprima/prima/tree/main/fortran/original/bobyqa}; + R interface following the \pkg{minqa} package. +} +\usage{ +bobyqa(par, fn, lower = -Inf, upper = Inf, control = list(), ...) +} +\arguments{ +\item{par}{numeric vector of starting parameters.} + +\item{fn}{function to be minimized; its first argument must be the +parameter vector and it must return a scalar numeric value.} + +\item{lower, upper}{numeric vectors of lower and upper bounds (recycled +when of length 1).} + +\item{control}{a list of control settings: \code{npt}, \code{rhobeg}, +\code{rhoend}, \code{iprint}, \code{maxfun}, \code{obstop} and +\code{force.start}, as in \code{minqa::bobyqa()}.} + +\item{...}{further arguments passed to \code{fn}.} +} +\value{ +A list of class \code{c("bobyqa", "minqa")} with components + \code{par}, \code{fval}, \code{feval}, \code{ierr} and \code{msg}. +} +\description{ +Thread-safe C++ port of \code{minqa::bobyqa()}: minimizes a function of +many variables subject to box constraints by a trust region method that +forms quadratic models by interpolation, using M. J. D. Powell's BOBYQA +algorithm. Arguments, defaults, and return value are those of +\code{minqa::bobyqa()}; see its documentation for details. +} +\examples{ +fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +bobyqa(c(1, 2), fr, lower = c(0, 0), upper = c(4, 4)) +} +\references{ +M. J. D. Powell (2009), "The BOBYQA algorithm for bound + constrained optimization without derivatives", Report No. DAMTP + 2009/NA06, Centre for Mathematical Sciences, University of Cambridge. +} +\seealso{ +[newuoa()], and [minqa_c_api] for calling the + solvers from parallel C/C++ code. +} diff --git a/man/minqa_c_api.Rd b/man/minqa_c_api.Rd new file mode 100644 index 0000000..7f9c7cc --- /dev/null +++ b/man/minqa_c_api.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/c-api.R +\name{minqa_c_api} +\alias{minqa_c_api} +\alias{steihaug_c_api} +\alias{trust_c_api} +\title{Thread-safe C interfaces} +\description{ +Every optimizer in this package is implemented as a C-callable core with +no R API calls and no global state, so each can run concurrently from +OpenMP/parallel C++ code (e.g. as an inner or outer optimizer in +\code{nlmixr2est}). The R functions [trust()], [steihaug()], [bobyqa()] +and [newuoa()] are thin wrappers around these same cores. +} +\details{ +\tabular{lll}{ + \strong{Solver} \tab \strong{Header} \tab \strong{Entry point / free} \cr + trust \tab \code{trust_types.h} \tab \code{trust_solve_c} / \code{trust_result_free} \cr + BOBYQA \tab \code{minqa_types.h} \tab \code{bobyqa_solve_c} / \code{minqa_result_free} \cr + NEWUOA \tab \code{minqa_types.h} \tab \code{newuoa_solve_c} / \code{minqa_result_free} \cr + Steihaug \tab \code{steihaug_types.h} \tab \code{steihaug_solve_c} / \code{steihaug_result_free} \cr +} + +A consuming package adds \code{RcppTrust} to \code{LinkingTo} and +\code{Imports}, includes \code{RcppTrust.h}, and resolves the pointers at +load time from [.RcppTrustPtr()] (slots, in order: \code{trust_solve_c}, +\code{trust_result_free}, \code{bobyqa_solve_c}, \code{newuoa_solve_c}, +\code{minqa_result_free}, \code{steihaug_solve_c}, +\code{steihaug_result_free}). See \code{vignette("RcppTrust")} for a +worked example. +} +\keyword{internal} diff --git a/man/newuoa.Rd b/man/newuoa.Rd new file mode 100644 index 0000000..ba3e5ff --- /dev/null +++ b/man/newuoa.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/minqa.R +\name{newuoa} +\alias{newuoa} +\title{Unconstrained derivative-free optimization (NEWUOA)} +\source{ +M. J. D. Powell's original Fortran 77 NEWUOA code, archived at + \url{https://github.com/libprima/prima/tree/main/fortran/original/newuoa}; + R interface following the \pkg{minqa} package. +} +\usage{ +newuoa(par, fn, control = list(), ...) +} +\arguments{ +\item{par}{numeric vector of starting parameters.} + +\item{fn}{function to be minimized; its first argument must be the +parameter vector and it must return a scalar numeric value.} + +\item{control}{a list of control settings: \code{npt}, \code{rhobeg}, +\code{rhoend}, \code{iprint} and \code{maxfun}, as in +\code{minqa::newuoa()}.} + +\item{...}{further arguments passed to \code{fn}.} +} +\value{ +A list of class \code{c("newuoa", "minqa")} with components + \code{par}, \code{fval}, \code{feval}, \code{ierr} and \code{msg}. +} +\description{ +Thread-safe C++ port of \code{minqa::newuoa()}: minimizes a function of +many variables by a trust region method that forms quadratic models by +interpolation, using M. J. D. Powell's NEWUOA algorithm. +} +\examples{ +fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +newuoa(c(1, 2), fr) +} +\references{ +M. J. D. Powell (2006), "The NEWUOA software for + unconstrained optimization without derivatives", in Large-Scale + Nonlinear Optimization, Springer, 255-297. + \doi{10.1007/0-387-30065-1_16} +} +\seealso{ +[bobyqa()], [minqa_c_api] +} diff --git a/man/print.minqa.Rd b/man/print.minqa.Rd new file mode 100644 index 0000000..e4d4b39 --- /dev/null +++ b/man/print.minqa.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/minqa.R +\name{print.minqa} +\alias{print.minqa} +\title{Print method for minqa objects} +\usage{ +\method{print}{minqa}(x, digits = max(3, getOption("digits") - 3), ...) +} +\arguments{ +\item{x}{an object inheriting from class \code{minqa}.} + +\item{digits}{unused; kept for compatibility with \code{minqa}.} + +\item{...}{unused.} +} +\value{ +\code{invisible(x)} +} +\description{ +Print method for minqa objects +} diff --git a/man/steihaug.Rd b/man/steihaug.Rd new file mode 100644 index 0000000..18955a9 --- /dev/null +++ b/man/steihaug.Rd @@ -0,0 +1,105 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/steihaug.R +\name{steihaug} +\alias{steihaug} +\title{Steihaug truncated-CG trust-region Newton minimization} +\usage{ +steihaug(par, fn, gr, hess = NULL, hessvec = NULL, control = list(), ...) +} +\arguments{ +\item{par}{numeric vector of starting parameters.} + +\item{fn}{objective function of the parameter vector returning a scalar.} + +\item{gr}{gradient function returning a numeric vector of length +\code{length(par)}.} + +\item{hess}{Hessian function returning a symmetric +\code{length(par)} by \code{length(par)} matrix. May be \code{NULL} when +\code{hessvec} is supplied.} + +\item{hessvec}{optional Hessian-vector product \code{function(x, v)} +returning \eqn{H(x) v}{H(x) \%*\% v}. When supplied, the matrix-free mode +is used and \code{hess} is never called.} + +\item{control}{a list of control settings (defaults in brackets; a +\code{NULL} tolerance or budget is disabled): +\describe{ + \item{rinit}{initial trust region radius [1]} + \item{rmax}{maximum trust region radius [100]} + \item{eta}{step acceptance threshold on the reduction ratio, in + \eqn{[0, 1/4)} [0.125]} + \item{maxInner}{radius reductions (re-solves) per outer iteration [10]} + \item{cgMaxit}{CG iteration cap per subproblem; 0 means + \code{length(par)} [0]} + \item{kappa, theta}{CG forcing rule: stop when + \eqn{\|r\| < \min(\kappa, \|g\|^\theta)\|g\|}{||r|| < min(kappa, ||g||^theta) ||g||} + [0.5, 0.5]} + \item{maxit}{maximum outer iterations [100]} + \item{maxCostEvals, maxGradEvals}{evaluation budgets [NULL]} + \item{targetCost}{stop once the objective is at or below this [NULL]} + \item{gradTol}{absolute gradient tolerance on + \eqn{\|g\|_2}{||g||_2} [1e-8]} + \item{relGradTol}{gradient tolerance relative to the initial gradient + norm [NULL]} + \item{stepTol, relStepTol}{absolute / relative step tolerance [NULL]} + \item{costTol, relCostTol}{absolute / relative objective change + tolerance [NULL]} + \item{trace}{if \code{TRUE}, return a per-attempt trace [FALSE]} +}} + +\item{...}{further arguments passed to \code{fn}, \code{gr}, \code{hess} +and \code{hessvec}.} +} +\value{ +A list with components \code{par}, \code{value}, \code{gradient}, + \code{iterations}, \code{converged}, \code{status} (integer), + \code{message} (the basin termination reason, e.g. + \code{"GradientTolerance"}, \code{"MaxIter"}), \code{radius} (final + trust radius), \code{counts} (evaluations of \code{fn}, \code{gr}, + \code{hess}, \code{hessvec}), and, when \code{control$trace} is + \code{TRUE}, \code{trace}, a data frame with one row per subproblem + attempt. +} +\description{ +Thread-safe C++ port of the trust-region Newton minimizer with the +Steihaug truncated conjugate-gradient subproblem from the Rust crate +\href{https://github.com/jolars/basin}{basin} (\code{TrustRegion} with +its default \code{Steihaug} subproblem, driven by basin's executor). Each +iteration approximately minimizes the quadratic model +\eqn{m(p) = f + g^T p + \frac{1}{2} p^T B p}{m(p) = f + g'p + p'Bp/2} +over \eqn{\|p\| \le \Delta}{||p|| <= Delta} by conjugate gradients, +stopping at the boundary on negative curvature. Unlike [trust()] it never +factorizes the Hessian, and with \code{hessvec} it never forms it at all +(basin's matrix-free mode). +} +\details{ +Evaluation pattern (identical to basin): \code{fn} and \code{gr} once at +the start; \code{hess} once per outer iteration (exact mode) or +\code{hessvec} once per CG product (matrix-free mode); \code{fn} at each +trial point; \code{gr} after each accepted step. \code{fn} may return +\code{Inf} (or \code{NaN}) at a trial point to reject it. +} +\examples{ +fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +grr <- function(x) c(-400 * x[1] * (x[2] - x[1]^2) - 2 * (1 - x[1]), + 200 * (x[2] - x[1]^2)) +hr <- function(x) matrix(c(1200 * x[1]^2 - 400 * x[2] + 2, -400 * x[1], + -400 * x[1], 200), 2, 2) +steihaug(c(-1.2, 1), fr, grr, hr) + +# matrix-free: only Hessian-vector products +hv <- function(x, v) drop(hr(x) \%*\% v) +steihaug(c(-1.2, 1), fr, grr, hessvec = hv)$counts +} +\references{ +Steihaug, T. (1983). The conjugate gradient method and trust + regions in large scale optimization. SIAM Journal on Numerical Analysis, + 20(3), 626-637. + + Nocedal, J. and Wright, S. J. (2006). Numerical Optimization (2nd ed.), + Algorithms 4.1 and 7.2. Springer. +} +\seealso{ +[trust()], [bobyqa()], [newuoa()] +} diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index f52cf4e..a07ece7 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -12,6 +12,74 @@ Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif +// minqa_bobyqa_r +List minqa_bobyqa_r(NumericVector par, NumericVector lower, NumericVector upper, Environment ctrl, Function fn); +RcppExport SEXP _RcppTrust_minqa_bobyqa_r(SEXP parSEXP, SEXP lowerSEXP, SEXP upperSEXP, SEXP ctrlSEXP, SEXP fnSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< NumericVector >::type par(parSEXP); + Rcpp::traits::input_parameter< NumericVector >::type lower(lowerSEXP); + Rcpp::traits::input_parameter< NumericVector >::type upper(upperSEXP); + Rcpp::traits::input_parameter< Environment >::type ctrl(ctrlSEXP); + Rcpp::traits::input_parameter< Function >::type fn(fnSEXP); + rcpp_result_gen = Rcpp::wrap(minqa_bobyqa_r(par, lower, upper, ctrl, fn)); + return rcpp_result_gen; +END_RCPP +} +// minqa_newuoa_r +List minqa_newuoa_r(NumericVector par, Environment ctrl, Function fn); +RcppExport SEXP _RcppTrust_minqa_newuoa_r(SEXP parSEXP, SEXP ctrlSEXP, SEXP fnSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< NumericVector >::type par(parSEXP); + Rcpp::traits::input_parameter< Environment >::type ctrl(ctrlSEXP); + Rcpp::traits::input_parameter< Function >::type fn(fnSEXP); + rcpp_result_gen = Rcpp::wrap(minqa_newuoa_r(par, ctrl, fn)); + return rcpp_result_gen; +END_RCPP +} +// solver_openmp_stress_test +List solver_openmp_stress_test(std::string solver, int n, int nStarts, int nThreadsRequested); +RcppExport SEXP _RcppTrust_solver_openmp_stress_test(SEXP solverSEXP, SEXP nSEXP, SEXP nStartsSEXP, SEXP nThreadsRequestedSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< std::string >::type solver(solverSEXP); + Rcpp::traits::input_parameter< int >::type n(nSEXP); + Rcpp::traits::input_parameter< int >::type nStarts(nStartsSEXP); + Rcpp::traits::input_parameter< int >::type nThreadsRequested(nThreadsRequestedSEXP); + rcpp_result_gen = Rcpp::wrap(solver_openmp_stress_test(solver, n, nStarts, nThreadsRequested)); + return rcpp_result_gen; +END_RCPP +} +// solver_c_api_edge_test +IntegerVector solver_c_api_edge_test(); +RcppExport SEXP _RcppTrust_solver_c_api_edge_test() { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + rcpp_result_gen = Rcpp::wrap(solver_c_api_edge_test()); + return rcpp_result_gen; +END_RCPP +} +// steihaug_solve_r +List steihaug_solve_r(NumericVector par, Function fn, Function gr, RObject hess, RObject hessvec, List control); +RcppExport SEXP _RcppTrust_steihaug_solve_r(SEXP parSEXP, SEXP fnSEXP, SEXP grSEXP, SEXP hessSEXP, SEXP hessvecSEXP, SEXP controlSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< NumericVector >::type par(parSEXP); + Rcpp::traits::input_parameter< Function >::type fn(fnSEXP); + Rcpp::traits::input_parameter< Function >::type gr(grSEXP); + Rcpp::traits::input_parameter< RObject >::type hess(hessSEXP); + Rcpp::traits::input_parameter< RObject >::type hessvec(hessvecSEXP); + Rcpp::traits::input_parameter< List >::type control(controlSEXP); + rcpp_result_gen = Rcpp::wrap(steihaug_solve_r(par, fn, gr, hess, hessvec, control)); + return rcpp_result_gen; +END_RCPP +} // trust_solve_r List trust_solve_r(Function objfun1, Function tryEval, NumericVector parinit, double rinit, double rmax, Nullable parscale, int iterlim, double fterm, double mterm, bool minimize, bool blather); RcppExport SEXP _RcppTrust_trust_solve_r(SEXP objfun1SEXP, SEXP tryEvalSEXP, SEXP parinitSEXP, SEXP rinitSEXP, SEXP rmaxSEXP, SEXP parscaleSEXP, SEXP iterlimSEXP, SEXP ftermSEXP, SEXP mtermSEXP, SEXP minimizeSEXP, SEXP blatherSEXP) { @@ -120,6 +188,11 @@ END_RCPP } static const R_CallMethodDef CallEntries[] = { + {"_RcppTrust_minqa_bobyqa_r", (DL_FUNC) &_RcppTrust_minqa_bobyqa_r, 5}, + {"_RcppTrust_minqa_newuoa_r", (DL_FUNC) &_RcppTrust_minqa_newuoa_r, 3}, + {"_RcppTrust_solver_openmp_stress_test", (DL_FUNC) &_RcppTrust_solver_openmp_stress_test, 4}, + {"_RcppTrust_solver_c_api_edge_test", (DL_FUNC) &_RcppTrust_solver_c_api_edge_test, 0}, + {"_RcppTrust_steihaug_solve_r", (DL_FUNC) &_RcppTrust_steihaug_solve_r, 6}, {"_RcppTrust_trust_solve_r", (DL_FUNC) &_RcppTrust_trust_solve_r, 11}, {"_RcppTrust_trust_check_numeric_output_test", (DL_FUNC) &_RcppTrust_trust_check_numeric_output_test, 5}, {"_RcppTrust_trust_solve_lagrange_multiplier_test", (DL_FUNC) &_RcppTrust_trust_solve_lagrange_multiplier_test, 6}, diff --git a/src/minqa_bobyqa.cpp b/src/minqa_bobyqa.cpp new file mode 100644 index 0000000..6cc4bc3 --- /dev/null +++ b/src/minqa_bobyqa.cpp @@ -0,0 +1,2210 @@ +// Thread-safe C++17 port of M. J. D. Powell's BOBYQA as shipped (with +// R-specific edits by John Nash et al.) in the CRAN package minqa 1.2.8: +// bobyqa.f, bobyqb.f, prelim.f, rescue.f, trsbox.f, altmov.f and +// updatebobyqa.f. The translation is line by line: Powell's variable names, +// the partitioning of the work array W, column-major 2-D arrays accessed +// with 1-based index macros, labels as gotos and the Fortran order of +// floating point operations are all kept, so results are bitwise identical +// to the Fortran compiled without FMA/fast-math. +// +// Differences from the Fortran: +// * CALFUN(N,X,IPRINT) is MinqaCalfun::operator()(x); minqit/minqir are +// MinqaCalfun::minqit/minqir (printing via an optional callback). +// * RESCUE in minqa calls CALFUN(N,X,IPRINT) where X is an undeclared +// (implicitly scalar, uninitialized) local, i.e. undefined behaviour. +// Powell's original code evaluates F at W(1..N), which RESCUE has just +// filled with the new point; this port does the same. +// * Locals that the Fortran may read before assignment on paths that are +// unreachable in practice are zero-initialized (KSAV in ALTMOV is +// initialized to KOPT so that XNEW=XOPT in that degenerate case). +// +// No static or global mutable state, no R API: safe to call concurrently. + +#include +#include +#include +#include +#include +#include "minqa_common.h" +#include "minqa_types.h" + +// Forbid FMA contraction (a*b + c -> fma) so the port keeps the exact IEEE +// operation sequence of minqa's Fortran as built on x86_64 (and the +// bit-for-bit validation holds) on targets that contract by default, such +// as aarch64. Placed after the headers so only this file's code is affected. +#if defined(__clang__) +#pragma clang fp contract(off) +#elif defined(__GNUC__) +#pragma GCC optimize("fp-contract=off") +#endif + +// Hook used only by the validation harness to count RESCUE calls. +#ifndef MINQA_BOBYQA_RESCUE_HOOK +#define MINQA_BOBYQA_RESCUE_HOOK() +#endif + +// 1-based, column-major array accessors mirroring the Fortran declarations. +#define X(i) x[(i) - 1] +#define XL(i) xl[(i) - 1] +#define XU(i) xu[(i) - 1] +#define W(i) w[(i) - 1] +#define XBASE(i) xbase[(i) - 1] +#define XPT(k, j) xpt[((k) - 1) + ((j) - 1) * npt] +#define FVAL(i) fval[(i) - 1] +#define XOPT(i) xopt[(i) - 1] +#define GOPT(i) gopt[(i) - 1] +#define HQ(i) hq[(i) - 1] +#define PQ(i) pq[(i) - 1] +#define BMAT(i, j) bmat[((i) - 1) + ((j) - 1) * ndim] +#define ZMAT(k, j) zmat[((k) - 1) + ((j) - 1) * npt] +#define SL(i) sl[(i) - 1] +#define SU(i) su[(i) - 1] +#define XNEW(i) xnew[(i) - 1] +#define XALT(i) xalt[(i) - 1] +#define D(i) d[(i) - 1] +#define VLAG(i) vlag[(i) - 1] +#define GNEW(i) gnew[(i) - 1] +#define XBDI(i) xbdi[(i) - 1] +#define S(i) s[(i) - 1] +#define HS(i) hs[(i) - 1] +#define HRED(i) hred[(i) - 1] +#define GLAG(i) glag[(i) - 1] +#define HCOL(i) hcol[(i) - 1] +#define PTSAUX(i, j) ptsaux[((i) - 1) + ((j) - 1) * 2] +#define PTSID(i) ptsid[(i) - 1] + +namespace { + +// --------------------------------------------------------------------------- +// updatebobyqa.f: SUBROUTINE UPDATEBOBYQA +// --------------------------------------------------------------------------- +void updatebobyqa(int n, int npt, double *bmat, double *zmat, int ndim, + double *vlag, double beta, double denom, int knew, + double *w) { + double one, zero, ztest, temp, tempa, tempb, alpha, tau; + int nptm, k, j, i, jp; + + one = 1.0; + zero = 0.0; + nptm = npt - n - 1; + ztest = zero; + for (k = 1; k <= npt; k++) { + for (j = 1; j <= nptm; j++) { + ztest = std::max(ztest, std::fabs(ZMAT(k, j))); + } + } + ztest = 1.0e-20 * ztest; + // + // Apply the rotations that put zeros in the KNEW-th row of ZMAT. + // + for (j = 2; j <= nptm; j++) { + if (std::fabs(ZMAT(knew, j)) > ztest) { + temp = std::sqrt(ZMAT(knew, 1) * ZMAT(knew, 1) + + ZMAT(knew, j) * ZMAT(knew, j)); + tempa = ZMAT(knew, 1) / temp; + tempb = ZMAT(knew, j) / temp; + for (i = 1; i <= npt; i++) { + temp = tempa * ZMAT(i, 1) + tempb * ZMAT(i, j); + ZMAT(i, j) = tempa * ZMAT(i, j) - tempb * ZMAT(i, 1); + ZMAT(i, 1) = temp; + } + } + ZMAT(knew, j) = zero; + } + // + // Put the first NPT components of the KNEW-th column of HLAG into W, + // and calculate the parameters of the updating formula. + // + for (i = 1; i <= npt; i++) { + W(i) = ZMAT(knew, 1) * ZMAT(i, 1); + } + alpha = W(knew); + tau = VLAG(knew); + VLAG(knew) = VLAG(knew) - one; + // + // Complete the updating of ZMAT. + // + temp = std::sqrt(denom); + tempb = ZMAT(knew, 1) / temp; + tempa = tau / temp; + for (i = 1; i <= npt; i++) { + ZMAT(i, 1) = tempa * ZMAT(i, 1) - tempb * VLAG(i); + } + // + // Finally, update the matrix BMAT. + // + for (j = 1; j <= n; j++) { + jp = npt + j; + W(jp) = BMAT(knew, j); + tempa = (alpha * VLAG(jp) - tau * W(jp)) / denom; + tempb = (-beta * W(jp) - tau * VLAG(jp)) / denom; + for (i = 1; i <= jp; i++) { + BMAT(i, j) = BMAT(i, j) + tempa * VLAG(i) + tempb * W(i); + if (i > npt) BMAT(jp, i - npt) = BMAT(i, j); + } + } +} + +// --------------------------------------------------------------------------- +// prelim.f: SUBROUTINE PRELIM +// --------------------------------------------------------------------------- +void prelim(int n, int npt, double *x, const double *xl, const double *xu, + double rhobeg, int maxfun, double *xbase, double *xpt, + double *fval, double *gopt, double *hq, double *pq, double *bmat, + double *zmat, int ndim, double *sl, double *su, int &nf, + int &kopt, MinqaCalfun &calfun) { + double half, one, two, zero, rhosq, recip, stepa = 0.0, stepb = 0.0, f, + fbeg = 0.0, temp, diff; + int np, j, k, i, ih, nfm, nfx, itemp, jpt = 0, ipt = 0; + + half = 0.5; + one = 1.0; + two = 2.0; + zero = 0.0; + rhosq = rhobeg * rhobeg; + recip = one / rhosq; + np = n + 1; + // + // Set XBASE to the initial vector of variables, and set the initial + // elements of XPT, BMAT, HQ, PQ and ZMAT to zero. + // + for (j = 1; j <= n; j++) { + XBASE(j) = X(j); + for (k = 1; k <= npt; k++) { + XPT(k, j) = zero; + } + for (i = 1; i <= ndim; i++) { + BMAT(i, j) = zero; + } + } + for (ih = 1; ih <= (n * np) / 2; ih++) { + HQ(ih) = zero; + } + for (k = 1; k <= npt; k++) { + PQ(k) = zero; + for (j = 1; j <= npt - np; j++) { + ZMAT(k, j) = zero; + } + } + // + // Begin the initialization procedure. NF becomes one more than the + // number of function values so far. The coordinates of the displacement + // of the next initial interpolation point from XBASE are set in + // XPT(NF+1,.). + // + nf = 0; +L50: + nfm = nf; + nfx = nf - n; + nf = nf + 1; + if (nfm <= 2 * n) { + if (nfm >= 1 && nfm <= n) { + stepa = rhobeg; + if (SU(nfm) == zero) stepa = -stepa; + XPT(nf, nfm) = stepa; + } else if (nfm > n) { + stepa = XPT(nf - n, nfx); + stepb = -rhobeg; + if (SL(nfx) == zero) stepb = std::min(two * rhobeg, SU(nfx)); + if (SU(nfx) == zero) stepb = std::max(-two * rhobeg, SL(nfx)); + XPT(nf, nfx) = stepb; + } + } else { + itemp = (nfm - np) / n; + jpt = nfm - itemp * n - n; + ipt = jpt + itemp; + if (ipt > n) { + itemp = jpt; + jpt = ipt - n; + ipt = itemp; + } + XPT(nf, ipt) = XPT(ipt + 1, ipt); + XPT(nf, jpt) = XPT(jpt + 1, jpt); + } + // + // Calculate the next value of F. The least function value so far and + // its index are required. + // + for (j = 1; j <= n; j++) { + X(j) = std::min(std::max(XL(j), XBASE(j) + XPT(nf, j)), XU(j)); + if (XPT(nf, j) == SL(j)) X(j) = XL(j); + if (XPT(nf, j) == SU(j)) X(j) = XU(j); + } + f = calfun(x); + FVAL(nf) = f; + if (nf == 1) { + fbeg = f; + kopt = 1; + } else if (f < FVAL(kopt)) { + kopt = nf; + } + // + // Set the nonzero initial elements of BMAT and the quadratic model in + // the cases when NF is at most 2*N+1. If NF exceeds N+1, then the + // positions of the NF-th and (NF-N)-th interpolation points may be + // switched, in order that the function value at the first of them + // contributes to the off-diagonal second derivative terms of the + // initial quadratic model. + // + if (nf <= 2 * n + 1) { + if (nf >= 2 && nf <= n + 1) { + GOPT(nfm) = (f - fbeg) / stepa; + if (npt < nf + n) { + BMAT(1, nfm) = -one / stepa; + BMAT(nf, nfm) = one / stepa; + BMAT(npt + nfm, nfm) = -half * rhosq; + } + } else if (nf >= n + 2) { + ih = (nfx * (nfx + 1)) / 2; + temp = (f - fbeg) / stepb; + diff = stepb - stepa; + HQ(ih) = two * (temp - GOPT(nfx)) / diff; + GOPT(nfx) = (GOPT(nfx) * stepb - temp * stepa) / diff; + if (stepa * stepb < zero) { + if (f < FVAL(nf - n)) { + FVAL(nf) = FVAL(nf - n); + FVAL(nf - n) = f; + if (kopt == nf) kopt = nf - n; + XPT(nf - n, nfx) = stepb; + XPT(nf, nfx) = stepa; + } + } + BMAT(1, nfx) = -(stepa + stepb) / (stepa * stepb); + BMAT(nf, nfx) = -half / XPT(nf - n, nfx); + BMAT(nf - n, nfx) = -BMAT(1, nfx) - BMAT(nf, nfx); + ZMAT(1, nfx) = std::sqrt(two) / (stepa * stepb); + ZMAT(nf, nfx) = std::sqrt(half) / rhosq; + ZMAT(nf - n, nfx) = -ZMAT(1, nfx) - ZMAT(nf, nfx); + } + // + // Set the off-diagonal second derivatives of the Lagrange functions + // and the initial quadratic model. + // + } else { + ih = (ipt * (ipt - 1)) / 2 + jpt; + ZMAT(1, nfx) = recip; + ZMAT(nf, nfx) = recip; + ZMAT(ipt + 1, nfx) = -recip; + ZMAT(jpt + 1, nfx) = -recip; + temp = XPT(nf, ipt) * XPT(nf, jpt); + HQ(ih) = (fbeg - FVAL(ipt + 1) - FVAL(jpt + 1) + f) / temp; + } + if (nf < npt && nf < maxfun) goto L50; +} + +// --------------------------------------------------------------------------- +// trsbox.f: SUBROUTINE TRSBOX +// --------------------------------------------------------------------------- +void trsbox(int n, int npt, double *xpt, double *xopt, double *gopt, + double *hq, double *pq, double *sl, double *su, double delta, + double *xnew, double *d, double *gnew, double *xbdi, double *s, + double *hs, double *hred, double &dsq, double &crvmin) { + double half, one, onemin, zero, delsq, qred, beta, stepsq, + gredsq = 0.0, resid, ds, shs, temp, blen, stplen, xsum, sdec, + ggsav = 0.0, dredsq = 0.0, dredg = 0.0, sredg = 0.0, angbd = 0.0, + tempa, tempb, ssq, xsav = 0.0, dhs, dhd, redmax, redsav, angt = 0.0, + sth, rednew, rdprev = 0.0, rdnext = 0.0, cth; + int iterc, nact, i, itermax = 0, iact = 0, itcsav = 0, isav, iu, ih, j, k; + + half = 0.5; + one = 1.0; + onemin = -1.0; + zero = 0.0; + // + // The sign of GOPT(I) gives the sign of the change to the I-th variable + // that will reduce Q from its value at XOPT. Thus XBDI(I) shows whether + // or not to fix the I-th variable at one of its bounds initially, with + // NACT being set to the number of fixed variables. D and GNEW are also + // set for the first iteration. DELSQ is the upper bound on the sum of + // squares of the free variables. QRED is the reduction in Q so far. + // + iterc = 0; + nact = 0; + for (i = 1; i <= n; i++) { + XBDI(i) = zero; + if (XOPT(i) <= SL(i)) { + if (GOPT(i) >= zero) XBDI(i) = onemin; + } else if (XOPT(i) >= SU(i)) { + if (GOPT(i) <= zero) XBDI(i) = one; + } + if (XBDI(i) != zero) nact = nact + 1; + D(i) = zero; + GNEW(i) = GOPT(i); + } + delsq = delta * delta; + qred = zero; + crvmin = onemin; + // + // Set the next search direction of the conjugate gradient method. It is + // the steepest descent direction initially and when the iterations are + // restarted because a variable has just been fixed by a bound, and of + // course the components of the fixed variables are zero. ITERMAX is an + // upper bound on the indices of the conjugate gradient iterations. + // +L20: + beta = zero; +L30: + stepsq = zero; + for (i = 1; i <= n; i++) { + if (XBDI(i) != zero) { + S(i) = zero; + } else if (beta == zero) { + S(i) = -GNEW(i); + } else { + S(i) = beta * S(i) - GNEW(i); + } + stepsq = stepsq + S(i) * S(i); + } + if (stepsq == zero) goto L190; + if (beta == zero) { + gredsq = stepsq; + itermax = iterc + n - nact; + } + if (gredsq * delsq <= 1.0e-4 * qred * qred) goto L190; + // + // Multiply the search direction by the second derivative matrix of Q + // and calculate some scalars for the choice of steplength. Then set + // BLEN to the length of the the step to the trust region boundary and + // STPLEN to the steplength, ignoring the simple bounds. + // + goto L210; +L50: + resid = delsq; + ds = zero; + shs = zero; + for (i = 1; i <= n; i++) { + if (XBDI(i) == zero) { + resid = resid - D(i) * D(i); + ds = ds + S(i) * D(i); + shs = shs + S(i) * HS(i); + } + } + if (resid <= zero) goto L90; + temp = std::sqrt(stepsq * resid + ds * ds); + if (ds < zero) { + blen = (temp - ds) / stepsq; + } else { + blen = resid / (temp + ds); + } + stplen = blen; + if (shs > zero) { + stplen = std::min(blen, gredsq / shs); + } + // + // Reduce STPLEN if necessary in order to preserve the simple bounds, + // letting IACT be the index of the new constrained variable. + // + iact = 0; + for (i = 1; i <= n; i++) { + if (S(i) != zero) { + xsum = XOPT(i) + D(i); + if (S(i) > zero) { + temp = (SU(i) - xsum) / S(i); + } else { + temp = (SL(i) - xsum) / S(i); + } + if (temp < stplen) { + stplen = temp; + iact = i; + } + } + } + // + // Update CRVMIN, GNEW and D. Set SDEC to the decrease that occurs in Q. + // + sdec = zero; + if (stplen > zero) { + iterc = iterc + 1; + temp = shs / stepsq; + if (iact == 0 && temp > zero) { + crvmin = std::min(crvmin, temp); + if (crvmin == onemin) crvmin = temp; + } + ggsav = gredsq; + gredsq = zero; + for (i = 1; i <= n; i++) { + GNEW(i) = GNEW(i) + stplen * HS(i); + if (XBDI(i) == zero) gredsq = gredsq + GNEW(i) * GNEW(i); + D(i) = D(i) + stplen * S(i); + } + sdec = std::max(stplen * (ggsav - half * stplen * shs), zero); + qred = qred + sdec; + } + // + // Restart the conjugate gradient method if it has hit a new bound. + // + if (iact > 0) { + nact = nact + 1; + XBDI(iact) = one; + if (S(iact) < zero) XBDI(iact) = onemin; + delsq = delsq - D(iact) * D(iact); + if (delsq <= zero) goto L90; + goto L20; + } + // + // If STPLEN is less than BLEN, then either apply another conjugate + // gradient iteration or RETURN. + // + if (stplen < blen) { + if (iterc == itermax) goto L190; + if (sdec <= 0.01 * qred) goto L190; + beta = gredsq / ggsav; + goto L30; + } +L90: + crvmin = zero; + // + // Prepare for the alternative iteration by calculating some scalars + // and by multiplying the reduced D by the second derivative matrix of + // Q, where S holds the reduced D in the call of GGMULT. + // +L100: + if (nact >= n - 1) goto L190; + dredsq = zero; + dredg = zero; + gredsq = zero; + for (i = 1; i <= n; i++) { + if (XBDI(i) == zero) { + dredsq = dredsq + D(i) * D(i); + dredg = dredg + D(i) * GNEW(i); + gredsq = gredsq + GNEW(i) * GNEW(i); + S(i) = D(i); + } else { + S(i) = zero; + } + } + itcsav = iterc; + goto L210; + // + // Let the search direction S be a linear combination of the reduced D + // and the reduced G that is orthogonal to the reduced D. + // +L120: + iterc = iterc + 1; + temp = gredsq * dredsq - dredg * dredg; + if (temp <= 1.0e-4 * qred * qred) goto L190; + temp = std::sqrt(temp); + for (i = 1; i <= n; i++) { + if (XBDI(i) == zero) { + S(i) = (dredg * D(i) - dredsq * GNEW(i)) / temp; + } else { + S(i) = zero; + } + } + sredg = -temp; + // + // By considering the simple bounds on the variables, calculate an upper + // bound on the tangent of half the angle of the alternative iteration, + // namely ANGBD, except that, if already a free variable has reached a + // bound, there is a branch back to label 100 after fixing that + // variable. + // + angbd = one; + iact = 0; + for (i = 1; i <= n; i++) { + if (XBDI(i) == zero) { + tempa = XOPT(i) + D(i) - SL(i); + tempb = SU(i) - XOPT(i) - D(i); + if (tempa <= zero) { + nact = nact + 1; + XBDI(i) = onemin; + goto L100; + } else if (tempb <= zero) { + nact = nact + 1; + XBDI(i) = one; + goto L100; + } + ssq = D(i) * D(i) + S(i) * S(i); + temp = ssq - (XOPT(i) - SL(i)) * (XOPT(i) - SL(i)); + if (temp > zero) { + temp = std::sqrt(temp) - S(i); + if (angbd * temp > tempa) { + angbd = tempa / temp; + iact = i; + xsav = onemin; + } + } + temp = ssq - (SU(i) - XOPT(i)) * (SU(i) - XOPT(i)); + if (temp > zero) { + temp = std::sqrt(temp) + S(i); + if (angbd * temp > tempb) { + angbd = tempb / temp; + iact = i; + xsav = one; + } + } + } + } + // + // Calculate HHD and some curvatures for the alternative iteration. + // + goto L210; +L150: + shs = zero; + dhs = zero; + dhd = zero; + for (i = 1; i <= n; i++) { + if (XBDI(i) == zero) { + shs = shs + S(i) * HS(i); + dhs = dhs + D(i) * HS(i); + dhd = dhd + D(i) * HRED(i); + } + } + // + // Seek the greatest reduction in Q for a range of equally spaced values + // of ANGT in [0,ANGBD], where ANGT is the tangent of half the angle of + // the alternative iteration. + // + redmax = zero; + isav = 0; + redsav = zero; + iu = static_cast(17.0 * angbd + 3.1); + for (i = 1; i <= iu; i++) { + angt = angbd * static_cast(i) / static_cast(iu); + sth = (angt + angt) / (one + angt * angt); + temp = shs + angt * (angt * dhd - dhs - dhs); + rednew = sth * (angt * dredg - sredg - half * sth * temp); + if (rednew > redmax) { + redmax = rednew; + isav = i; + rdprev = redsav; + } else if (i == isav + 1) { + rdnext = rednew; + } + redsav = rednew; + } + // + // Return if the reduction is zero. Otherwise, set the sine and cosine + // of the angle of the alternative iteration, and calculate SDEC. + // + if (isav == 0) goto L190; + if (isav < iu) { + temp = (rdnext - rdprev) / (redmax + redmax - rdprev - rdnext); + angt = angbd * (static_cast(isav) + half * temp) / + static_cast(iu); + } + cth = (one - angt * angt) / (one + angt * angt); + sth = (angt + angt) / (one + angt * angt); + temp = shs + angt * (angt * dhd - dhs - dhs); + sdec = sth * (angt * dredg - sredg - half * sth * temp); + if (sdec <= zero) goto L190; + // + // Update GNEW, D and HRED. If the angle of the alternative iteration + // is restricted by a bound on a free variable, that variable is fixed + // at the bound. + // + dredg = zero; + gredsq = zero; + for (i = 1; i <= n; i++) { + GNEW(i) = GNEW(i) + (cth - one) * HRED(i) + sth * HS(i); + if (XBDI(i) == zero) { + D(i) = cth * D(i) + sth * S(i); + dredg = dredg + D(i) * GNEW(i); + gredsq = gredsq + GNEW(i) * GNEW(i); + } + HRED(i) = cth * HRED(i) + sth * HS(i); + } + qred = qred + sdec; + if (iact > 0 && isav == iu) { + nact = nact + 1; + XBDI(iact) = xsav; + goto L100; + } + // + // If SDEC is sufficiently small, then RETURN after setting XNEW to + // XOPT+D, giving careful attention to the bounds. + // + if (sdec > 0.01 * qred) goto L120; +L190: + dsq = zero; + for (i = 1; i <= n; i++) { + XNEW(i) = std::max(std::min(XOPT(i) + D(i), SU(i)), SL(i)); + if (XBDI(i) == onemin) XNEW(i) = SL(i); + if (XBDI(i) == one) XNEW(i) = SU(i); + D(i) = XNEW(i) - XOPT(i); + dsq = dsq + D(i) * D(i); + } + return; + + // The following instructions multiply the current S-vector by the + // second derivative matrix of the quadratic model, putting the product + // in HS. They are reached from three different parts of the software + // above and they can be regarded as an external subroutine. + // +L210: + ih = 0; + for (j = 1; j <= n; j++) { + HS(j) = zero; + for (i = 1; i <= j; i++) { + ih = ih + 1; + if (i < j) HS(j) = HS(j) + HQ(ih) * S(i); + HS(i) = HS(i) + HQ(ih) * S(j); + } + } + for (k = 1; k <= npt; k++) { + if (PQ(k) != zero) { + temp = zero; + for (j = 1; j <= n; j++) { + temp = temp + XPT(k, j) * S(j); + } + temp = temp * PQ(k); + for (i = 1; i <= n; i++) { + HS(i) = HS(i) + temp * XPT(k, i); + } + } + } + if (crvmin != zero) goto L50; + if (iterc > itcsav) goto L150; + for (i = 1; i <= n; i++) { + HRED(i) = HS(i); + } + goto L120; +} + +// --------------------------------------------------------------------------- +// altmov.f: SUBROUTINE ALTMOV +// --------------------------------------------------------------------------- +void altmov(int n, int npt, double *xpt, double *xopt, double *bmat, + double *zmat, int ndim, double *sl, double *su, int kopt, + int knew, double adelt, double *xnew, double *xalt, + double &alpha, double &cauchy, double *glag, double *hcol, + double *w) { + double half, one, zero, cons, temp, ha, presav, dderiv, distsq, subd, + slbd, sumin, diff, step = 0.0, vlag, tempd, tempa, tempb, predsq, + stpsav = 0.0, bigstp, wfixsq, ggfree, wsqsav, gw, curv, scale, + csave = 0.0; + int k, j, i, ilbd, iubd, isbd, ksav, ibdsav, iflag; + + half = 0.5; + one = 1.0; + zero = 0.0; + cons = one + std::sqrt(2.0); + ksav = kopt; + for (k = 1; k <= npt; k++) { + HCOL(k) = zero; + } + for (j = 1; j <= npt - n - 1; j++) { + temp = ZMAT(knew, j); + for (k = 1; k <= npt; k++) { + HCOL(k) = HCOL(k) + temp * ZMAT(k, j); + } + } + alpha = HCOL(knew); + ha = half * alpha; + // + // Calculate the gradient of the KNEW-th Lagrange function at XOPT. + // + for (i = 1; i <= n; i++) { + GLAG(i) = BMAT(knew, i); + } + for (k = 1; k <= npt; k++) { + temp = zero; + for (j = 1; j <= n; j++) { + temp = temp + XPT(k, j) * XOPT(j); + } + temp = HCOL(k) * temp; + for (i = 1; i <= n; i++) { + GLAG(i) = GLAG(i) + temp * XPT(k, i); + } + } + // + // Search for a large denominator along the straight lines through XOPT + // and another interpolation point. SLBD and SUBD will be lower and + // upper bounds on the step along each of these lines in turn. PREDSQ + // will be set to the square of the predicted denominator for each line. + // PRESAV will be set to the largest admissible value of PREDSQ that + // occurs. + // + presav = zero; + for (k = 1; k <= npt; k++) { + if (k == kopt) continue; // GOTO 80 + dderiv = zero; + distsq = zero; + for (i = 1; i <= n; i++) { + temp = XPT(k, i) - XOPT(i); + dderiv = dderiv + GLAG(i) * temp; + distsq = distsq + temp * temp; + } + subd = adelt / std::sqrt(distsq); + slbd = -subd; + ilbd = 0; + iubd = 0; + sumin = std::min(one, subd); + // + // Revise SLBD and SUBD if necessary because of the bounds in SL and SU. + // + for (i = 1; i <= n; i++) { + temp = XPT(k, i) - XOPT(i); + if (temp > zero) { + if (slbd * temp < SL(i) - XOPT(i)) { + slbd = (SL(i) - XOPT(i)) / temp; + ilbd = -i; + } + if (subd * temp > SU(i) - XOPT(i)) { + subd = std::max(sumin, (SU(i) - XOPT(i)) / temp); + iubd = i; + } + } else if (temp < zero) { + if (slbd * temp > SU(i) - XOPT(i)) { + slbd = (SU(i) - XOPT(i)) / temp; + ilbd = i; + } + if (subd * temp < SL(i) - XOPT(i)) { + subd = std::max(sumin, (SL(i) - XOPT(i)) / temp); + iubd = -i; + } + } + } + // + // Seek a large modulus of the KNEW-th Lagrange function when the index + // of the other interpolation point on the line through XOPT is KNEW. + // + if (k == knew) { + diff = dderiv - one; + step = slbd; + vlag = slbd * (dderiv - slbd * diff); + isbd = ilbd; + temp = subd * (dderiv - subd * diff); + if (std::fabs(temp) > std::fabs(vlag)) { + step = subd; + vlag = temp; + isbd = iubd; + } + tempd = half * dderiv; + tempa = tempd - diff * slbd; + tempb = tempd - diff * subd; + if (tempa * tempb < zero) { + temp = tempd * tempd / diff; + if (std::fabs(temp) > std::fabs(vlag)) { + step = tempd / diff; + vlag = temp; + isbd = 0; + } + } + // + // Search along each of the other lines through XOPT and another + // point. + // + } else { + step = slbd; + vlag = slbd * (one - slbd); + isbd = ilbd; + temp = subd * (one - subd); + if (std::fabs(temp) > std::fabs(vlag)) { + step = subd; + vlag = temp; + isbd = iubd; + } + if (subd > half) { + if (std::fabs(vlag) < 0.25) { + step = half; + vlag = 0.25; + isbd = 0; + } + } + vlag = vlag * dderiv; + } + // + // Calculate PREDSQ for the current line search and maintain PRESAV. + // + temp = step * (one - step) * distsq; + predsq = vlag * vlag * (vlag * vlag + ha * temp * temp); + if (predsq > presav) { + presav = predsq; + ksav = k; + stpsav = step; + ibdsav = isbd; + } + } + // + // Construct XNEW in a way that satisfies the bound constraints exactly. + // + ibdsav = 0; + for (i = 1; i <= n; i++) { + temp = XOPT(i) + stpsav * (XPT(ksav, i) - XOPT(i)); + XNEW(i) = std::max(SL(i), std::min(SU(i), temp)); + } + if (ibdsav < 0) XNEW(-ibdsav) = SL(-ibdsav); + if (ibdsav > 0) XNEW(ibdsav) = SU(ibdsav); + // + // Prepare for the iterative method that assembles the constrained + // Cauchy step in W. The sum of squares of the fixed components of W is + // formed in WFIXSQ, and the free components of W are set to BIGSTP. + // + bigstp = adelt + adelt; + iflag = 0; +L100: + wfixsq = zero; + ggfree = zero; + for (i = 1; i <= n; i++) { + W(i) = zero; + tempa = std::min(XOPT(i) - SL(i), GLAG(i)); + tempb = std::max(XOPT(i) - SU(i), GLAG(i)); + if (tempa > zero || tempb < zero) { + W(i) = bigstp; + ggfree = ggfree + GLAG(i) * GLAG(i); + } + } + if (ggfree == zero) { + cauchy = zero; + return; // GOTO 200 + } + // + // Investigate whether more components of W can be fixed. + // +L120: + temp = adelt * adelt - wfixsq; + if (temp > zero) { + wsqsav = wfixsq; + step = std::sqrt(temp / ggfree); + ggfree = zero; + for (i = 1; i <= n; i++) { + if (W(i) == bigstp) { + temp = XOPT(i) - step * GLAG(i); + if (temp <= SL(i)) { + W(i) = SL(i) - XOPT(i); + wfixsq = wfixsq + W(i) * W(i); + } else if (temp >= SU(i)) { + W(i) = SU(i) - XOPT(i); + wfixsq = wfixsq + W(i) * W(i); + } else { + ggfree = ggfree + GLAG(i) * GLAG(i); + } + } + } + if (wfixsq > wsqsav && ggfree > zero) goto L120; + } + // + // Set the remaining free components of W and all components of XALT, + // except that W may be scaled later. + // + gw = zero; + for (i = 1; i <= n; i++) { + if (W(i) == bigstp) { + W(i) = -step * GLAG(i); + XALT(i) = std::max(SL(i), std::min(SU(i), XOPT(i) + W(i))); + } else if (W(i) == zero) { + XALT(i) = XOPT(i); + } else if (GLAG(i) > zero) { + XALT(i) = SL(i); + } else { + XALT(i) = SU(i); + } + gw = gw + GLAG(i) * W(i); + } + // + // Set CURV to the curvature of the KNEW-th Lagrange function along W. + // Scale W by a factor less than one if that can reduce the modulus of + // the Lagrange function at XOPT+W. Set CAUCHY to the final value of + // the square of this function. + // + curv = zero; + for (k = 1; k <= npt; k++) { + temp = zero; + for (j = 1; j <= n; j++) { + temp = temp + XPT(k, j) * W(j); + } + curv = curv + HCOL(k) * temp * temp; + } + if (iflag == 1) curv = -curv; + if (curv > -gw && curv < -cons * gw) { + scale = -gw / curv; + for (i = 1; i <= n; i++) { + temp = XOPT(i) + scale * W(i); + XALT(i) = std::max(SL(i), std::min(SU(i), temp)); + } + cauchy = (half * gw * scale) * (half * gw * scale); + } else { + cauchy = (gw + half * curv) * (gw + half * curv); + } + // + // If IFLAG is zero, then XALT is calculated as before after reversing + // the sign of GLAG. Thus two XALT vectors become available. The one + // that is chosen is the one that gives the larger value of CAUCHY. + // + if (iflag == 0) { + for (i = 1; i <= n; i++) { + GLAG(i) = -GLAG(i); + W(n + i) = XALT(i); + } + csave = cauchy; + iflag = 1; + goto L100; + } + if (csave > cauchy) { + for (i = 1; i <= n; i++) { + XALT(i) = W(n + i); + } + cauchy = csave; + } +} + +// --------------------------------------------------------------------------- +// rescue.f: SUBROUTINE RESCUE +// --------------------------------------------------------------------------- +void rescue(int n, int npt, const double *xl, const double *xu, int maxfun, + double *xbase, double *xpt, double *fval, double *xopt, + double *gopt, double *hq, double *pq, double *bmat, double *zmat, + int ndim, double *sl, double *su, int &nf, double delta, + int &kopt, double *vlag, double *ptsaux, double *ptsid, double *w, + MinqaCalfun &calfun) { + double half, one, zero, sfrac, sumpq, winc, distsq, temp, fbase, + beta = 0.0, denom = 0.0, dsqmin, sum, bsum, vlmxsq, hdiag, den, + xp = 0.0, xq = 0.0, vquad, f, diff; + int np, nptm, k, j, ih, i, jp, jpn, iw, ip, iq, nrem, kold, knew, kpt, + ihp = 0, ihq; + + MINQA_BOBYQA_RESCUE_HOOK(); + half = 0.5; + one = 1.0; + zero = 0.0; + np = n + 1; + sfrac = half / static_cast(np); + nptm = npt - np; + // + // Shift the interpolation points so that XOPT becomes the origin, and + // set the elements of ZMAT to zero. The value of SUMPQ is required in + // the updating of HQ below. The squares of the distances from XOPT to + // the other interpolation points are set at the end of W. Increments + // of WINC may be added later to these squares to balance the + // consideration of the choice of point that is going to become current. + // + sumpq = zero; + winc = zero; + for (k = 1; k <= npt; k++) { + distsq = zero; + for (j = 1; j <= n; j++) { + XPT(k, j) = XPT(k, j) - XOPT(j); + distsq = distsq + XPT(k, j) * XPT(k, j); + } + sumpq = sumpq + PQ(k); + W(ndim + k) = distsq; + winc = std::max(winc, distsq); + for (j = 1; j <= nptm; j++) { + ZMAT(k, j) = zero; + } + } + // + // Update HQ so that HQ and PQ define the second derivatives of the + // model after XBASE has been shifted to the trust region centre. + // + ih = 0; + for (j = 1; j <= n; j++) { + W(j) = half * sumpq * XOPT(j); + for (k = 1; k <= npt; k++) { + W(j) = W(j) + PQ(k) * XPT(k, j); + } + for (i = 1; i <= j; i++) { + ih = ih + 1; + HQ(ih) = HQ(ih) + W(i) * XOPT(j) + W(j) * XOPT(i); + } + } + // + // Shift XBASE, SL, SU and XOPT. Set the elements of BMAT to zero, and + // also set the elements of PTSAUX. + // + for (j = 1; j <= n; j++) { + XBASE(j) = XBASE(j) + XOPT(j); + SL(j) = SL(j) - XOPT(j); + SU(j) = SU(j) - XOPT(j); + XOPT(j) = zero; + PTSAUX(1, j) = std::min(delta, SU(j)); + PTSAUX(2, j) = std::max(-delta, SL(j)); + if (PTSAUX(1, j) + PTSAUX(2, j) < zero) { + temp = PTSAUX(1, j); + PTSAUX(1, j) = PTSAUX(2, j); + PTSAUX(2, j) = temp; + } + if (std::fabs(PTSAUX(2, j)) < half * std::fabs(PTSAUX(1, j))) { + PTSAUX(2, j) = half * PTSAUX(1, j); + } + for (i = 1; i <= ndim; i++) { + BMAT(i, j) = zero; + } + } + fbase = FVAL(kopt); + // + // Set the identifiers of the artificial interpolation points that are + // along a coordinate direction from XOPT, and set the corresponding + // nonzero elements of BMAT and ZMAT. + // + PTSID(1) = sfrac; + for (j = 1; j <= n; j++) { + jp = j + 1; + jpn = jp + n; + PTSID(jp) = static_cast(j) + sfrac; + if (jpn <= npt) { + PTSID(jpn) = static_cast(j) / static_cast(np) + sfrac; + temp = one / (PTSAUX(1, j) - PTSAUX(2, j)); + BMAT(jp, j) = -temp + one / PTSAUX(1, j); + BMAT(jpn, j) = temp + one / PTSAUX(2, j); + BMAT(1, j) = -BMAT(jp, j) - BMAT(jpn, j); + ZMAT(1, j) = std::sqrt(2.0) / std::fabs(PTSAUX(1, j) * PTSAUX(2, j)); + ZMAT(jp, j) = ZMAT(1, j) * PTSAUX(2, j) * temp; + ZMAT(jpn, j) = -ZMAT(1, j) * PTSAUX(1, j) * temp; + } else { + BMAT(1, j) = -one / PTSAUX(1, j); + BMAT(jp, j) = one / PTSAUX(1, j); + BMAT(j + npt, j) = -half * (PTSAUX(1, j) * PTSAUX(1, j)); + } + } + // + // Set any remaining identifiers with their nonzero elements of ZMAT. + // + if (npt >= n + np) { + for (k = 2 * np; k <= npt; k++) { + iw = static_cast((static_cast(k - np) - half) / + static_cast(n)); + ip = k - np - iw * n; + iq = ip + iw; + if (iq > n) iq = iq - n; + PTSID(k) = static_cast(ip) + + static_cast(iq) / static_cast(np) + sfrac; + temp = one / (PTSAUX(1, ip) * PTSAUX(1, iq)); + ZMAT(1, k - np) = temp; + ZMAT(ip + 1, k - np) = -temp; + ZMAT(iq + 1, k - np) = -temp; + ZMAT(k, k - np) = temp; + } + } + nrem = npt; + kold = 1; + knew = kopt; + // + // Reorder the provisional points in the way that exchanges PTSID(KOLD) + // with PTSID(KNEW). + // +L80: + for (j = 1; j <= n; j++) { + temp = BMAT(kold, j); + BMAT(kold, j) = BMAT(knew, j); + BMAT(knew, j) = temp; + } + for (j = 1; j <= nptm; j++) { + temp = ZMAT(kold, j); + ZMAT(kold, j) = ZMAT(knew, j); + ZMAT(knew, j) = temp; + } + PTSID(kold) = PTSID(knew); + PTSID(knew) = zero; + W(ndim + knew) = zero; + nrem = nrem - 1; + if (knew != kopt) { + temp = VLAG(kold); + VLAG(kold) = VLAG(knew); + VLAG(knew) = temp; + // + // Update the BMAT and ZMAT matrices so that the status of the KNEW-th + // interpolation point can be changed from provisional to original. + // The branch to label 350 occurs if all the original points are + // reinstated. The nonnegative values of W(NDIM+K) are required in + // the search below. + // + updatebobyqa(n, npt, bmat, zmat, ndim, vlag, beta, denom, knew, w); + if (nrem == 0) return; // GOTO 350 + for (k = 1; k <= npt; k++) { + W(ndim + k) = std::fabs(W(ndim + k)); + } + } + // + // Pick the index KNEW of an original interpolation point that has not + // yet replaced one of the provisional interpolation points, giving + // attention to the closeness to XOPT and to previous tries with KNEW. + // +L120: + dsqmin = zero; + for (k = 1; k <= npt; k++) { + if (W(ndim + k) > zero) { + if (dsqmin == zero || W(ndim + k) < dsqmin) { + knew = k; + dsqmin = W(ndim + k); + } + } + } + if (dsqmin == zero) goto L260; + // + // Form the W-vector of the chosen original interpolation point. + // + for (j = 1; j <= n; j++) { + W(npt + j) = XPT(knew, j); + } + for (k = 1; k <= npt; k++) { + sum = zero; + if (k == kopt) { + // CONTINUE + } else if (PTSID(k) == zero) { + for (j = 1; j <= n; j++) { + sum = sum + W(npt + j) * XPT(k, j); + } + } else { + ip = static_cast(PTSID(k)); + if (ip > 0) sum = W(npt + ip) * PTSAUX(1, ip); + iq = static_cast(static_cast(np) * PTSID(k) - + static_cast(ip * np)); + if (iq > 0) { + iw = 1; + if (ip == 0) iw = 2; + sum = sum + W(npt + iq) * PTSAUX(iw, iq); + } + } + W(k) = half * sum * sum; + } + // + // Calculate VLAG and BETA for the required updating of the H matrix if + // XPT(KNEW,.) is reinstated in the set of interpolation points. + // + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= n; j++) { + sum = sum + BMAT(k, j) * W(npt + j); + } + VLAG(k) = sum; + } + beta = zero; + for (j = 1; j <= nptm; j++) { + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + ZMAT(k, j) * W(k); + } + beta = beta - sum * sum; + for (k = 1; k <= npt; k++) { + VLAG(k) = VLAG(k) + sum * ZMAT(k, j); + } + } + bsum = zero; + distsq = zero; + for (j = 1; j <= n; j++) { + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + BMAT(k, j) * W(k); + } + jp = j + npt; + bsum = bsum + sum * W(jp); + for (ip = npt + 1; ip <= ndim; ip++) { + sum = sum + BMAT(ip, j) * W(ip); + } + bsum = bsum + sum * W(jp); + VLAG(jp) = sum; + distsq = distsq + XPT(knew, j) * XPT(knew, j); + } + beta = half * distsq * distsq + beta - bsum; + VLAG(kopt) = VLAG(kopt) + one; + // + // KOLD is set to the index of the provisional interpolation point that + // is going to be deleted to make way for the KNEW-th original + // interpolation point. The choice of KOLD is governed by the avoidance + // of a small value of the denominator in the updating calculation of + // UPDATE. + // + denom = zero; + vlmxsq = zero; + for (k = 1; k <= npt; k++) { + if (PTSID(k) != zero) { + hdiag = zero; + for (j = 1; j <= nptm; j++) { + hdiag = hdiag + ZMAT(k, j) * ZMAT(k, j); + } + den = beta * hdiag + VLAG(k) * VLAG(k); + if (den > denom) { + kold = k; + denom = den; + } + } + vlmxsq = std::max(vlmxsq, VLAG(k) * VLAG(k)); + } + if (denom <= 1.0e-2 * vlmxsq) { + W(ndim + knew) = -W(ndim + knew) - winc; + goto L120; + } + goto L80; + // + // When label 260 is reached, all the final positions of the + // interpolation points have been chosen although any changes have not + // been included yet in XPT. Also the final BMAT and ZMAT matrices are + // complete, but, apart from the shift of XBASE, the updating of the + // quadratic model remains to be done. The following cycle through the + // new interpolation points begins by putting the new point in + // XPT(KPT,.) and by setting PQ(KPT) to zero, except that a RETURN + // occurs if MAXFUN prohibits another value of F. + // +L260: + for (kpt = 1; kpt <= npt; kpt++) { + if (PTSID(kpt) == zero) continue; // GOTO 340 + if (nf >= maxfun) { + nf = -1; + return; // GOTO 350 + } + ih = 0; + for (j = 1; j <= n; j++) { + W(j) = XPT(kpt, j); + XPT(kpt, j) = zero; + temp = PQ(kpt) * W(j); + for (i = 1; i <= j; i++) { + ih = ih + 1; + HQ(ih) = HQ(ih) + temp * W(i); + } + } + PQ(kpt) = zero; + ip = static_cast(PTSID(kpt)); + iq = static_cast(static_cast(np) * PTSID(kpt) - + static_cast(ip * np)); + if (ip > 0) { + xp = PTSAUX(1, ip); + XPT(kpt, ip) = xp; + } + if (iq > 0) { + xq = PTSAUX(1, iq); + if (ip == 0) xq = PTSAUX(2, iq); + XPT(kpt, iq) = xq; + } + // + // Set VQUAD to the value of the current model at the new point. + // + vquad = fbase; + if (ip > 0) { + ihp = (ip + ip * ip) / 2; + vquad = vquad + xp * (GOPT(ip) + half * xp * HQ(ihp)); + } + if (iq > 0) { + ihq = (iq + iq * iq) / 2; + vquad = vquad + xq * (GOPT(iq) + half * xq * HQ(ihq)); + if (ip > 0) { + iw = std::max(ihp, ihq) - std::abs(ip - iq); + vquad = vquad + xp * xq * HQ(iw); + } + } + for (k = 1; k <= npt; k++) { + temp = zero; + if (ip > 0) temp = temp + xp * XPT(k, ip); + if (iq > 0) temp = temp + xq * XPT(k, iq); + vquad = vquad + half * PQ(k) * temp * temp; + } + // + // Calculate F at the new interpolation point, and set DIFF to the + // factor that is going to multiply the KPT-th Lagrange function when + // the model is updated to provide interpolation to the new function + // value. + // + for (i = 1; i <= n; i++) { + W(i) = std::min(std::max(XL(i), XBASE(i) + XPT(kpt, i)), XU(i)); + if (XPT(kpt, i) == SL(i)) W(i) = XL(i); + if (XPT(kpt, i) == SU(i)) W(i) = XU(i); + } + nf = nf + 1; + // minqa: F = CALFUN (N,X,IPRINT) with X undefined; Powell: CALFUN(N,W,F) + f = calfun(w); + FVAL(kpt) = f; + if (f < FVAL(kopt)) kopt = kpt; + diff = f - vquad; + // + // Update the quadratic model. The RETURN from the subroutine occurs + // when all the new interpolation points are included in the model. + // + for (i = 1; i <= n; i++) { + GOPT(i) = GOPT(i) + diff * BMAT(kpt, i); + } + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= nptm; j++) { + sum = sum + ZMAT(k, j) * ZMAT(kpt, j); + } + temp = diff * sum; + if (PTSID(k) == zero) { + PQ(k) = PQ(k) + temp; + } else { + ip = static_cast(PTSID(k)); + iq = static_cast(static_cast(np) * PTSID(k) - + static_cast(ip * np)); + ihq = (iq * iq + iq) / 2; + if (ip == 0) { + HQ(ihq) = HQ(ihq) + temp * (PTSAUX(2, iq) * PTSAUX(2, iq)); + } else { + ihp = (ip * ip + ip) / 2; + HQ(ihp) = HQ(ihp) + temp * (PTSAUX(1, ip) * PTSAUX(1, ip)); + if (iq > 0) { + HQ(ihq) = HQ(ihq) + temp * (PTSAUX(1, iq) * PTSAUX(1, iq)); + iw = std::max(ihp, ihq) - std::abs(iq - ip); + HQ(iw) = HQ(iw) + temp * PTSAUX(1, ip) * PTSAUX(1, iq); + } + } + } + } + PTSID(kpt) = zero; + } +} + +// --------------------------------------------------------------------------- +// bobyqb.f: SUBROUTINE BOBYQB +// --------------------------------------------------------------------------- +void bobyqb(int n, int npt, double *x, const double *xl, const double *xu, + double rhobeg, double rhoend, int maxfun, double *xbase, + double *xpt, double *fval, double *xopt, double *gopt, double *hq, + double *pq, double *bmat, double *zmat, int ndim, double *sl, + double *su, double *xnew, double *xalt, double *d, double *vlag, + double *w, int &ierr, MinqaCalfun &calfun) { + double half, one, ten, tenth, two, zero, xoptsq, fsave, rho, delta, diffa, + diffb, diffc = 0.0, temp, dsq = 0.0, crvmin = 0.0, dnorm = 0.0, distsq, + errbig, frhosq, bdtol, bdtest, curv, fracsq, sumpq, sum, sumz, sumw, + adelt = 0.0, alpha = 0.0, cauchy = 0.0, suma, sumb, beta = 0.0, bsum, + dx, denom = 0.0, delsq, scaden, biglsq, hdiag, den, f = 0.0, fopt = 0.0, + vquad = 0.0, diff = 0.0, ratio = 0.0, densav, pqold, gqsq, gisq, dist; + int np, nptm, nh, nf = 0, kopt = 0, i, kbase, nresc, ntrits, itest, nfsav, + ih, j, k, jj, ip, jp, knew = 0, ksav; + + half = 0.5; + one = 1.0; + ten = 10.0; + tenth = 0.1; + two = 2.0; + zero = 0.0; + np = n + 1; + nptm = npt - np; + nh = (n * np) / 2; + // + // The call of PRELIM sets the elements of XBASE, XPT, FVAL, GOPT, HQ, + // PQ, BMAT and ZMAT for the first iteration, with the corresponding + // values of of NF and KOPT, which are the number of calls of CALFUN so + // far and the index of the interpolation point at the trust region + // centre. Then the initial XOPT is set too. The branch to label 720 + // occurs if MAXFUN is less than NPT. GOPT will be updated if KOPT is + // different from KBASE. + // + prelim(n, npt, x, xl, xu, rhobeg, maxfun, xbase, xpt, fval, gopt, hq, pq, + bmat, zmat, ndim, sl, su, nf, kopt, calfun); + xoptsq = zero; + for (i = 1; i <= n; i++) { + XOPT(i) = XPT(kopt, i); + xoptsq = xoptsq + XOPT(i) * XOPT(i); + } + fsave = FVAL(1); + if (nf < npt) { + ierr = 390; + goto L720; + } + kbase = 1; + // + // Complete the settings that are required for the iterative procedure. + // + rho = rhobeg; + delta = rho; + nresc = nf; + ntrits = 0; + diffa = zero; + diffb = zero; + itest = 0; + nfsav = nf; + // + // Update GOPT if necessary before the first iteration and after each + // call of RESCUE that makes a call of CALFUN. + // +L20: + if (kopt != kbase) { + ih = 0; + for (j = 1; j <= n; j++) { + for (i = 1; i <= j; i++) { + ih = ih + 1; + if (i < j) GOPT(j) = GOPT(j) + HQ(ih) * XOPT(i); + GOPT(i) = GOPT(i) + HQ(ih) * XOPT(j); + } + } + if (nf > npt) { + for (k = 1; k <= npt; k++) { + temp = zero; + for (j = 1; j <= n; j++) { + temp = temp + XPT(k, j) * XOPT(j); + } + temp = PQ(k) * temp; + for (i = 1; i <= n; i++) { + GOPT(i) = GOPT(i) + temp * XPT(k, i); + } + } + } + } + // + // Generate the next point in the trust region that provides a small + // value of the quadratic model subject to the constraints on the + // variables. The integer NTRITS is set to the number "trust region" + // iterations that have occurred since the last "alternative" iteration. + // If the length of XNEW-XOPT is less than HALF*RHO, however, then there + // is a branch to label 650 or 680 with NTRITS=-1, instead of + // calculating F at XNEW. + // +L60: + trsbox(n, npt, xpt, xopt, gopt, hq, pq, sl, su, delta, xnew, d, w, + &W(np), &W(np + n), &W(np + 2 * n), &W(np + 3 * n), dsq, crvmin); + dnorm = std::min(delta, std::sqrt(dsq)); + if (dnorm < half * rho) { + ntrits = -1; + distsq = (ten * rho) * (ten * rho); + if (nf <= nfsav + 2) goto L650; + // + // The following choice between labels 650 and 680 depends on whether + // or not our work with the current RHO seems to be complete. Either + // RHO is decreased or termination occurs if the errors in the + // quadratic model at the last three interpolation points compare + // favourably with predictions of likely improvements to the model + // within distance HALF*RHO of XOPT. + // + errbig = std::max(std::max(diffa, diffb), diffc); + frhosq = 0.125 * rho * rho; + if (crvmin > zero && errbig > frhosq * crvmin) goto L650; + bdtol = errbig / rho; + for (j = 1; j <= n; j++) { + bdtest = bdtol; + if (XNEW(j) == SL(j)) bdtest = W(j); + if (XNEW(j) == SU(j)) bdtest = -W(j); + if (bdtest < bdtol) { + curv = HQ((j + j * j) / 2); + for (k = 1; k <= npt; k++) { + curv = curv + PQ(k) * (XPT(k, j) * XPT(k, j)); + } + bdtest = bdtest + half * curv * rho; + if (bdtest < bdtol) goto L650; + } + } + goto L680; + } + ntrits = ntrits + 1; + // + // Severe cancellation is likely to occur if XOPT is too far from XBASE. + // If the following test holds, then XBASE is shifted so that XOPT + // becomes zero. The appropriate changes are made to BMAT and to the + // second derivatives of the current model, beginning with the changes + // to BMAT that do not depend on ZMAT. VLAG is used temporarily for + // working space. + // +L90: + if (dsq <= 1.0e-3 * xoptsq) { + fracsq = 0.25 * xoptsq; + sumpq = zero; + for (k = 1; k <= npt; k++) { + sumpq = sumpq + PQ(k); + sum = -half * xoptsq; + for (i = 1; i <= n; i++) { + sum = sum + XPT(k, i) * XOPT(i); + } + W(npt + k) = sum; + temp = fracsq - half * sum; + for (i = 1; i <= n; i++) { + W(i) = BMAT(k, i); + VLAG(i) = sum * XPT(k, i) + temp * XOPT(i); + ip = npt + i; + for (j = 1; j <= i; j++) { + BMAT(ip, j) = BMAT(ip, j) + W(i) * VLAG(j) + VLAG(i) * W(j); + } + } + } + // + // Then the revisions of BMAT that depend on ZMAT are calculated. + // + for (jj = 1; jj <= nptm; jj++) { + sumz = zero; + sumw = zero; + for (k = 1; k <= npt; k++) { + sumz = sumz + ZMAT(k, jj); + VLAG(k) = W(npt + k) * ZMAT(k, jj); + sumw = sumw + VLAG(k); + } + for (j = 1; j <= n; j++) { + sum = (fracsq * sumz - half * sumw) * XOPT(j); + for (k = 1; k <= npt; k++) { + sum = sum + VLAG(k) * XPT(k, j); + } + W(j) = sum; + for (k = 1; k <= npt; k++) { + BMAT(k, j) = BMAT(k, j) + sum * ZMAT(k, jj); + } + } + for (i = 1; i <= n; i++) { + ip = i + npt; + temp = W(i); + for (j = 1; j <= i; j++) { + BMAT(ip, j) = BMAT(ip, j) + temp * W(j); + } + } + } + // + // The following instructions complete the shift, including the + // changes to the second derivative parameters of the quadratic model. + // + ih = 0; + for (j = 1; j <= n; j++) { + W(j) = -half * sumpq * XOPT(j); + for (k = 1; k <= npt; k++) { + W(j) = W(j) + PQ(k) * XPT(k, j); + XPT(k, j) = XPT(k, j) - XOPT(j); + } + for (i = 1; i <= j; i++) { + ih = ih + 1; + HQ(ih) = HQ(ih) + W(i) * XOPT(j) + XOPT(i) * W(j); + BMAT(npt + i, j) = BMAT(npt + j, i); + } + } + for (i = 1; i <= n; i++) { + XBASE(i) = XBASE(i) + XOPT(i); + XNEW(i) = XNEW(i) - XOPT(i); + SL(i) = SL(i) - XOPT(i); + SU(i) = SU(i) - XOPT(i); + XOPT(i) = zero; + } + xoptsq = zero; + } + if (ntrits == 0) goto L210; + goto L230; + // + // XBASE is also moved to XOPT by a call of RESCUE. This calculation is + // more expensive than the previous shift, because new matrices BMAT and + // ZMAT are generated from scratch, which may include the replacement of + // interpolation points whose positions seem to be causing near linear + // dependence in the interpolation conditions. Therefore RESCUE is + // called only if rounding errors have reduced by at least a factor of + // two the denominator of the formula for updating the H matrix. It + // provides a useful safeguard, but is not invoked in most applications + // of BOBYQA. + // +L190: + nfsav = nf; + kbase = kopt; + rescue(n, npt, xl, xu, maxfun, xbase, xpt, fval, xopt, gopt, hq, pq, bmat, + zmat, ndim, sl, su, nf, delta, kopt, vlag, w, &W(n + np), + &W(ndim + np), calfun); + // + // XOPT is updated now in case the branch below to label 720 is taken. + // Any updating of GOPT occurs after the branch below to label 20, which + // leads to a trust region iteration as does the branch to label 60. + // + xoptsq = zero; + if (kopt != kbase) { + for (i = 1; i <= n; i++) { + XOPT(i) = XPT(kopt, i); + xoptsq = xoptsq + XOPT(i) * XOPT(i); + } + } + if (nf < 0) { + nf = maxfun; + ierr = 390; + goto L720; + } + nresc = nf; + if (nfsav < nf) { + nfsav = nf; + goto L20; + } + if (ntrits > 0) goto L60; + // + // Pick two alternative vectors of variables, relative to XBASE, that + // are suitable as new positions of the KNEW-th interpolation point. + // Firstly, XNEW is set to the point on a line through XOPT and another + // interpolation point that minimizes the predicted value of the next + // denominator, subject to ||XNEW - XOPT|| .LEQ. ADELT and to the SL + // and SU bounds. Secondly, XALT is set to the best feasible point on + // a constrained version of the Cauchy step of the KNEW-th Lagrange + // function, the corresponding value of the square of this function + // being returned in CAUCHY. The choice between these alternatives is + // going to be made when the denominator is calculated. + // +L210: + altmov(n, npt, xpt, xopt, bmat, zmat, ndim, sl, su, kopt, knew, adelt, xnew, + xalt, alpha, cauchy, w, &W(np), &W(ndim + 1)); + for (i = 1; i <= n; i++) { + D(i) = XNEW(i) - XOPT(i); + } + // + // Calculate VLAG and BETA for the current choice of D. The scalar + // product of D with XPT(K,.) is going to be held in W(NPT+K) for + // use when VQUAD is calculated. + // +L230: + for (k = 1; k <= npt; k++) { + suma = zero; + sumb = zero; + sum = zero; + for (j = 1; j <= n; j++) { + suma = suma + XPT(k, j) * D(j); + sumb = sumb + XPT(k, j) * XOPT(j); + sum = sum + BMAT(k, j) * D(j); + } + W(k) = suma * (half * suma + sumb); + VLAG(k) = sum; + W(npt + k) = suma; + } + beta = zero; + for (jj = 1; jj <= nptm; jj++) { + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + ZMAT(k, jj) * W(k); + } + beta = beta - sum * sum; + for (k = 1; k <= npt; k++) { + VLAG(k) = VLAG(k) + sum * ZMAT(k, jj); + } + } + dsq = zero; + bsum = zero; + dx = zero; + for (j = 1; j <= n; j++) { + dsq = dsq + D(j) * D(j); + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + W(k) * BMAT(k, j); + } + bsum = bsum + sum * D(j); + jp = npt + j; + for (i = 1; i <= n; i++) { + sum = sum + BMAT(jp, i) * D(i); + } + VLAG(jp) = sum; + bsum = bsum + sum * D(j); + dx = dx + D(j) * XOPT(j); + } + beta = dx * dx + dsq * (xoptsq + dx + dx + half * dsq) + beta - bsum; + VLAG(kopt) = VLAG(kopt) + one; + // + // If NTRITS is zero, the denominator may be increased by replacing + // the step D of ALTMOV by a Cauchy step. Then RESCUE may be called if + // rounding errors have damaged the chosen denominator. + // + if (ntrits == 0) { + denom = VLAG(knew) * VLAG(knew) + alpha * beta; + if (denom < cauchy && cauchy > zero) { + for (i = 1; i <= n; i++) { + XNEW(i) = XALT(i); + D(i) = XNEW(i) - XOPT(i); + } + cauchy = zero; + goto L230; + } + if (denom <= half * (VLAG(knew) * VLAG(knew))) { + if (nf > nresc) goto L190; + ierr = 320; + goto L720; + } + // + // Alternatively, if NTRITS is positive, then set KNEW to the index of + // the next interpolation point to be deleted to make room for a trust + // region step. Again RESCUE may be called if rounding errors have + // damaged the chosen denominator, which is the reason for attempting + // to select KNEW before calculating the next value of the objective + // function. + // + } else { + delsq = delta * delta; + scaden = zero; + biglsq = zero; + knew = 0; + for (k = 1; k <= npt; k++) { + if (k == kopt) continue; // GOTO 350 + hdiag = zero; + for (jj = 1; jj <= nptm; jj++) { + hdiag = hdiag + ZMAT(k, jj) * ZMAT(k, jj); + } + den = beta * hdiag + VLAG(k) * VLAG(k); + distsq = zero; + for (j = 1; j <= n; j++) { + distsq = distsq + (XPT(k, j) - XOPT(j)) * (XPT(k, j) - XOPT(j)); + } + temp = std::max(one, (distsq / delsq) * (distsq / delsq)); + if (temp * den > scaden) { + scaden = temp * den; + knew = k; + denom = den; + } + biglsq = std::max(biglsq, temp * (VLAG(k) * VLAG(k))); + } + if (scaden <= half * biglsq) { + if (nf > nresc) goto L190; + ierr = 320; + goto L720; + } + } + // + // Put the variables for the next calculation of the objective function + // in XNEW, with any adjustments for the bounds. + // + // + // Calculate the value of the objective function at XBASE+XNEW, unless + // the limit on the number of calculations of F has been reached. + // +L360: + for (i = 1; i <= n; i++) { + X(i) = std::min(std::max(XL(i), XBASE(i) + XNEW(i)), XU(i)); + if (XNEW(i) == SL(i)) X(i) = XL(i); + if (XNEW(i) == SU(i)) X(i) = XU(i); + } + if (nf >= maxfun) { + ierr = 390; + goto L720; + } + nf = nf + 1; + f = calfun(x); + if (ntrits == -1) { + fsave = f; + goto L720; + } + // + // Use the quadratic model to predict the change in F due to the step D, + // and set DIFF to the error of this prediction. + // + fopt = FVAL(kopt); + vquad = zero; + ih = 0; + for (j = 1; j <= n; j++) { + vquad = vquad + D(j) * GOPT(j); + for (i = 1; i <= j; i++) { + ih = ih + 1; + temp = D(i) * D(j); + if (i == j) temp = half * temp; + vquad = vquad + HQ(ih) * temp; + } + } + for (k = 1; k <= npt; k++) { + vquad = vquad + half * PQ(k) * (W(npt + k) * W(npt + k)); + } + diff = f - fopt - vquad; + diffc = diffb; + diffb = diffa; + diffa = std::fabs(diff); + if (dnorm > rho) nfsav = nf; + // + // Pick the next value of DELTA after a trust region step. + // + if (ntrits > 0) { + if (vquad >= zero) { + ierr = 430; + goto L720; + } + ratio = (f - fopt) / vquad; + if (ratio <= tenth) { + delta = std::min(half * delta, dnorm); + } else if (ratio <= 0.7) { + delta = std::max(half * delta, dnorm); + } else { + delta = std::max(half * delta, dnorm + dnorm); + } + if (delta <= 1.5 * rho) delta = rho; + // + // Recalculate KNEW and DENOM if the new F is less than FOPT. + // + if (f < fopt) { + ksav = knew; + densav = denom; + delsq = delta * delta; + scaden = zero; + biglsq = zero; + knew = 0; + for (k = 1; k <= npt; k++) { + hdiag = zero; + for (jj = 1; jj <= nptm; jj++) { + hdiag = hdiag + ZMAT(k, jj) * ZMAT(k, jj); + } + den = beta * hdiag + VLAG(k) * VLAG(k); + distsq = zero; + for (j = 1; j <= n; j++) { + distsq = distsq + (XPT(k, j) - XNEW(j)) * (XPT(k, j) - XNEW(j)); + } + temp = std::max(one, (distsq / delsq) * (distsq / delsq)); + if (temp * den > scaden) { + scaden = temp * den; + knew = k; + denom = den; + } + biglsq = std::max(biglsq, temp * (VLAG(k) * VLAG(k))); + } + if (scaden <= half * biglsq) { + knew = ksav; + denom = densav; + } + } + } + // + // Update BMAT and ZMAT, so that the KNEW-th interpolation point can be + // moved. Also update the second derivative terms of the model. + // + updatebobyqa(n, npt, bmat, zmat, ndim, vlag, beta, denom, knew, w); + ih = 0; + pqold = PQ(knew); + PQ(knew) = zero; + for (i = 1; i <= n; i++) { + temp = pqold * XPT(knew, i); + for (j = 1; j <= i; j++) { + ih = ih + 1; + HQ(ih) = HQ(ih) + temp * XPT(knew, j); + } + } + for (jj = 1; jj <= nptm; jj++) { + temp = diff * ZMAT(knew, jj); + for (k = 1; k <= npt; k++) { + PQ(k) = PQ(k) + temp * ZMAT(k, jj); + } + } + // + // Include the new interpolation point, and make the changes to GOPT at + // the old XOPT that are caused by the updating of the quadratic model. + // + FVAL(knew) = f; + for (i = 1; i <= n; i++) { + XPT(knew, i) = XNEW(i); + W(i) = BMAT(knew, i); + } + for (k = 1; k <= npt; k++) { + suma = zero; + for (jj = 1; jj <= nptm; jj++) { + suma = suma + ZMAT(knew, jj) * ZMAT(k, jj); + } + sumb = zero; + for (j = 1; j <= n; j++) { + sumb = sumb + XPT(k, j) * XOPT(j); + } + temp = suma * sumb; + for (i = 1; i <= n; i++) { + W(i) = W(i) + temp * XPT(k, i); + } + } + for (i = 1; i <= n; i++) { + GOPT(i) = GOPT(i) + diff * W(i); + } + // + // Update XOPT, GOPT and KOPT if the new calculated F is less than FOPT. + // + if (f < fopt) { + kopt = knew; + xoptsq = zero; + ih = 0; + for (j = 1; j <= n; j++) { + XOPT(j) = XNEW(j); + xoptsq = xoptsq + XOPT(j) * XOPT(j); + for (i = 1; i <= j; i++) { + ih = ih + 1; + if (i < j) GOPT(j) = GOPT(j) + HQ(ih) * D(i); + GOPT(i) = GOPT(i) + HQ(ih) * D(j); + } + } + for (k = 1; k <= npt; k++) { + temp = zero; + for (j = 1; j <= n; j++) { + temp = temp + XPT(k, j) * D(j); + } + temp = PQ(k) * temp; + for (i = 1; i <= n; i++) { + GOPT(i) = GOPT(i) + temp * XPT(k, i); + } + } + } + // + // Calculate the parameters of the least Frobenius norm interpolant to + // the current data, the gradient of this interpolant at XOPT being put + // into VLAG(NPT+I), I=1,2,...,N. + // + if (ntrits > 0) { + for (k = 1; k <= npt; k++) { + VLAG(k) = FVAL(k) - FVAL(kopt); + W(k) = zero; + } + for (j = 1; j <= nptm; j++) { + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + ZMAT(k, j) * VLAG(k); + } + for (k = 1; k <= npt; k++) { + W(k) = W(k) + sum * ZMAT(k, j); + } + } + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= n; j++) { + sum = sum + XPT(k, j) * XOPT(j); + } + W(k + npt) = W(k); + W(k) = sum * W(k); + } + gqsq = zero; + gisq = zero; + for (i = 1; i <= n; i++) { + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + BMAT(k, i) * VLAG(k) + XPT(k, i) * W(k); + } + if (XOPT(i) == SL(i)) { + gqsq = gqsq + std::min(zero, GOPT(i)) * std::min(zero, GOPT(i)); + gisq = gisq + std::min(zero, sum) * std::min(zero, sum); + } else if (XOPT(i) == SU(i)) { + gqsq = gqsq + std::max(zero, GOPT(i)) * std::max(zero, GOPT(i)); + gisq = gisq + std::max(zero, sum) * std::max(zero, sum); + } else { + gqsq = gqsq + GOPT(i) * GOPT(i); + gisq = gisq + sum * sum; + } + VLAG(npt + i) = sum; + } + // + // Test whether to replace the new quadratic model by the least + // Frobenius norm interpolant, making the replacement if the test is + // satisfied. + // + itest = itest + 1; + if (gqsq < ten * gisq) itest = 0; + if (itest >= 3) { + for (i = 1; i <= std::max(npt, nh); i++) { + if (i <= n) GOPT(i) = VLAG(npt + i); + if (i <= npt) PQ(i) = W(npt + i); + if (i <= nh) HQ(i) = zero; + itest = 0; + } + } + } + // + // If a trust region step has provided a sufficient decrease in F, then + // branch for another trust region calculation. The case NTRITS=0 + // occurs when the new interpolation point was reached by an alternative + // step. + // + if (ntrits == 0) goto L60; + if (f <= fopt + tenth * vquad) goto L60; + // + // Alternatively, find out if the interpolation points are close enough + // to the best point so far. + // + distsq = std::max((two * delta) * (two * delta), (ten * rho) * (ten * rho)); +L650: + knew = 0; + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= n; j++) { + sum = sum + (XPT(k, j) - XOPT(j)) * (XPT(k, j) - XOPT(j)); + } + if (sum > distsq) { + knew = k; + distsq = sum; + } + } + // + // If KNEW is positive, then ALTMOV finds alternative new positions for + // the KNEW-th interpolation point within distance ADELT of XOPT. It is + // reached via label 90. Otherwise, there is a branch to label 60 for + // another trust region iteration, unless the calculations with the + // current RHO are complete. + // + if (knew > 0) { + dist = std::sqrt(distsq); + if (ntrits == -1) { + delta = std::min(tenth * delta, half * dist); + if (delta <= 1.5 * rho) delta = rho; + } + ntrits = 0; + adelt = std::max(std::min(tenth * dist, delta), rho); + dsq = adelt * adelt; + goto L90; + } + if (ntrits == -1) goto L680; + if (ratio > zero) goto L60; + if (std::max(delta, dnorm) > rho) goto L60; + // + // The calculations with the current value of RHO are complete. Pick the + // next values of RHO and DELTA. + // +L680: + if (rho > rhoend) { + delta = half * rho; + ratio = rho / rhoend; + if (ratio <= 16.0) { + rho = rhoend; + } else if (ratio <= 250.0) { + rho = std::sqrt(ratio) * rhoend; + } else { + rho = tenth * rho; + } + delta = std::max(delta, rho); + calfun.minqit(rho, nf, FVAL(kopt), xbase, xopt); + ntrits = 0; + nfsav = nf; + goto L60; + } + // + // Return from the calculation, after another Newton-Raphson step, if + // it is too short to have been tried before. + // + if (ntrits == -1) goto L360; +L720: + if (FVAL(kopt) <= fsave) { + for (i = 1; i <= n; i++) { + X(i) = std::min(std::max(XL(i), XBASE(i) + XOPT(i)), XU(i)); + if (XOPT(i) == SL(i)) X(i) = XL(i); + if (XOPT(i) == SU(i)) X(i) = XU(i); + } + f = FVAL(kopt); + } + calfun.minqir(f, nf, x); +} + +// --------------------------------------------------------------------------- +// bobyqa.f: SUBROUTINE BOBYQA +// --------------------------------------------------------------------------- +void bobyqa(int n, int npt, double *x, const double *xl, const double *xu, + double rhobeg, double rhoend, int maxfun, double *w, int &ierr, + MinqaCalfun &calfun) { + double zero, temp; + int np, ndim, ixb, ixp, ifv, ixo, igo, ihq, ipq, ibmat, izmat, isl, isu, + ixn, ixa, id, ivl, iw, j, jsl, jsu; + + np = n + 1; + if (npt < n + 2 || npt > ((n + 2) * np) / 2) { + ierr = 10; + return; // GO TO 40 + } + // + // Partition the working space array, so that different parts of it can + // be treated separately during the calculation of BOBYQB. The partition + // requires the first (NPT+2)*(NPT+N)+3*N*(N+5)/2 elements of W plus the + // space that is taken by the last array in the argument list of BOBYQB. + // + ndim = npt + n; + ixb = 1; + ixp = ixb + n; + ifv = ixp + n * npt; + ixo = ifv + npt; + igo = ixo + n; + ihq = igo + n; + ipq = ihq + (n * np) / 2; + ibmat = ipq + npt; + izmat = ibmat + ndim * n; + isl = izmat + npt * (npt - np); + isu = isl + n; + ixn = isu + n; + ixa = ixn + n; + id = ixa + n; + ivl = id + n; + iw = ivl + ndim; + ierr = 0; + // + // Return if there is insufficient space between the bounds. Modify the + // initial X if necessary in order to avoid conflicts between the bounds + // and the construction of the first quadratic model. The lower and + // upper bounds on moves from the updated X are set now, in the ISL and + // ISU partitions of W, in order to provide useful and exact information + // about components of X that become within distance RHOBEG from their + // bounds. + // + zero = 0.0; + for (j = 1; j <= n; j++) { + temp = XU(j) - XL(j); + if (temp < rhobeg + rhobeg) { + ierr = 20; + return; // GOTO 40 + } + jsl = isl + j - 1; + jsu = jsl + n; + W(jsl) = XL(j) - X(j); + W(jsu) = XU(j) - X(j); + if (W(jsl) >= -rhobeg) { + if (W(jsl) >= zero) { + X(j) = XL(j); + W(jsl) = zero; + W(jsu) = temp; + } else { + X(j) = XL(j) + rhobeg; + W(jsl) = -rhobeg; + W(jsu) = std::max(XU(j) - X(j), rhobeg); + } + } else if (W(jsu) <= rhobeg) { + if (W(jsu) <= zero) { + X(j) = XU(j); + W(jsl) = -temp; + W(jsu) = zero; + } else { + X(j) = XU(j) - rhobeg; + W(jsl) = std::min(XL(j) - X(j), -rhobeg); + W(jsu) = rhobeg; + } + } + } + // + // Make the call of BOBYQB. + // + bobyqb(n, npt, x, xl, xu, rhobeg, rhoend, maxfun, &W(ixb), &W(ixp), + &W(ifv), &W(ixo), &W(igo), &W(ihq), &W(ipq), &W(ibmat), &W(izmat), + ndim, &W(isl), &W(isu), &W(ixn), &W(ixa), &W(id), &W(ivl), &W(iw), + ierr, calfun); +} + +} // namespace + +#undef X +#undef XL +#undef XU +#undef W +#undef XBASE +#undef XPT +#undef FVAL +#undef XOPT +#undef GOPT +#undef HQ +#undef PQ +#undef BMAT +#undef ZMAT +#undef SL +#undef SU +#undef XNEW +#undef XALT +#undef D +#undef VLAG +#undef GNEW +#undef XBDI +#undef S +#undef HS +#undef HRED +#undef GLAG +#undef HCOL +#undef PTSAUX +#undef PTSID + +// Public entry point (declared in minqa_types.h). Mirrors minqa's +// bobyqa_cpp(): workspace sized as (NPT+5)*(NPT+N)+3*N*(N+5)/2, a copy of +// par is optimized in place, then par/fval are finalized by minqa_run(). +// A NULL lower (upper) means -Inf (+Inf) for every component; NULL opts +// means minqa_options_default(n, par). +int bobyqa_solve_c(int n, const double *par, const double *lower, + const double *upper, minqa_c_objfun_t objfun, + void *userdata, const minqa_options_t *opts, + minqa_result_t *result) { + minqa_options_t defopts; + if (opts == nullptr && n > 0 && par != nullptr) { + defopts = minqa_options_default(n, par); + opts = &defopts; + } + if (opts == nullptr) { + if (result != nullptr) { + minqa_result_zero(result); + result->n = n; + result->ierr = MINQA_ERR_INVALID; + } + return MINQA_ERR_INVALID; + } + int chk = minqa_check_args(n, par, objfun, opts, result); + if (chk != MINQA_OK) return chk; + MinqaCalfun calfun(objfun, userdata, n, opts); + std::vector x, xl, xu, w; + try { + x.assign(par, par + n); + xl.assign(static_cast(n), -HUGE_VAL); + xu.assign(static_cast(n), HUGE_VAL); + if (lower != nullptr) xl.assign(lower, lower + n); + if (upper != nullptr) xu.assign(upper, upper + n); + // minqa.cpp: vector w((np + 5) * (np + n) + (3 * n * (n + 5))/2) + long long lw = (static_cast(opts->npt) + 5) * + (static_cast(opts->npt) + n) + + (3LL * n * (n + 5)) / 2; + if (lw < 1) lw = 1; + w.assign(static_cast(lw), 0.0); + } catch (const std::bad_alloc &) { + minqa_result_zero(result); + result->n = n; + result->ierr = MINQA_ERR_NOMEM; + return MINQA_ERR_NOMEM; + } + return minqa_run(n, x.data(), calfun, result, [&]() -> int { + int ierr = 0; + bobyqa(n, opts->npt, x.data(), xl.data(), xu.data(), opts->rhobeg, + opts->rhoend, opts->maxfun, w.data(), ierr, calfun); + return ierr; + }); +} diff --git a/src/minqa_common.cpp b/src/minqa_common.cpp new file mode 100644 index 0000000..7ad5020 --- /dev/null +++ b/src/minqa_common.cpp @@ -0,0 +1,29 @@ +#include "minqa_common.h" +#include +#include +#include + +void minqa_result_zero(minqa_result_t *res) { std::memset(res, 0, sizeof(*res)); } + +void minqa_result_free(minqa_result_t *res) { + free(res->par); + minqa_result_zero(res); +} + +int minqa_finish(int n, const double *x, int raw_ierr, MinqaCalfun &calfun, + minqa_result_t *result) { + result->raw_ierr = raw_ierr; + result->ierr = minqa_map_ierr(raw_ierr); + result->feval = calfun.feval; + size_t bytes = n > 0 ? static_cast(n) * sizeof(double) : sizeof(double); + result->par = static_cast(malloc(bytes)); + if (result->par == nullptr) throw std::bad_alloc(); + if (n > 0) std::memcpy(result->par, x, static_cast(n) * sizeof(double)); + double f = 0.0; + if (calfun.fn(n, x, &f, calfun.userdata) < 0) { + result->ierr = MINQA_ERR_OBJFUN; + return result->ierr; + } + result->fval = f; + return result->ierr; +} diff --git a/src/minqa_common.h b/src/minqa_common.h new file mode 100644 index 0000000..89efe66 --- /dev/null +++ b/src/minqa_common.h @@ -0,0 +1,151 @@ +#ifndef MINQA_COMMON_H +#define MINQA_COMMON_H + +/* Shared, thread-safe replacement for minqa's R-bound glue (calfun(), + * minqit(), minqir() in minqa/src/minqa.cpp). One MinqaCalfun lives on + * the stack of each *_solve_c() call, so concurrent solves share nothing. + * + * Aborts (objfun error, non-finite x) unwind the Fortran-style goto code + * via the MinqaAbort exception, caught in the extern "C" entry point. */ + +#include +#include +#include +#include +#include "minqa_types.h" + +struct MinqaAbort { + int code; // MINQA_ERR_OBJFUN or MINQA_ERR_NONFINITE_X +}; + +struct MinqaCalfun { + minqa_c_objfun_t fn; + void *userdata; + int n; + int iprint; + minqa_print_t print; + void *print_userdata; + int feval = 0; + + MinqaCalfun(minqa_c_objfun_t fn_, void *userdata_, int n_, + const minqa_options_t *opts) + : fn(fn_), userdata(userdata_), n(n_), iprint(opts->iprint), + print(opts->print), print_userdata(opts->print_userdata) {} + + void emit(const std::string &line) const { + if (print != nullptr) print(line.c_str(), print_userdata); + } + + static std::string fmt(const char *format, double v) { + char buf[64]; + std::snprintf(buf, sizeof(buf), format, v); + return buf; + } + static std::string fmti(const char *format, int v) { + char buf[64]; + std::snprintf(buf, sizeof(buf), format, v); + return buf; + } + + // F77_NAME(calfun): counts, rejects non-finite x, clamps non-finite f + // to DBL_MAX, and prints per iprint exactly as minqa does. + double operator()(const double *x) { + feval++; + for (int i = 0; i < n; i++) + if (!std::isfinite(x[i])) throw MinqaAbort{MINQA_ERR_NONFINITE_X}; + double f = 0.0; + if (fn(n, x, &f, userdata) < 0) throw MinqaAbort{MINQA_ERR_OBJFUN}; + if (!std::isfinite(f)) f = DBL_MAX; + if (print != nullptr && + (iprint == 3 || (iprint > 3 && feval % iprint == 0))) { + std::string line = fmti("%3d:", feval) + fmt("%#14.8g:", f); + for (int i = 0; i < n; i++) line += fmt(" %#8g", x[i]); + emit(line + "\n"); + } + return f; + } + + // F77_NAME(minqit): called when rho changes and iprint >= 2. + // xbase and xopt are 0-based pointers to length-n arrays. + void minqit(double rho, int nf, double fopt, const double *xbase, + const double *xopt) const { + if (print == nullptr || iprint < 2) return; + std::string line = fmt("rho: %#8.2g", rho) + fmti(" eval: %3d", nf) + + fmt(" fn: %#12g par:", fopt); + for (int i = 0; i < n; i++) line += fmt("%#8g ", xbase[i] + xopt[i]); + emit(line + "\n"); + } + + // F77_NAME(minqir): output at return when iprint > 0. + void minqir(double f, int nf, const double *x) const { + if (print == nullptr || iprint <= 0) return; + emit("At return\n"); + std::string line = fmti("eval: %3d", nf) + fmt(" fn: %#14.8g par:", f); + for (int i = 0; i < n; i++) line += fmt(" %#8g", x[i]); + emit(line + "\n"); + } +}; + +/* Maps the raw Fortran IERR to minqa.R's remapped code. */ +inline int minqa_map_ierr(int raw) { + switch (raw) { + case 0: return MINQA_OK; + case 390: return MINQA_ERR_MAXFUN; + case 10: return MINQA_ERR_NPT; + case 430: case 3701: return MINQA_ERR_NO_REDUCTION; + case 20: return MINQA_ERR_RANGE; + case 320: return MINQA_ERR_CANCELLATION; + default: return raw; + } +} + +/* Shared argument checks for every *_solve_c() entry point. Returns + * MINQA_OK, or zeroes *result, stores the code and returns it. */ +inline int minqa_check_args(int n, const double *par, minqa_c_objfun_t objfun, + const minqa_options_t *opts, + minqa_result_t *result) { + if (result == nullptr) return MINQA_ERR_INVALID; + if (n < 0 || (n > 0 && par == nullptr) || objfun == nullptr || + !(opts->rhobeg > 0.0) || !(opts->rhoend > 0.0)) { + minqa_result_zero(result); + result->n = n; + result->ierr = MINQA_ERR_INVALID; + return MINQA_ERR_INVALID; + } + return MINQA_OK; +} + +/* Common tail of every *_solve_c(): copy par, re-evaluate fval at par + * (uncounted, unclamped, like minqa's rval()), map ierr. Returns + * result->ierr. Defined in minqa_common.cpp. */ +int minqa_finish(int n, const double *x, int raw_ierr, MinqaCalfun &calfun, + minqa_result_t *result); + +/* Wraps a solver body with the shared error translation. body() must + * run the port and return the raw Fortran IERR, leaving the final X in + * x. Defined as a template so each solver's core stays in its own file. */ +template +int minqa_run(int n, double *x, MinqaCalfun &calfun, minqa_result_t *result, + Body body) { + minqa_result_zero(result); + result->n = n; + try { + int raw = body(); + return minqa_finish(n, x, raw, calfun, result); + } catch (const MinqaAbort &a) { + result->ierr = a.code; + result->feval = calfun.feval; + return a.code; + } catch (const std::bad_alloc &) { + minqa_result_free(result); + result->n = n; + result->ierr = MINQA_ERR_NOMEM; + return MINQA_ERR_NOMEM; + } catch (...) { + result->ierr = MINQA_ERR_INTERNAL; + result->feval = calfun.feval; + return MINQA_ERR_INTERNAL; + } +} + +#endif /* MINQA_COMMON_H */ diff --git a/src/minqa_newuoa.cpp b/src/minqa_newuoa.cpp new file mode 100644 index 0000000..71886fb --- /dev/null +++ b/src/minqa_newuoa.cpp @@ -0,0 +1,1632 @@ +// Thread-safe C++17 port of M. J. D. Powell's NEWUOA, exactly as shipped +// (with R-specific edits by John Nash and Douglas Bates) in the CRAN +// package minqa 1.2.8: src/newuoa.f, newuob.f, trsapp.f, biglag.f, +// bigden.f and update.f. +// +// The translation is line by line: Powell's variable names, the partition +// of the workspace W, column-major 2-D arrays (accessed through 1-based +// index macros), statement labels (as goto targets) and the order of the +// floating point operations are all kept, so that results are bitwise +// identical to the Fortran compiled without FMA contraction. +// +// Differences from the Fortran, all of them required for thread safety: +// * CALFUN(N,X,IPRINT) is the per-call MinqaCalfun object; MINQIT/MINQIR +// are its member functions (no Rprintf, no global state). +// * Local variables are initialized to zero (the Fortran leaves them +// undefined, but never reads them before they are set). + +#include +#include +#include + +#include "minqa_common.h" +#include "minqa_types.h" + +// Forbid FMA contraction (a*b + c -> fma) so the port keeps the exact IEEE +// operation sequence of minqa's Fortran as built on x86_64 (and the +// bit-for-bit validation holds) on targets that contract by default, such +// as aarch64. Placed after the headers so only this file's code is affected. +#if defined(__clang__) +#pragma clang fp contract(off) +#elif defined(__GNUC__) +#pragma GCC optimize("fp-contract=off") +#endif + +namespace { + +// --------------------------------------------------------------------------- +// trsapp.f: SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, +// D,G,HD,HS,CRVMIN) +// --------------------------------------------------------------------------- +void trsapp(int n, int npt, const double *xopt, const double *xpt, + const double *gq, const double *hq, const double *pq, + double delta, double *step, double *d, double *g, double *hd, + double *hs, double &crvmin) { +#define XOPT(I) xopt[(I) - 1] +#define XPT(I, J) xpt[((I) - 1) + ((J) - 1) * npt] +#define GQ(I) gq[(I) - 1] +#define HQ(I) hq[(I) - 1] +#define PQ(I) pq[(I) - 1] +#define STEP(I) step[(I) - 1] +#define D(I) d[(I) - 1] +#define G(I) g[(I) - 1] +#define HD(I) hd[(I) - 1] +#define HS(I) hs[(I) - 1] + double half, zero, twopi, delsq, qred, dd, ds, ss, gg, ggbeg, temp, bstep, + dhd, alpha, qadd, ggsav, sg, shs, sgk, angtest, tempa, tempb, dg, dhs, + cf, qbeg, qsav, qmin, angle, cth, sth, qnew, reduc, ratio; + int iterc, itermax, itersw, i, j, k, ih, isave, iu; + qred = dd = ds = ss = gg = ggbeg = temp = bstep = dhd = alpha = qadd = + ggsav = sg = shs = sgk = angtest = tempa = tempb = dg = dhs = cf = + qbeg = qsav = qmin = angle = cth = sth = qnew = reduc = ratio = 0.0; + ih = isave = iu = 0; + + half = 0.5e0; + zero = 0.0e0; + twopi = 8.0e0 * std::atan(1.0e0); + delsq = delta * delta; + iterc = 0; + itermax = n; + itersw = itermax; + for (i = 1; i <= n; i++) { + D(i) = XOPT(i); + } + goto L170; + + // Prepare for the first line search. +L20: + qred = zero; + dd = zero; + for (i = 1; i <= n; i++) { + STEP(i) = zero; + HS(i) = zero; + G(i) = GQ(i) + HD(i); + D(i) = -G(i); + dd = dd + D(i) * D(i); + } + crvmin = zero; + if (dd == zero) goto L160; + ds = zero; + ss = zero; + gg = dd; + ggbeg = gg; + + // Calculate the step to the trust region boundary and the product HD. +L40: + iterc = iterc + 1; + temp = delsq - ss; + bstep = temp / (ds + std::sqrt(ds * ds + dd * temp)); + goto L170; +L50: + dhd = zero; + for (j = 1; j <= n; j++) { + dhd = dhd + D(j) * HD(j); + } + + // Update CRVMIN and set the step-length ALPHA. + alpha = bstep; + if (dhd > zero) { + temp = dhd / dd; + if (iterc == 1) crvmin = temp; + crvmin = std::min(crvmin, temp); + alpha = std::min(alpha, gg / dhd); + } + qadd = alpha * (gg - half * alpha * dhd); + qred = qred + qadd; + + // Update STEP and HS. + ggsav = gg; + gg = zero; + for (i = 1; i <= n; i++) { + STEP(i) = STEP(i) + alpha * D(i); + HS(i) = HS(i) + alpha * HD(i); + gg = gg + (G(i) + HS(i)) * (G(i) + HS(i)); + } + + // Begin another conjugate direction iteration if required. + if (alpha < bstep) { + if (qadd <= 0.01e0 * qred) goto L160; + if (gg <= 1.0e-4 * ggbeg) goto L160; + if (iterc == itermax) goto L160; + temp = gg / ggsav; + dd = zero; + ds = zero; + ss = zero; + for (i = 1; i <= n; i++) { + D(i) = temp * D(i) - G(i) - HS(i); + dd = dd + D(i) * D(i); + ds = ds + D(i) * STEP(i); + ss = ss + STEP(i) * STEP(i); + } + if (ds <= zero) goto L160; + if (ss < delsq) goto L40; + } + crvmin = zero; + itersw = iterc; + + // Test whether an alternative iteration is required. +L90: + if (gg <= 1.0e-4 * ggbeg) goto L160; + sg = zero; + shs = zero; + for (i = 1; i <= n; i++) { + sg = sg + STEP(i) * G(i); + shs = shs + STEP(i) * HS(i); + } + sgk = sg + shs; + angtest = sgk / std::sqrt(gg * delsq); + if (angtest <= -0.99e0) goto L160; + + // Begin the alternative iteration by calculating D and HD and some + // scalar products. + iterc = iterc + 1; + temp = std::sqrt(delsq * gg - sgk * sgk); + tempa = delsq / temp; + tempb = sgk / temp; + for (i = 1; i <= n; i++) { + D(i) = tempa * (G(i) + HS(i)) - tempb * STEP(i); + } + goto L170; +L120: + dg = zero; + dhd = zero; + dhs = zero; + for (i = 1; i <= n; i++) { + dg = dg + D(i) * G(i); + dhd = dhd + HD(i) * D(i); + dhs = dhs + HD(i) * STEP(i); + } + + // Seek the value of the angle that minimizes Q. + cf = half * (shs - dhd); + qbeg = sg + cf; + qsav = qbeg; + qmin = qbeg; + isave = 0; + iu = 49; + temp = twopi / static_cast(iu + 1); + for (i = 1; i <= iu; i++) { + angle = static_cast(i) * temp; + cth = std::cos(angle); + sth = std::sin(angle); + qnew = (sg + cf * cth) * cth + (dg + dhs * cth) * sth; + if (qnew < qmin) { + qmin = qnew; + isave = i; + tempa = qsav; + } else if (i == isave + 1) { + tempb = qnew; + } + qsav = qnew; + } + if (static_cast(isave) == zero) tempa = qnew; + if (isave == iu) tempb = qbeg; + angle = zero; + if (tempa != tempb) { + tempa = tempa - qmin; + tempb = tempb - qmin; + angle = half * (tempa - tempb) / (tempa + tempb); + } + angle = temp * (static_cast(isave) + angle); + + // Calculate the new STEP and HS. Then test for convergence. + cth = std::cos(angle); + sth = std::sin(angle); + reduc = qbeg - (sg + cf * cth) * cth - (dg + dhs * cth) * sth; + gg = zero; + for (i = 1; i <= n; i++) { + STEP(i) = cth * STEP(i) + sth * D(i); + HS(i) = cth * HS(i) + sth * HD(i); + gg = gg + (G(i) + HS(i)) * (G(i) + HS(i)); + } + qred = qred + reduc; + ratio = reduc / qred; + if (iterc < itermax && ratio > 0.01e0) goto L90; +L160: + return; + + // The following instructions act as a subroutine for setting the vector + // HD to the vector D multiplied by the second derivative matrix of Q. + // They are called from three different places, which are distinguished + // by the value of ITERC. +L170: + for (i = 1; i <= n; i++) { + HD(i) = zero; + } + for (k = 1; k <= npt; k++) { + temp = zero; + for (j = 1; j <= n; j++) { + temp = temp + XPT(k, j) * D(j); + } + temp = temp * PQ(k); + for (i = 1; i <= n; i++) { + HD(i) = HD(i) + temp * XPT(k, i); + } + } + ih = 0; + for (j = 1; j <= n; j++) { + for (i = 1; i <= j; i++) { + ih = ih + 1; + if (i < j) HD(j) = HD(j) + HQ(ih) * D(i); + HD(i) = HD(i) + HQ(ih) * D(j); + } + } + if (iterc == 0) goto L20; + if (iterc <= itersw) goto L50; + goto L120; +#undef XOPT +#undef XPT +#undef GQ +#undef HQ +#undef PQ +#undef STEP +#undef D +#undef G +#undef HD +#undef HS +} + +// --------------------------------------------------------------------------- +// biglag.f: SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, +// DELTA,D,ALPHA,HCOL,GC,GD,S,W) +// --------------------------------------------------------------------------- +void biglag(int n, int npt, const double *xopt, const double *xpt, + const double *bmat, const double *zmat, int idz, int ndim, + int knew, double delta, double *d, double &alpha, double *hcol, + double *gc, double *gd, double *s, double *w) { +#define XOPT(I) xopt[(I) - 1] +#define XPT(I, J) xpt[((I) - 1) + ((J) - 1) * npt] +#define BMAT(I, J) bmat[((I) - 1) + ((J) - 1) * ndim] +#define ZMAT(I, J) zmat[((I) - 1) + ((J) - 1) * npt] +#define D(I) d[(I) - 1] +#define HCOL(I) hcol[(I) - 1] +#define GC(I) gc[(I) - 1] +#define GD(I) gd[(I) - 1] +#define S(I) s[(I) - 1] +#define W(I) w[(I) - 1] + double half, one, zero, twopi, delsq, temp, dd, sum, gg, sp, dhd, scale, + tau, ss, denom, cf1, cf2, cf3, cf4, cf5, taubeg, taumax, tauold, angle, + cth, sth, tempa, tempb, step; + int nptm, iterc, i, j, k, isave, iu; + temp = dd = sum = gg = sp = dhd = scale = tau = ss = denom = cf1 = cf2 = + cf3 = cf4 = cf5 = taubeg = taumax = tauold = angle = cth = sth = tempa = + tempb = step = 0.0; + isave = iu = 0; + + half = 0.5e0; + one = 1.0e0; + zero = 0.0e0; + twopi = 8.0e0 * std::atan(one); + delsq = delta * delta; + nptm = npt - n - 1; + + // Set the first NPT components of HCOL to the leading elements of the + // KNEW-th column of H. + iterc = 0; + for (k = 1; k <= npt; k++) { + HCOL(k) = zero; + } + for (j = 1; j <= nptm; j++) { + temp = ZMAT(knew, j); + if (j < idz) temp = -temp; + for (k = 1; k <= npt; k++) { + HCOL(k) = HCOL(k) + temp * ZMAT(k, j); + } + } + alpha = HCOL(knew); + + // Set the unscaled initial direction D. Form the gradient of LFUNC at + // XOPT, and multiply D by the second derivative matrix of LFUNC. + dd = zero; + for (i = 1; i <= n; i++) { + D(i) = XPT(knew, i) - XOPT(i); + GC(i) = BMAT(knew, i); + GD(i) = zero; + dd = dd + D(i) * D(i); + } + for (k = 1; k <= npt; k++) { + temp = zero; + sum = zero; + for (j = 1; j <= n; j++) { + temp = temp + XPT(k, j) * XOPT(j); + sum = sum + XPT(k, j) * D(j); + } + temp = HCOL(k) * temp; + sum = HCOL(k) * sum; + for (i = 1; i <= n; i++) { + GC(i) = GC(i) + temp * XPT(k, i); + GD(i) = GD(i) + sum * XPT(k, i); + } + } + + // Scale D and GD, with a sign change if required. Set S to another + // vector in the initial two dimensional subspace. + gg = zero; + sp = zero; + dhd = zero; + for (i = 1; i <= n; i++) { + gg = gg + GC(i) * GC(i); + sp = sp + D(i) * GC(i); + dhd = dhd + D(i) * GD(i); + } + scale = delta / std::sqrt(dd); + if (sp * dhd < zero) scale = -scale; + temp = zero; + if (sp * sp > 0.99e0 * dd * gg) temp = one; + tau = scale * (std::fabs(sp) + half * scale * std::fabs(dhd)); + if (gg * delsq < 0.01e0 * tau * tau) temp = one; + for (i = 1; i <= n; i++) { + D(i) = scale * D(i); + GD(i) = scale * GD(i); + S(i) = GC(i) + temp * GD(i); + } + + // Begin the iteration by overwriting S with a vector that has the + // required length and direction, except that termination occurs if + // the given D and S are nearly parallel. +L80: + iterc = iterc + 1; + dd = zero; + sp = zero; + ss = zero; + for (i = 1; i <= n; i++) { + dd = dd + D(i) * D(i); + sp = sp + D(i) * S(i); + ss = ss + S(i) * S(i); + } + temp = dd * ss - sp * sp; + if (temp <= 1.0e-8 * dd * ss) goto L160; + denom = std::sqrt(temp); + for (i = 1; i <= n; i++) { + S(i) = (dd * S(i) - sp * D(i)) / denom; + W(i) = zero; + } + + // Calculate the coefficients of the objective function on the circle, + // beginning with the multiplication of S by the second derivative matrix. + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= n; j++) { + sum = sum + XPT(k, j) * S(j); + } + sum = HCOL(k) * sum; + for (i = 1; i <= n; i++) { + W(i) = W(i) + sum * XPT(k, i); + } + } + cf1 = zero; + cf2 = zero; + cf3 = zero; + cf4 = zero; + cf5 = zero; + for (i = 1; i <= n; i++) { + cf1 = cf1 + S(i) * W(i); + cf2 = cf2 + D(i) * GC(i); + cf3 = cf3 + S(i) * GC(i); + cf4 = cf4 + D(i) * GD(i); + cf5 = cf5 + S(i) * GD(i); + } + cf1 = half * cf1; + cf4 = half * cf4 - cf1; + + // Seek the value of the angle that maximizes the modulus of TAU. + taubeg = cf1 + cf2 + cf4; + taumax = taubeg; + tauold = taubeg; + isave = 0; + iu = 49; + temp = twopi / static_cast(iu + 1); + for (i = 1; i <= iu; i++) { + angle = static_cast(i) * temp; + cth = std::cos(angle); + sth = std::sin(angle); + tau = cf1 + (cf2 + cf4 * cth) * cth + (cf3 + cf5 * cth) * sth; + if (std::fabs(tau) > std::fabs(taumax)) { + taumax = tau; + isave = i; + tempa = tauold; + } else if (i == isave + 1) { + tempb = tau; + } + tauold = tau; + } + if (isave == 0) tempa = tau; + if (isave == iu) tempb = taubeg; + step = zero; + if (tempa != tempb) { + tempa = tempa - taumax; + tempb = tempb - taumax; + step = half * (tempa - tempb) / (tempa + tempb); + } + angle = temp * (static_cast(isave) + step); + + // Calculate the new D and GD. Then test for convergence. + cth = std::cos(angle); + sth = std::sin(angle); + tau = cf1 + (cf2 + cf4 * cth) * cth + (cf3 + cf5 * cth) * sth; + for (i = 1; i <= n; i++) { + D(i) = cth * D(i) + sth * S(i); + GD(i) = cth * GD(i) + sth * W(i); + S(i) = GC(i) + GD(i); + } + if (std::fabs(tau) <= 1.1e0 * std::fabs(taubeg)) goto L160; + if (iterc < n) goto L80; +L160: + return; +#undef XOPT +#undef XPT +#undef BMAT +#undef ZMAT +#undef D +#undef HCOL +#undef GC +#undef GD +#undef S +#undef W +} + +// --------------------------------------------------------------------------- +// bigden.f: SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, +// KNEW,D,W,VLAG,BETA,S,WVEC,PROD) +// --------------------------------------------------------------------------- +void bigden(int n, int npt, const double *xopt, const double *xpt, + const double *bmat, const double *zmat, int idz, int ndim, + int kopt, int knew, double *d, double *w, double *vlag, + double &beta, double *s, double *wvec, double *prod) { +#define XOPT(I) xopt[(I) - 1] +#define XPT(I, J) xpt[((I) - 1) + ((J) - 1) * npt] +#define BMAT(I, J) bmat[((I) - 1) + ((J) - 1) * ndim] +#define ZMAT(I, J) zmat[((I) - 1) + ((J) - 1) * npt] +#define D(I) d[(I) - 1] +#define W(I) w[(I) - 1] +#define VLAG(I) vlag[(I) - 1] +#define S(I) s[(I) - 1] +#define WVEC(I, J) wvec[((I) - 1) + ((J) - 1) * ndim] +#define PROD(I, J) prod[((I) - 1) + ((J) - 1) * ndim] +#define DEN(I) den[(I) - 1] +#define DENEX(I) denex[(I) - 1] +#define PAR(I) par[(I) - 1] + double den[9] = {0}, denex[9] = {0}, par[9] = {0}; + double half, one, quart, two, zero, twopi, temp, alpha, dd, ds, ss, xoptsq, + dtest, dstemp, sstemp, diff, ssden, densav, xoptd, xopts, tempa, tempb, + tempc, sum, denold, denmax, angle, sumold, step, tau; + int nptm, i, j, k, ksav, iterc, ip, jc, nw, isave, iu; + temp = alpha = dd = ds = ss = xoptsq = dtest = dstemp = sstemp = diff = + ssden = densav = xoptd = xopts = tempa = tempb = tempc = sum = denold = + denmax = angle = sumold = step = tau = 0.0; + ksav = iterc = ip = jc = nw = isave = iu = 0; + + half = 0.5e0; + one = 1.0e0; + quart = 0.25e0; + two = 2.0e0; + zero = 0.0e0; + twopi = 8.0e0 * std::atan(one); + nptm = npt - n - 1; + + // Store the first NPT elements of the KNEW-th column of H in W(N+1) + // to W(N+NPT). + for (k = 1; k <= npt; k++) { + W(n + k) = zero; + } + for (j = 1; j <= nptm; j++) { + temp = ZMAT(knew, j); + if (j < idz) temp = -temp; + for (k = 1; k <= npt; k++) { + W(n + k) = W(n + k) + temp * ZMAT(k, j); + } + } + alpha = W(n + knew); + + // The initial search direction D is taken from the last call of BIGLAG, + // and the initial S is set below, usually to the direction from X_OPT + // to X_KNEW, but a different direction to an interpolation point may + // be chosen, in order to prevent S from being nearly parallel to D. + dd = zero; + ds = zero; + ss = zero; + xoptsq = zero; + for (i = 1; i <= n; i++) { + dd = dd + D(i) * D(i); + S(i) = XPT(knew, i) - XOPT(i); + ds = ds + D(i) * S(i); + ss = ss + S(i) * S(i); + xoptsq = xoptsq + XOPT(i) * XOPT(i); + } + if (ds * ds > 0.99e0 * dd * ss) { + ksav = knew; + dtest = ds * ds / ss; + for (k = 1; k <= npt; k++) { + if (k != kopt) { + dstemp = zero; + sstemp = zero; + for (i = 1; i <= n; i++) { + diff = XPT(k, i) - XOPT(i); + dstemp = dstemp + D(i) * diff; + sstemp = sstemp + diff * diff; + } + if (dstemp * dstemp / sstemp < dtest) { + ksav = k; + dtest = dstemp * dstemp / sstemp; + ds = dstemp; + ss = sstemp; + } + } + } + for (i = 1; i <= n; i++) { + S(i) = XPT(ksav, i) - XOPT(i); + } + } + ssden = dd * ss - ds * ds; + iterc = 0; + densav = zero; + + // Begin the iteration by overwriting S with a vector that has the + // required length and direction. +L70: + iterc = iterc + 1; + temp = one / std::sqrt(ssden); + xoptd = zero; + xopts = zero; + for (i = 1; i <= n; i++) { + S(i) = temp * (dd * S(i) - ds * D(i)); + xoptd = xoptd + XOPT(i) * D(i); + xopts = xopts + XOPT(i) * S(i); + } + + // Set the coefficients of the first two terms of BETA. + tempa = half * xoptd * xoptd; + tempb = half * xopts * xopts; + DEN(1) = dd * (xoptsq + half * dd) + tempa + tempb; + DEN(2) = two * xoptd * dd; + DEN(3) = two * xopts * dd; + DEN(4) = tempa - tempb; + DEN(5) = xoptd * xopts; + for (i = 6; i <= 9; i++) { + DEN(i) = zero; + } + + // Put the coefficients of Wcheck in WVEC. + for (k = 1; k <= npt; k++) { + tempa = zero; + tempb = zero; + tempc = zero; + for (i = 1; i <= n; i++) { + tempa = tempa + XPT(k, i) * D(i); + tempb = tempb + XPT(k, i) * S(i); + tempc = tempc + XPT(k, i) * XOPT(i); + } + WVEC(k, 1) = quart * (tempa * tempa + tempb * tempb); + WVEC(k, 2) = tempa * tempc; + WVEC(k, 3) = tempb * tempc; + WVEC(k, 4) = quart * (tempa * tempa - tempb * tempb); + WVEC(k, 5) = half * tempa * tempb; + } + for (i = 1; i <= n; i++) { + ip = i + npt; + WVEC(ip, 1) = zero; + WVEC(ip, 2) = D(i); + WVEC(ip, 3) = S(i); + WVEC(ip, 4) = zero; + WVEC(ip, 5) = zero; + } + + // Put the coefficents of THETA*Wcheck in PROD. + for (jc = 1; jc <= 5; jc++) { + nw = npt; + if (jc == 2 || jc == 3) nw = ndim; + for (k = 1; k <= npt; k++) { + PROD(k, jc) = zero; + } + for (j = 1; j <= nptm; j++) { + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + ZMAT(k, j) * WVEC(k, jc); + } + if (j < idz) sum = -sum; + for (k = 1; k <= npt; k++) { + PROD(k, jc) = PROD(k, jc) + sum * ZMAT(k, j); + } + } + if (nw == ndim) { + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= n; j++) { + sum = sum + BMAT(k, j) * WVEC(npt + j, jc); + } + PROD(k, jc) = PROD(k, jc) + sum; + } + } + for (j = 1; j <= n; j++) { + sum = zero; + for (i = 1; i <= nw; i++) { + sum = sum + BMAT(i, j) * WVEC(i, jc); + } + PROD(npt + j, jc) = sum; + } + } + + // Include in DEN the part of BETA that depends on THETA. + for (k = 1; k <= ndim; k++) { + sum = zero; + for (i = 1; i <= 5; i++) { + PAR(i) = half * PROD(k, i) * WVEC(k, i); + sum = sum + PAR(i); + } + DEN(1) = DEN(1) - PAR(1) - sum; + tempa = PROD(k, 1) * WVEC(k, 2) + PROD(k, 2) * WVEC(k, 1); + tempb = PROD(k, 2) * WVEC(k, 4) + PROD(k, 4) * WVEC(k, 2); + tempc = PROD(k, 3) * WVEC(k, 5) + PROD(k, 5) * WVEC(k, 3); + DEN(2) = DEN(2) - tempa - half * (tempb + tempc); + DEN(6) = DEN(6) - half * (tempb - tempc); + tempa = PROD(k, 1) * WVEC(k, 3) + PROD(k, 3) * WVEC(k, 1); + tempb = PROD(k, 2) * WVEC(k, 5) + PROD(k, 5) * WVEC(k, 2); + tempc = PROD(k, 3) * WVEC(k, 4) + PROD(k, 4) * WVEC(k, 3); + DEN(3) = DEN(3) - tempa - half * (tempb - tempc); + DEN(7) = DEN(7) - half * (tempb + tempc); + tempa = PROD(k, 1) * WVEC(k, 4) + PROD(k, 4) * WVEC(k, 1); + DEN(4) = DEN(4) - tempa - PAR(2) + PAR(3); + tempa = PROD(k, 1) * WVEC(k, 5) + PROD(k, 5) * WVEC(k, 1); + tempb = PROD(k, 2) * WVEC(k, 3) + PROD(k, 3) * WVEC(k, 2); + DEN(5) = DEN(5) - tempa - half * tempb; + DEN(8) = DEN(8) - PAR(4) + PAR(5); + tempa = PROD(k, 4) * WVEC(k, 5) + PROD(k, 5) * WVEC(k, 4); + DEN(9) = DEN(9) - half * tempa; + } + + // Extend DEN so that it holds all the coefficients of DENOM. + sum = zero; + for (i = 1; i <= 5; i++) { + PAR(i) = half * PROD(knew, i) * PROD(knew, i); + sum = sum + PAR(i); + } + DENEX(1) = alpha * DEN(1) + PAR(1) + sum; + tempa = two * PROD(knew, 1) * PROD(knew, 2); + tempb = PROD(knew, 2) * PROD(knew, 4); + tempc = PROD(knew, 3) * PROD(knew, 5); + DENEX(2) = alpha * DEN(2) + tempa + tempb + tempc; + DENEX(6) = alpha * DEN(6) + tempb - tempc; + tempa = two * PROD(knew, 1) * PROD(knew, 3); + tempb = PROD(knew, 2) * PROD(knew, 5); + tempc = PROD(knew, 3) * PROD(knew, 4); + DENEX(3) = alpha * DEN(3) + tempa + tempb - tempc; + DENEX(7) = alpha * DEN(7) + tempb + tempc; + tempa = two * PROD(knew, 1) * PROD(knew, 4); + DENEX(4) = alpha * DEN(4) + tempa + PAR(2) - PAR(3); + tempa = two * PROD(knew, 1) * PROD(knew, 5); + DENEX(5) = alpha * DEN(5) + tempa + PROD(knew, 2) * PROD(knew, 3); + DENEX(8) = alpha * DEN(8) + PAR(4) - PAR(5); + DENEX(9) = alpha * DEN(9) + PROD(knew, 4) * PROD(knew, 5); + + // Seek the value of the angle that maximizes the modulus of DENOM. + sum = DENEX(1) + DENEX(2) + DENEX(4) + DENEX(6) + DENEX(8); + denold = sum; + denmax = sum; + isave = 0; + iu = 49; + temp = twopi / static_cast(iu + 1); + PAR(1) = one; + for (i = 1; i <= iu; i++) { + angle = static_cast(i) * temp; + PAR(2) = std::cos(angle); + PAR(3) = std::sin(angle); + for (j = 4; j <= 8; j += 2) { + PAR(j) = PAR(2) * PAR(j - 2) - PAR(3) * PAR(j - 1); + PAR(j + 1) = PAR(2) * PAR(j - 1) + PAR(3) * PAR(j - 2); + } + sumold = sum; + sum = zero; + for (j = 1; j <= 9; j++) { + sum = sum + DENEX(j) * PAR(j); + } + if (std::fabs(sum) > std::fabs(denmax)) { + denmax = sum; + isave = i; + tempa = sumold; + } else if (i == isave + 1) { + tempb = sum; + } + } + if (isave == 0) tempa = sum; + if (isave == iu) tempb = denold; + step = zero; + if (tempa != tempb) { + tempa = tempa - denmax; + tempb = tempb - denmax; + step = half * (tempa - tempb) / (tempa + tempb); + } + angle = temp * (static_cast(isave) + step); + + // Calculate the new parameters of the denominator, the new VLAG vector + // and the new D. Then test for convergence. + PAR(2) = std::cos(angle); + PAR(3) = std::sin(angle); + for (j = 4; j <= 8; j += 2) { + PAR(j) = PAR(2) * PAR(j - 2) - PAR(3) * PAR(j - 1); + PAR(j + 1) = PAR(2) * PAR(j - 1) + PAR(3) * PAR(j - 2); + } + beta = zero; + denmax = zero; + for (j = 1; j <= 9; j++) { + beta = beta + DEN(j) * PAR(j); + denmax = denmax + DENEX(j) * PAR(j); + } + for (k = 1; k <= ndim; k++) { + VLAG(k) = zero; + for (j = 1; j <= 5; j++) { + VLAG(k) = VLAG(k) + PROD(k, j) * PAR(j); + } + } + tau = VLAG(knew); + dd = zero; + tempa = zero; + tempb = zero; + for (i = 1; i <= n; i++) { + D(i) = PAR(2) * D(i) + PAR(3) * S(i); + W(i) = XOPT(i) + D(i); + dd = dd + D(i) * D(i); + tempa = tempa + D(i) * W(i); + tempb = tempb + W(i) * W(i); + } + if (iterc >= n) goto L340; + if (iterc > 1) densav = std::max(densav, denold); + if (std::fabs(denmax) <= 1.1e0 * std::fabs(densav)) goto L340; + densav = denmax; + + // Set S to half the gradient of the denominator with respect to D. + // Then branch for the next iteration. + for (i = 1; i <= n; i++) { + temp = tempa * XOPT(i) + tempb * D(i) - VLAG(npt + i); + S(i) = tau * BMAT(knew, i) + alpha * temp; + } + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= n; j++) { + sum = sum + XPT(k, j) * W(j); + } + temp = (tau * W(n + k) - alpha * VLAG(k)) * sum; + for (i = 1; i <= n; i++) { + S(i) = S(i) + temp * XPT(k, i); + } + } + ss = zero; + ds = zero; + for (i = 1; i <= n; i++) { + ss = ss + S(i) * S(i); + ds = ds + D(i) * S(i); + } + ssden = dd * ss - ds * ds; + if (ssden >= 1.0e-8 * dd * ss) goto L70; + + // Set the vector W before the RETURN from the subroutine. +L340: + for (k = 1; k <= ndim; k++) { + W(k) = zero; + for (j = 1; j <= 5; j++) { + W(k) = W(k) + WVEC(k, j) * PAR(j); + } + } + VLAG(kopt) = VLAG(kopt) + one; + return; +#undef XOPT +#undef XPT +#undef BMAT +#undef ZMAT +#undef D +#undef W +#undef VLAG +#undef S +#undef WVEC +#undef PROD +#undef DEN +#undef DENEX +#undef PAR +} + +// --------------------------------------------------------------------------- +// update.f: SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,IDZ,NDIM,VLAG,BETA,KNEW,W) +// --------------------------------------------------------------------------- +void update(int n, int npt, double *bmat, double *zmat, int &idz, int ndim, + double *vlag, double beta, int knew, double *w) { +#define BMAT(I, J) bmat[((I) - 1) + ((J) - 1) * ndim] +#define ZMAT(I, J) zmat[((I) - 1) + ((J) - 1) * npt] +#define VLAG(I) vlag[(I) - 1] +#define W(I) w[(I) - 1] + double one, zero, temp, tempa, tempb, alpha, tau, tausq, denom, scala, + scalb; + int nptm, jl, i, j, iflag, ja, jb, jp; + temp = tempa = tempb = alpha = tau = tausq = denom = scala = scalb = 0.0; + ja = jb = jp = 0; + + one = 1.0e0; + zero = 0.0e0; + nptm = npt - n - 1; + + // Apply the rotations that put zeros in the KNEW-th row of ZMAT. + jl = 1; + for (j = 2; j <= nptm; j++) { + if (j == idz) { + jl = idz; + } else if (ZMAT(knew, j) != zero) { + temp = std::sqrt(ZMAT(knew, jl) * ZMAT(knew, jl) + + ZMAT(knew, j) * ZMAT(knew, j)); + tempa = ZMAT(knew, jl) / temp; + tempb = ZMAT(knew, j) / temp; + for (i = 1; i <= npt; i++) { + temp = tempa * ZMAT(i, jl) + tempb * ZMAT(i, j); + ZMAT(i, j) = tempa * ZMAT(i, j) - tempb * ZMAT(i, jl); + ZMAT(i, jl) = temp; + } + ZMAT(knew, j) = zero; + } + } + + // Put the first NPT components of the KNEW-th column of HLAG into W, + // and calculate the parameters of the updating formula. + tempa = ZMAT(knew, 1); + if (idz >= 2) tempa = -tempa; + if (jl > 1) tempb = ZMAT(knew, jl); + for (i = 1; i <= npt; i++) { + W(i) = tempa * ZMAT(i, 1); + if (jl > 1) W(i) = W(i) + tempb * ZMAT(i, jl); + } + alpha = W(knew); + tau = VLAG(knew); + tausq = tau * tau; + denom = alpha * beta + tausq; + VLAG(knew) = VLAG(knew) - one; + + // Complete the updating of ZMAT when there is only one nonzero element + // in the KNEW-th row of the new matrix ZMAT, but, if IFLAG is set to one, + // then the first column of ZMAT will be exchanged with another one later. + iflag = 0; + if (jl == 1) { + temp = std::sqrt(std::fabs(denom)); + tempb = tempa / temp; + tempa = tau / temp; + for (i = 1; i <= npt; i++) { + ZMAT(i, 1) = tempa * ZMAT(i, 1) - tempb * VLAG(i); + } + if (idz == 1 && temp < zero) idz = 2; + if (idz >= 2 && temp >= zero) iflag = 1; + } else { + // Complete the updating of ZMAT in the alternative case. + ja = 1; + if (beta >= zero) ja = jl; + jb = jl + 1 - ja; + temp = ZMAT(knew, jb) / denom; + tempa = temp * beta; + tempb = temp * tau; + temp = ZMAT(knew, ja); + scala = one / std::sqrt(std::fabs(beta) * temp * temp + tausq); + scalb = scala * std::sqrt(std::fabs(denom)); + for (i = 1; i <= npt; i++) { + ZMAT(i, ja) = scala * (tau * ZMAT(i, ja) - temp * VLAG(i)); + ZMAT(i, jb) = scalb * (ZMAT(i, jb) - tempa * W(i) - tempb * VLAG(i)); + } + if (denom <= zero) { + if (beta < zero) idz = idz + 1; + if (beta >= zero) iflag = 1; + } + } + + // IDZ is reduced in the following case, and usually the first column + // of ZMAT is exchanged with a later one. + if (iflag == 1) { + idz = idz - 1; + for (i = 1; i <= npt; i++) { + temp = ZMAT(i, 1); + ZMAT(i, 1) = ZMAT(i, idz); + ZMAT(i, idz) = temp; + } + } + + // Finally, update the matrix BMAT. + for (j = 1; j <= n; j++) { + jp = npt + j; + W(jp) = BMAT(knew, j); + tempa = (alpha * VLAG(jp) - tau * W(jp)) / denom; + tempb = (-beta * W(jp) - tau * VLAG(jp)) / denom; + for (i = 1; i <= jp; i++) { + BMAT(i, j) = BMAT(i, j) + tempa * VLAG(i) + tempb * W(i); + if (i > npt) BMAT(jp, i - npt) = BMAT(i, j); + } + } + return; +#undef BMAT +#undef ZMAT +#undef VLAG +#undef W +} + +// --------------------------------------------------------------------------- +// newuob.f: SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, +// XOPT,XNEW,XPT,FVAL,GQ,HQ,PQ,BMAT,ZMAT,NDIM,D,VLAG,W,IERR) +// --------------------------------------------------------------------------- +void newuob(int n, int npt, double *x, double rhobeg, double rhoend, + int iprint, int maxfun, double *xbase, double *xopt, + double *xnew, double *xpt, double *fval, double *gq, double *hq, + double *pq, double *bmat, double *zmat, int ndim, double *d, + double *vlag, double *w, int &ierr, MinqaCalfun &calfun) { +#define X(I) x[(I) - 1] +#define XBASE(I) xbase[(I) - 1] +#define XOPT(I) xopt[(I) - 1] +#define XNEW(I) xnew[(I) - 1] +#define XPT(I, J) xpt[((I) - 1) + ((J) - 1) * npt] +#define FVAL(I) fval[(I) - 1] +#define GQ(I) gq[(I) - 1] +#define HQ(I) hq[(I) - 1] +#define PQ(I) pq[(I) - 1] +#define BMAT(I, J) bmat[((I) - 1) + ((J) - 1) * ndim] +#define ZMAT(I, J) zmat[((I) - 1) + ((J) - 1) * npt] +#define D(I) d[(I) - 1] +#define VLAG(I) vlag[(I) - 1] +#define W(I) w[(I) - 1] + double half, one, tenth, zero, rhosq, recip, reciq, xipt, xjpt, f, fbeg, + fopt, temp, rho, delta, diffa, diffb, diffc, xoptsq, crvmin, dsq, dnorm, + ratio, tempq, sum, sumz, dstep, alpha, suma, sumb, beta, bsum, dx, + vquad, diff, fsave, detrat, hdiag, distsq, gqsq, gisq; + int np, nh, nptm, nftest, i, j, k, ih, nf, nfm, nfmm, itemp, jpt, ipt, + kopt, idz, itest, nfsav, knew, ip, jp, ksave, ktemp; + xipt = xjpt = f = fbeg = fopt = temp = rho = delta = diffa = diffb = diffc = + xoptsq = crvmin = dsq = dnorm = ratio = tempq = sum = sumz = dstep = + alpha = suma = sumb = beta = bsum = dx = vquad = diff = fsave = + detrat = hdiag = distsq = gqsq = gisq = 0.0; + itemp = jpt = ipt = kopt = idz = itest = nfsav = knew = ip = jp = ksave = + ktemp = 0; + + // Set some constants. + half = 0.5e0; + one = 1.0e0; + tenth = 0.1e0; + zero = 0.0e0; + np = n + 1; + nh = (n * np) / 2; + nptm = npt - np; + nftest = std::max(maxfun, 1); + + // Set the initial elements of XPT, BMAT, HQ, PQ and ZMAT to zero. + for (j = 1; j <= n; j++) { + XBASE(j) = X(j); + for (k = 1; k <= npt; k++) { + XPT(k, j) = zero; + } + for (i = 1; i <= ndim; i++) { + BMAT(i, j) = zero; + } + } + for (ih = 1; ih <= nh; ih++) { + HQ(ih) = zero; + } + for (k = 1; k <= npt; k++) { + PQ(k) = zero; + for (j = 1; j <= nptm; j++) { + ZMAT(k, j) = zero; + } + } + + // Begin the initialization procedure. NF becomes one more than the number + // of function values so far. The coordinates of the displacement of the + // next initial interpolation point from XBASE are set in XPT(NF,.). + rhosq = rhobeg * rhobeg; + recip = one / rhosq; + reciq = std::sqrt(half) / rhosq; + nf = 0; +L50: + nfm = nf; + nfmm = nf - n; + nf = nf + 1; + if (nfm <= 2 * n) { + if (nfm >= 1 && nfm <= n) { + XPT(nf, nfm) = rhobeg; + } else if (nfm > n) { + XPT(nf, nfmm) = -rhobeg; + } + } else { + itemp = (nfmm - 1) / n; + jpt = nfm - itemp * n - n; + ipt = jpt + itemp; + if (ipt > n) { + itemp = jpt; + jpt = ipt - n; + ipt = itemp; + } + xipt = rhobeg; + if (FVAL(ipt + np) < FVAL(ipt + 1)) xipt = -xipt; + xjpt = rhobeg; + if (FVAL(jpt + np) < FVAL(jpt + 1)) xjpt = -xjpt; + XPT(nf, ipt) = xipt; + XPT(nf, jpt) = xjpt; + } + + // Calculate the next value of F, label 70 being reached immediately + // after this calculation. The least function value so far and its index + // are required. + for (j = 1; j <= n; j++) { + X(j) = XPT(nf, j) + XBASE(j); + } + goto L310; +L70: + FVAL(nf) = f; + if (nf == 1) { + fbeg = f; + fopt = f; + kopt = 1; + } else if (f < fopt) { + fopt = f; + kopt = nf; + } + + // Set the nonzero initial elements of BMAT and the quadratic model in + // the cases when NF is at most 2*N+1. + if (nfm <= 2 * n) { + if (nfm >= 1 && nfm <= n) { + GQ(nfm) = (f - fbeg) / rhobeg; + if (npt < nf + n) { + BMAT(1, nfm) = -one / rhobeg; + BMAT(nf, nfm) = one / rhobeg; + BMAT(npt + nfm, nfm) = -half * rhosq; + } + } else if (nfm > n) { + BMAT(nf - n, nfmm) = half / rhobeg; + BMAT(nf, nfmm) = -half / rhobeg; + ZMAT(1, nfmm) = -reciq - reciq; + ZMAT(nf - n, nfmm) = reciq; + ZMAT(nf, nfmm) = reciq; + ih = (nfmm * (nfmm + 1)) / 2; + temp = (fbeg - f) / rhobeg; + HQ(ih) = (GQ(nfmm) - temp) / rhobeg; + GQ(nfmm) = half * (GQ(nfmm) + temp); + } + + // Set the off-diagonal second derivatives of the Lagrange functions and + // the initial quadratic model. + } else { + ih = (ipt * (ipt - 1)) / 2 + jpt; + if (xipt < zero) ipt = ipt + n; + if (xjpt < zero) jpt = jpt + n; + ZMAT(1, nfmm) = recip; + ZMAT(nf, nfmm) = recip; + ZMAT(ipt + 1, nfmm) = -recip; + ZMAT(jpt + 1, nfmm) = -recip; + HQ(ih) = (fbeg - FVAL(ipt + 1) - FVAL(jpt + 1) + f) / (xipt * xjpt); + } + if (nf < npt) goto L50; + + // Begin the iterative procedure, because the initial model is complete. + rho = rhobeg; + delta = rho; + idz = 1; + diffa = zero; + diffb = zero; + itest = 0; + xoptsq = zero; + for (i = 1; i <= n; i++) { + XOPT(i) = XPT(kopt, i); + xoptsq = xoptsq + XOPT(i) * XOPT(i); + } +L90: + nfsav = nf; + + // Generate the next trust region step and test its length. Set KNEW + // to -1 if the purpose of the next F will be to improve the model. +L100: + knew = 0; + trsapp(n, npt, xopt, xpt, gq, hq, pq, delta, d, w, &W(np), &W(np + n), + &W(np + 2 * n), crvmin); + dsq = zero; + for (i = 1; i <= n; i++) { + dsq = dsq + D(i) * D(i); + } + dnorm = std::min(delta, std::sqrt(dsq)); + if (dnorm < half * rho) { + knew = -1; + delta = tenth * delta; + ratio = -1.0e0; + if (delta <= 1.5e0 * rho) delta = rho; + if (nf <= nfsav + 2) goto L460; + temp = 0.125e0 * crvmin * rho * rho; + if (temp <= std::max(std::max(diffa, diffb), diffc)) goto L460; + goto L490; + } + + // Shift XBASE if XOPT may be too far from XBASE. First make the changes + // to BMAT that do not depend on ZMAT. +L120: + if (dsq <= 1.0e-3 * xoptsq) { + tempq = 0.25e0 * xoptsq; + for (k = 1; k <= npt; k++) { + sum = zero; + for (i = 1; i <= n; i++) { + sum = sum + XPT(k, i) * XOPT(i); + } + temp = PQ(k) * sum; + sum = sum - half * xoptsq; + W(npt + k) = sum; + for (i = 1; i <= n; i++) { + GQ(i) = GQ(i) + temp * XPT(k, i); + XPT(k, i) = XPT(k, i) - half * XOPT(i); + VLAG(i) = BMAT(k, i); + W(i) = sum * XPT(k, i) + tempq * XOPT(i); + ip = npt + i; + for (j = 1; j <= i; j++) { + BMAT(ip, j) = BMAT(ip, j) + VLAG(i) * W(j) + W(i) * VLAG(j); + } + } + } + + // Then the revisions of BMAT that depend on ZMAT are calculated. + for (k = 1; k <= nptm; k++) { + sumz = zero; + for (i = 1; i <= npt; i++) { + sumz = sumz + ZMAT(i, k); + W(i) = W(npt + i) * ZMAT(i, k); + } + for (j = 1; j <= n; j++) { + sum = tempq * sumz * XOPT(j); + for (i = 1; i <= npt; i++) { + sum = sum + W(i) * XPT(i, j); + } + VLAG(j) = sum; + if (k < idz) sum = -sum; + for (i = 1; i <= npt; i++) { + BMAT(i, j) = BMAT(i, j) + sum * ZMAT(i, k); + } + } + for (i = 1; i <= n; i++) { + ip = i + npt; + temp = VLAG(i); + if (k < idz) temp = -temp; + for (j = 1; j <= i; j++) { + BMAT(ip, j) = BMAT(ip, j) + temp * VLAG(j); + } + } + } + + // The following instructions complete the shift of XBASE, including + // the changes to the parameters of the quadratic model. + ih = 0; + for (j = 1; j <= n; j++) { + W(j) = zero; + for (k = 1; k <= npt; k++) { + W(j) = W(j) + PQ(k) * XPT(k, j); + XPT(k, j) = XPT(k, j) - half * XOPT(j); + } + for (i = 1; i <= j; i++) { + ih = ih + 1; + if (i < j) GQ(j) = GQ(j) + HQ(ih) * XOPT(i); + GQ(i) = GQ(i) + HQ(ih) * XOPT(j); + HQ(ih) = HQ(ih) + W(i) * XOPT(j) + XOPT(i) * W(j); + BMAT(npt + i, j) = BMAT(npt + j, i); + } + } + for (j = 1; j <= n; j++) { + XBASE(j) = XBASE(j) + XOPT(j); + XOPT(j) = zero; + } + xoptsq = zero; + } + + // Pick the model step if KNEW is positive. A different choice of D + // may be made later, if the choice of D by BIGLAG causes substantial + // cancellation in DENOM. + if (knew > 0) { + biglag(n, npt, xopt, xpt, bmat, zmat, idz, ndim, knew, dstep, d, alpha, + vlag, &VLAG(npt + 1), w, &W(np), &W(np + n)); + } + + // Calculate VLAG and BETA for the current choice of D. The first NPT + // components of W_check will be held in W. + for (k = 1; k <= npt; k++) { + suma = zero; + sumb = zero; + sum = zero; + for (j = 1; j <= n; j++) { + suma = suma + XPT(k, j) * D(j); + sumb = sumb + XPT(k, j) * XOPT(j); + sum = sum + BMAT(k, j) * D(j); + } + W(k) = suma * (half * suma + sumb); + VLAG(k) = sum; + } + beta = zero; + for (k = 1; k <= nptm; k++) { + sum = zero; + for (i = 1; i <= npt; i++) { + sum = sum + ZMAT(i, k) * W(i); + } + if (k < idz) { + beta = beta + sum * sum; + sum = -sum; + } else { + beta = beta - sum * sum; + } + for (i = 1; i <= npt; i++) { + VLAG(i) = VLAG(i) + sum * ZMAT(i, k); + } + } + bsum = zero; + dx = zero; + for (j = 1; j <= n; j++) { + sum = zero; + for (i = 1; i <= npt; i++) { + sum = sum + W(i) * BMAT(i, j); + } + bsum = bsum + sum * D(j); + jp = npt + j; + for (k = 1; k <= n; k++) { + sum = sum + BMAT(jp, k) * D(k); + } + VLAG(jp) = sum; + bsum = bsum + sum * D(j); + dx = dx + D(j) * XOPT(j); + } + beta = dx * dx + dsq * (xoptsq + dx + dx + half * dsq) + beta - bsum; + VLAG(kopt) = VLAG(kopt) + one; + + // If KNEW is positive and if the cancellation in DENOM is unacceptable, + // then BIGDEN calculates an alternative model step, XNEW being used for + // working space. + if (knew > 0) { + temp = one + alpha * beta / (VLAG(knew) * VLAG(knew)); + if (std::fabs(temp) <= 0.8e0) { + bigden(n, npt, xopt, xpt, bmat, zmat, idz, ndim, kopt, knew, d, w, vlag, + beta, xnew, &W(ndim + 1), &W(6 * ndim + 1)); + } + } + + // Calculate the next value of the objective function. +L290: + for (i = 1; i <= n; i++) { + XNEW(i) = XOPT(i) + D(i); + X(i) = XBASE(i) + XNEW(i); + } + nf = nf + 1; +L310: + if (nf > nftest) { + nf = nf - 1; + ierr = 390; + goto L530; + } + f = calfun(x); + if (nf <= npt) goto L70; + if (knew == -1) goto L530; + + // Use the quadratic model to predict the change in F due to the step D, + // and set DIFF to the error of this prediction. + vquad = zero; + ih = 0; + for (j = 1; j <= n; j++) { + vquad = vquad + D(j) * GQ(j); + for (i = 1; i <= j; i++) { + ih = ih + 1; + temp = D(i) * XNEW(j) + D(j) * XOPT(i); + if (i == j) temp = half * temp; + vquad = vquad + temp * HQ(ih); + } + } + for (k = 1; k <= npt; k++) { + vquad = vquad + PQ(k) * W(k); + } + diff = f - fopt - vquad; + diffc = diffb; + diffb = diffa; + diffa = std::fabs(diff); + if (dnorm > rho) nfsav = nf; + + // Update FOPT and XOPT if the new F is the least value of the objective + // function so far. The branch when KNEW is positive occurs if D is not + // a trust region step. + fsave = fopt; + if (f < fopt) { + fopt = f; + xoptsq = zero; + for (i = 1; i <= n; i++) { + XOPT(i) = XNEW(i); + xoptsq = xoptsq + XOPT(i) * XOPT(i); + } + } + ksave = knew; + if (knew > 0) goto L410; + + // Pick the next value of DELTA after a trust region step. + if (vquad >= zero) { + ierr = 3701; + goto L530; + } + ratio = (f - fsave) / vquad; + if (ratio <= tenth) { + delta = half * dnorm; + } else if (ratio <= 0.7e0) { + delta = std::max(half * delta, dnorm); + } else { + delta = std::max(half * delta, dnorm + dnorm); + } + if (delta <= 1.5e0 * rho) delta = rho; + + // Set KNEW to the index of the next interpolation point to be deleted. + rhosq = std::max(tenth * delta, rho) * std::max(tenth * delta, rho); + ktemp = 0; + detrat = zero; + if (f >= fsave) { + ktemp = kopt; + detrat = one; + } + for (k = 1; k <= npt; k++) { + hdiag = zero; + for (j = 1; j <= nptm; j++) { + temp = one; + if (j < idz) temp = -one; + hdiag = hdiag + temp * ZMAT(k, j) * ZMAT(k, j); + } + temp = std::fabs(beta * hdiag + VLAG(k) * VLAG(k)); + distsq = zero; + for (j = 1; j <= n; j++) { + distsq = distsq + (XPT(k, j) - XOPT(j)) * (XPT(k, j) - XOPT(j)); + } + if (distsq > rhosq) { + temp = temp * ((distsq / rhosq) * (distsq / rhosq) * (distsq / rhosq)); + } + if (temp > detrat && k != ktemp) { + detrat = temp; + knew = k; + } + } + if (knew == 0) goto L460; + + // Update BMAT, ZMAT and IDZ, so that the KNEW-th interpolation point + // can be moved. Begin the updating of the quadratic model, starting + // with the explicit second derivative term. +L410: + update(n, npt, bmat, zmat, idz, ndim, vlag, beta, knew, w); + FVAL(knew) = f; + ih = 0; + for (i = 1; i <= n; i++) { + temp = PQ(knew) * XPT(knew, i); + for (j = 1; j <= i; j++) { + ih = ih + 1; + HQ(ih) = HQ(ih) + temp * XPT(knew, j); + } + } + PQ(knew) = zero; + + // Update the other second derivative parameters, and then the gradient + // vector of the model. Also include the new interpolation point. + for (j = 1; j <= nptm; j++) { + temp = diff * ZMAT(knew, j); + if (j < idz) temp = -temp; + for (k = 1; k <= npt; k++) { + PQ(k) = PQ(k) + temp * ZMAT(k, j); + } + } + gqsq = zero; + for (i = 1; i <= n; i++) { + GQ(i) = GQ(i) + diff * BMAT(knew, i); + gqsq = gqsq + GQ(i) * GQ(i); + XPT(knew, i) = XNEW(i); + } + + // If a trust region step makes a small change to the objective function, + // then calculate the gradient of the least Frobenius norm interpolant at + // XBASE, and store it in W, using VLAG for a vector of right hand sides. + if (ksave == 0 && delta == rho) { + if (std::fabs(ratio) > 1.0e-2) { + itest = 0; + } else { + for (k = 1; k <= npt; k++) { + VLAG(k) = FVAL(k) - FVAL(kopt); + } + gisq = zero; + for (i = 1; i <= n; i++) { + sum = zero; + for (k = 1; k <= npt; k++) { + sum = sum + BMAT(k, i) * VLAG(k); + } + gisq = gisq + sum * sum; + W(i) = sum; + } + + // Test whether to replace the new quadratic model by the least + // Frobenius norm interpolant, making the replacement if the test is + // satisfied. + itest = itest + 1; + if (gqsq < 1.0e2 * gisq) itest = 0; + if (itest >= 3) { + for (i = 1; i <= n; i++) { + GQ(i) = W(i); + } + for (ih = 1; ih <= nh; ih++) { + HQ(ih) = zero; + } + for (j = 1; j <= nptm; j++) { + W(j) = zero; + for (k = 1; k <= npt; k++) { + W(j) = W(j) + VLAG(k) * ZMAT(k, j); + } + if (j < idz) W(j) = -W(j); + } + for (k = 1; k <= npt; k++) { + PQ(k) = zero; + for (j = 1; j <= nptm; j++) { + PQ(k) = PQ(k) + ZMAT(k, j) * W(j); + } + } + itest = 0; + } + } + } + if (f < fsave) kopt = knew; + + // If a trust region step has provided a sufficient decrease in F, then + // branch for another trust region calculation. The case KSAVE>0 occurs + // when the new function value was calculated by a model step. + if (f <= fsave + tenth * vquad) goto L100; + if (ksave > 0) goto L100; + + // Alternatively, find out if the interpolation points are close enough + // to the best point so far. + knew = 0; +L460: + distsq = 4.0e0 * delta * delta; + for (k = 1; k <= npt; k++) { + sum = zero; + for (j = 1; j <= n; j++) { + sum = sum + (XPT(k, j) - XOPT(j)) * (XPT(k, j) - XOPT(j)); + } + if (sum > distsq) { + knew = k; + distsq = sum; + } + } + + // If KNEW is positive, then set DSTEP, and branch back for the next + // iteration, which will generate a "model step". + if (knew > 0) { + dstep = std::max(std::min(tenth * std::sqrt(distsq), half * delta), rho); + dsq = dstep * dstep; + goto L120; + } + if (ratio > zero) goto L100; + if (std::max(delta, dnorm) > rho) goto L100; + + // The calculations with the current value of RHO are complete. Pick the + // next values of RHO and DELTA. +L490: + if (rho > rhoend) { + delta = half * rho; + ratio = rho / rhoend; + if (ratio <= 16.0e0) { + rho = rhoend; + } else if (ratio <= 250.0e0) { + rho = std::sqrt(ratio) * rhoend; + } else { + rho = tenth * rho; + } + delta = std::max(delta, rho); + if (iprint >= 2) { + calfun.minqit(rho, nf, fopt, xbase, xopt); + } + goto L90; + } + + // Return from the calculation, after another Newton-Raphson step, if + // it is too short to have been tried before. + if (knew == -1) goto L290; +L530: + if (fopt <= f) { + for (i = 1; i <= n; i++) { + X(i) = XBASE(i) + XOPT(i); + } + f = fopt; + } + if (iprint >= 1) { + calfun.minqir(f, nf, x); + } + return; +#undef X +#undef XBASE +#undef XOPT +#undef XNEW +#undef XPT +#undef FVAL +#undef GQ +#undef HQ +#undef PQ +#undef BMAT +#undef ZMAT +#undef D +#undef VLAG +#undef W +} + +// --------------------------------------------------------------------------- +// newuoa.f: SUBROUTINE NEWUOA (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W,IERR) +// --------------------------------------------------------------------------- +void newuoa(int n, int npt, double *x, double rhobeg, double rhoend, + int iprint, int maxfun, double *w, int &ierr, + MinqaCalfun &calfun) { +#define W(I) w[(I) - 1] + int np, nptm, ndim, ixb, ixo, ixn, ixp, ifv, igq, ihq, ipq, ibmat, izmat, + id, ivl, iw; + + // Partition the working space array, so that different parts of it can be + // treated separately by the subroutine that performs the main calculation. + np = n + 1; + nptm = npt - np; + if (npt < n + 2 || npt > ((n + 2) * np) / 2) { + ierr = 10; + goto L20; + } + ndim = npt + n; + ixb = 1; + ixo = ixb + n; + ixn = ixo + n; + ixp = ixn + n; + ifv = ixp + n * npt; + igq = ifv + npt; + ihq = igq + n; + ipq = ihq + (n * np) / 2; + ibmat = ipq + npt; + izmat = ibmat + ndim * n; + id = izmat + npt * nptm; + ivl = id + n; + iw = ivl + ndim; + + // The above settings provide a partition of W for subroutine NEWUOB. + // The partition requires the first NPT*(NPT+N)+5*N*(N+3)/2 elements of + // W plus the space that is needed by the last array of NEWUOB. + newuob(n, npt, x, rhobeg, rhoend, iprint, maxfun, &W(ixb), &W(ixo), + &W(ixn), &W(ixp), &W(ifv), &W(igq), &W(ihq), &W(ipq), &W(ibmat), + &W(izmat), ndim, &W(id), &W(ivl), &W(iw), ierr, calfun); +L20: + return; +#undef W +} + +} // namespace + +// Thread-safe replacement for minqa.cpp's newuoa_cpp(). +extern "C" int newuoa_solve_c(int n, const double *par, + minqa_c_objfun_t objfun, void *userdata, + const minqa_options_t *opts, + minqa_result_t *result) { + minqa_options_t defopts; + if (opts == nullptr && n > 0 && par != nullptr) { + defopts = minqa_options_default(n, par); + opts = &defopts; + } + if (opts == nullptr) { + if (result != nullptr) { + minqa_result_zero(result); + result->n = n; + result->ierr = MINQA_ERR_INVALID; + } + return MINQA_ERR_INVALID; + } + int chk = minqa_check_args(n, par, objfun, opts, result); + if (chk != MINQA_OK) return chk; + MinqaCalfun calfun(objfun, userdata, n, opts); + std::vector x, w; + int np = opts->npt; + try { + x.assign(par, par + n); + // Same size as minqa.cpp: (np+13)*(np+n)+(3*n*(n+3))/2. It is only + // clamped to at least one element so that an invalid (negative) npt + // still reaches NEWUOA's IERR = 10 check instead of a length_error. + long long wlen = (static_cast(np) + 13) * + (static_cast(np) + n) + + (3LL * n * (n + 3)) / 2; + w.assign(static_cast(std::max(wlen, 1LL)), 0.0); + } catch (const std::bad_alloc &) { + minqa_result_zero(result); + result->n = n; + result->ierr = MINQA_ERR_NOMEM; + return MINQA_ERR_NOMEM; + } + return minqa_run(n, x.data(), calfun, result, [&]() -> int { + int ierr = 0; + newuoa(n, np, x.data(), opts->rhobeg, opts->rhoend, opts->iprint, + opts->maxfun, w.data(), ierr, calfun); + return ierr; + }); +} diff --git a/src/minqa_r_interface.cpp b/src/minqa_r_interface.cpp new file mode 100644 index 0000000..bb0dfca --- /dev/null +++ b/src/minqa_r_interface.cpp @@ -0,0 +1,102 @@ +// R-objfun entry points for the BOBYQA/NEWUOA ports, called by the +// shims in R/minqa.R. These replace minqa's bobyqa_cpp/newuoa_cpp + +// calfun()/rval() glue, but drive the same thread-safe +// *_solve_c() cores a C/C++ consumer calls -- only the objective callback +// (which evaluates an R closure, so is main-thread only) differs. +#include +#include +#include "minqa_types.h" +using namespace Rcpp; + +namespace { + +struct MinqaRObjfun { + SEXP fn; + std::exception_ptr error; +}; + +// Mirrors minqa's calfun(): Rf_asReal(fn(x)), evaluated in fn's +// environment. Any R error (or interrupt) is captured and re-thrown by the +// caller once the solver has unwound, so no longjmp crosses the core. +int minqa_r_objfun(int n, const double *x, double *f, void *userdata) { + MinqaRObjfun *d = static_cast(userdata); + try { + NumericVector xx(x, x + n); + Function fn(d->fn); + SEXP v = fn(xx); + // Coerce odd returns through R (unwind-protected by Rcpp) so a coercion + // warning promoted to an error can't longjmp across the solver frames; + // the value is the same NA-or-number Rf_asReal() gives minqa. + if (!Rf_isNumeric(v) && !Rf_isLogical(v)) v = Function("as.double")(v); + *f = Rf_asReal(v); + return 0; + } catch (...) { + d->error = std::current_exception(); + return -1; + } +} + +void minqa_r_print(const char *line, void *) { Rprintf("%s", line); } + +minqa_options_t minqa_r_options(Environment ctrl) { + minqa_options_t opts; + opts.npt = as(ctrl.get("npt")); + opts.rhobeg = as(ctrl.get("rhobeg")); + opts.rhoend = as(ctrl.get("rhoend")); + opts.iprint = as(ctrl.get("iprint")); + opts.maxfun = as(ctrl.get("maxfun")); + opts.print = minqa_r_print; + opts.print_userdata = nullptr; + return opts; +} + +// Shape of minqa's rval() list (before the R shim adds `msg`). +List minqa_r_result(int n, minqa_result_t &res, MinqaRObjfun &d, + const char *cls) { + if (d.error) { + minqa_result_free(&res); + std::rethrow_exception(d.error); + } + if (res.ierr == MINQA_ERR_NONFINITE_X) { + minqa_result_free(&res); + Rcpp::stop("non-finite x values not allowed in calfun"); + } + if (res.ierr < 0 || res.par == nullptr) { + int code = res.ierr; + minqa_result_free(&res); + Rcpp::stop("minqa solver failed with internal error code %d", code); + } + NumericVector par(res.par, res.par + n); + double fval = res.fval; + int raw = res.raw_ierr; + IntegerVector feval = IntegerVector::create(res.feval); + minqa_result_free(&res); + List rr = List::create(_["par"] = par, _["fval"] = fval, + _["feval"] = feval, _["ierr"] = raw); + rr.attr("class") = CharacterVector::create(cls, "minqa"); + return rr; +} + +} // namespace + +// [[Rcpp::export]] +List minqa_bobyqa_r(NumericVector par, NumericVector lower, NumericVector upper, + Environment ctrl, Function fn) { + int n = par.size(); + MinqaRObjfun d{fn, nullptr}; + minqa_options_t opts = minqa_r_options(ctrl); + minqa_result_t res; + bobyqa_solve_c(n, par.begin(), lower.begin(), upper.begin(), minqa_r_objfun, + &d, &opts, &res); + return minqa_r_result(n, res, d, "bobyqa"); +} + +// [[Rcpp::export]] +List minqa_newuoa_r(NumericVector par, Environment ctrl, Function fn) { + int n = par.size(); + MinqaRObjfun d{fn, nullptr}; + minqa_options_t opts = minqa_r_options(ctrl); + minqa_result_t res; + newuoa_solve_c(n, par.begin(), minqa_r_objfun, &d, &opts, &res); + return minqa_r_result(n, res, d, "newuoa"); +} diff --git a/src/minqa_types.h b/src/minqa_types.h new file mode 100644 index 0000000..d1ac226 --- /dev/null +++ b/src/minqa_types.h @@ -0,0 +1,6 @@ +#ifndef MINQA_TYPES_SRC_FORWARD_H +#define MINQA_TYPES_SRC_FORWARD_H +/* Canonical definitions live in inst/include/minqa_types.h (see + * trust_types.h for why). */ +#include "../inst/include/minqa_types.h" +#endif diff --git a/src/solver_test_objfuns.cpp b/src/solver_test_objfuns.cpp new file mode 100644 index 0000000..fe9c67e --- /dev/null +++ b/src/solver_test_objfuns.cpp @@ -0,0 +1,271 @@ +// Native C objectives and OpenMP stress-test shims for the BOBYQA, NEWUOA +// and Steihaug ports, used only by tests/testthat (mirrors +// trust_test_objfuns.cpp's trust_openmp_stress_test for trust_solve_c()). +#include +#include +#include +#include +#include +#include +#include "minqa_types.h" +#include "steihaug_types.h" +#ifdef _OPENMP +#include +#endif +using namespace Rcpp; + +namespace { + +// Extended Rosenbrock, sum_i 100 (x_{i+1} - x_i^2)^2 + (1 - x_i)^2. +double ext_rosen(int n, const double *x) { + double f = 0.0; + for (int i = 0; i + 1 < n; i++) { + double t = x[i + 1] - x[i] * x[i]; + f += 100.0 * t * t + (1.0 - x[i]) * (1.0 - x[i]); + } + return f; +} + +int minqa_test_rosen(int n, const double *x, double *f, void *) { + *f = ext_rosen(n, x); + return 0; +} + +void ext_rosen_grad(int n, const double *x, double *g) { + for (int i = 0; i < n; i++) g[i] = 0.0; + for (int i = 0; i + 1 < n; i++) { + double t = x[i + 1] - x[i] * x[i]; + g[i] += -400.0 * x[i] * t - 2.0 * (1.0 - x[i]); + g[i + 1] += 200.0 * t; + } +} + +void ext_rosen_hess(int n, const double *x, double *h) { + for (int i = 0; i < n * n; i++) h[i] = 0.0; + for (int i = 0; i + 1 < n; i++) { + h[i * n + i] += 1200.0 * x[i] * x[i] - 400.0 * x[i + 1] + 2.0; + h[i * n + i + 1] += -400.0 * x[i]; + h[(i + 1) * n + i] += -400.0 * x[i]; + h[(i + 1) * n + i + 1] += 200.0; + } +} + +int steihaug_test_rosen(int n, const double *x, double *value, double *gradient, + double *hessian, void *) { + if (value != nullptr) *value = ext_rosen(n, x); + if (gradient != nullptr) ext_rosen_grad(n, x, gradient); + if (hessian != nullptr) ext_rosen_hess(n, x, hessian); + return 0; +} + +int steihaug_test_rosen_hv(int n, const double *x, const double *v, double *hv, + void *) { + std::vector h(static_cast(n) * n); + ext_rosen_hess(n, x, h.data()); + for (int i = 0; i < n; i++) { + double s = 0.0; + for (int j = 0; j < n; j++) s += h[i * n + j] * v[j]; + hv[i] = s; + } + return 0; +} + +struct RunOut { + std::vector par; + double value = 0.0; + int evals = 0, code = 0; +}; + +// solver: 0 = bobyqa, 1 = newuoa, 2 = steihaug exact, 3 = steihaug matrix-free +RunOut run_one(int solver, const std::vector &start) { + int n = static_cast(start.size()); + RunOut o; + if (solver <= 1) { + minqa_options_t opts = minqa_options_default(n, start.data()); + opts.npt = 2 * n + 1; + minqa_result_t res; + std::vector lower(n, -10.0), upper(n, 10.0); + if (solver == 0) { + bobyqa_solve_c(n, start.data(), lower.data(), upper.data(), + minqa_test_rosen, nullptr, &opts, &res); + } else { + newuoa_solve_c(n, start.data(), minqa_test_rosen, nullptr, &opts, &res); + } + if (res.par != nullptr) o.par.assign(res.par, res.par + n); + o.value = res.fval; + o.evals = res.feval; + o.code = res.ierr; + minqa_result_free(&res); + } else { + steihaug_options_t opts = steihaug_options_default(); + steihaug_result_t res; + steihaug_solve_c(n, start.data(), steihaug_test_rosen, + solver == 3 ? steihaug_test_rosen_hv : nullptr, nullptr, + &opts, &res); + if (res.argument != nullptr) o.par.assign(res.argument, res.argument + n); + o.value = res.value; + o.evals = static_cast(res.cost_evals + res.hessvec_evals); + o.code = res.status; + steihaug_result_free(&res); + } + return o; +} + +} // namespace + +// Runs nStarts distinct extended-Rosenbrock problems once sequentially and +// once across OpenMP threads, and reports whether the results match +// bitwise. solver: "bobyqa", "newuoa", "steihaug", "steihaug_hessvec". +// [[Rcpp::export]] +List solver_openmp_stress_test(std::string solver, int n, int nStarts, + int nThreadsRequested) { + int s = solver == "bobyqa" ? 0 : solver == "newuoa" ? 1 + : solver == "steihaug" ? 2 : solver == "steihaug_hessvec" ? 3 : -1; + if (s < 0) Rcpp::stop("unknown solver"); + std::vector > starts(nStarts, std::vector(n)); + for (int i = 0; i < nStarts; i++) + for (int j = 0; j < n; j++) + starts[i][j] = (j % 2 == 0 ? -1.2 : 1.0) + 0.013 * i - 0.004 * j; + + std::vector ref(nStarts), par(nStarts); + for (int i = 0; i < nStarts; i++) ref[i] = run_one(s, starts[i]); + + std::vector threadIds(nStarts, 0); +#ifdef _OPENMP + int usedThreads = std::max(1, std::min(nThreadsRequested, omp_get_max_threads())); +#pragma omp parallel for num_threads(usedThreads) schedule(static) +#endif + for (int i = 0; i < nStarts; i++) { +#ifdef _OPENMP + threadIds[i] = omp_get_thread_num(); +#endif + par[i] = run_one(s, starts[i]); + } + + bool identical = true; + int nOk = 0; + for (int i = 0; i < nStarts; i++) { + if (ref[i].par != par[i].par || ref[i].evals != par[i].evals || + ref[i].code != par[i].code || + std::memcmp(&ref[i].value, &par[i].value, sizeof(double)) != 0) + identical = false; + bool near = !ref[i].par.empty(); + for (double v : ref[i].par) near = near && std::fabs(v - 1.0) < 1e-3; + if (near) nOk++; + } + (void)nThreadsRequested; + return List::create( + _["identical"] = identical, _["nNearOptimum"] = nOk, + _["distinctThreadsUsed"] = + static_cast(std::set(threadIds.begin(), threadIds.end()).size()), + _["openmpAvailable"] = +#ifdef _OPENMP + true +#else + false +#endif + ); +} + +namespace { +int minqa_fail_after(int n, const double *x, double *f, void *ud) { + int *left = static_cast(ud); + if ((*left)-- <= 0) return -1; + return minqa_test_rosen(n, x, f, nullptr); +} +int steihaug_fail_after(int n, const double *x, double *value, double *gradient, + double *hessian, void *ud) { + int *left = static_cast(ud); + if ((*left)-- <= 0) return -1; + return steihaug_test_rosen(n, x, value, gradient, hessian, nullptr); +} +int steihaug_hv_fail(int, const double *, const double *, double *, void *) { + return -1; +} +} // namespace + +// Return codes of the thread-safe C entry points on invalid input and +// failing callbacks (paths the R wrappers never reach). +// [[Rcpp::export]] +IntegerVector solver_c_api_edge_test() { + double start[2] = {-1.2, 1.0}, zero[2] = {0.0, 0.0}; + double lower[2] = {0.0, 0.0}, upper[2] = {1e-8, 1.0}; + minqa_result_t mr; + steihaug_result_t sr; + IntegerVector out; + auto push = [&](const char *nm, int code) { + out.push_back(code, nm); + }; + + push("newuoa_null_opts", newuoa_solve_c(2, start, minqa_test_rosen, nullptr, + nullptr, &mr)); + minqa_result_free(&mr); + push("bobyqa_null_opts", bobyqa_solve_c(2, start, nullptr, nullptr, + minqa_test_rosen, nullptr, nullptr, + &mr)); + minqa_result_free(&mr); + push("newuoa_zero_start", newuoa_solve_c(2, zero, minqa_test_rosen, nullptr, + nullptr, &mr)); + push("bobyqa_negative_n", bobyqa_solve_c(-1, start, nullptr, nullptr, + minqa_test_rosen, nullptr, nullptr, + &mr)); + push("newuoa_null_result", newuoa_solve_c(2, start, minqa_test_rosen, + nullptr, nullptr, nullptr)); + minqa_options_t mo = minqa_options_default(2, start); + mo.npt = 2; + push("newuoa_bad_npt", newuoa_solve_c(2, start, minqa_test_rosen, nullptr, + &mo, &mr)); + minqa_result_free(&mr); + push("bobyqa_bad_npt", bobyqa_solve_c(2, start, nullptr, nullptr, + minqa_test_rosen, nullptr, &mo, &mr)); + minqa_result_free(&mr); + mo = minqa_options_default(2, start); + double tight[2] = {0.0, 0.5}; + push("bobyqa_range", bobyqa_solve_c(2, tight, lower, upper, minqa_test_rosen, + nullptr, &mo, &mr)); + minqa_result_free(&mr); + int left = 7; + push("newuoa_objfun_error", newuoa_solve_c(2, start, minqa_fail_after, &left, + &mo, &mr)); + minqa_result_free(&mr); + left = 7; + push("bobyqa_objfun_error", bobyqa_solve_c(2, start, nullptr, nullptr, + minqa_fail_after, &left, &mo, &mr)); + minqa_result_free(&mr); + // A non-finite start reaches calfun on the first evaluation, which aborts + // (minqa stops with "non-finite x values not allowed in calfun"). + double nanstart[2] = {NAN, 1.0}; + int nanCode = newuoa_solve_c(2, nanstart, minqa_test_rosen, nullptr, &mo, &mr); + minqa_result_free(&mr); + push("newuoa_nonfinite_x", nanCode); + + steihaug_options_t so = steihaug_options_default(); + push("steihaug_ok", steihaug_solve_c(2, start, steihaug_test_rosen, nullptr, + nullptr, &so, &sr)); + steihaug_result_free(&sr); + push("steihaug_null_opts", steihaug_solve_c(2, start, steihaug_test_rosen, + nullptr, nullptr, nullptr, &sr)); + steihaug_result_free(&sr); + so.eta = 0.5; + push("steihaug_bad_eta", steihaug_solve_c(2, start, steihaug_test_rosen, + nullptr, nullptr, &so, &sr)); + steihaug_result_free(&sr); + so = steihaug_options_default(); + so.abs_step_tol = NAN; + push("steihaug_nan_tol", steihaug_solve_c(2, start, steihaug_test_rosen, + nullptr, nullptr, &so, &sr)); + steihaug_result_free(&sr); + so = steihaug_options_default(); + left = 5; + push("steihaug_objfun_error", steihaug_solve_c(2, start, steihaug_fail_after, + nullptr, &left, &so, &sr)); + steihaug_result_free(&sr); + push("steihaug_hessvec_error", steihaug_solve_c(2, start, steihaug_test_rosen, + steihaug_hv_fail, nullptr, &so, + &sr)); + steihaug_result_free(&sr); + push("steihaug_zero_n", steihaug_solve_c(0, start, steihaug_test_rosen, + nullptr, nullptr, &so, &sr)); + steihaug_result_free(&sr); + return out; +} diff --git a/src/steihaug_core.cpp b/src/steihaug_core.cpp new file mode 100644 index 0000000..5c8e35a --- /dev/null +++ b/src/steihaug_core.cpp @@ -0,0 +1,798 @@ +// Thread-safe C++17 port of basin's Steihaug truncated-CG trust-region +// Newton minimizer (https://github.com/jolars/basin, MIT OR Apache-2.0, +// commit 86cc0d6, crate `basin` v1.12.0). +// +// Ported sources (paths relative to crates/basin/src): +// solver/trust_region.rs tr_init, tr_next_iter, both modes, +// tau_to_boundary, model_decrease_from_bd +// solver/trust_region/steihaug.rs Steihaug::solve_with +// core/executor.rs Executor::into_stepper, step_once +// core/run_control.rs RunControl::check +// core/convergence.rs ConfiguredSolver::check_convergence, +// GradientChecks, StepChecks, CostChecks +// core/termination.rs GradientTolerance, +// RelativeGradientTolerance, +// CostTolerance, RelativeCostTolerance, +// TargetCost +// core/math/vec.rs, dense.rs Vec / DenseMatrix kernels +// +// The floating-point kernels reproduce the Vec/DenseMatrix backend's +// order of operations (left-to-right sums seeded with -0.0, as Rust's +// `Iterator::sum` for f64 is) so iterates can match basin bit-for-bit. +// FMA contraction is disabled below via pragmas (rustc never contracts). +// +// Thread safety: no statics, no globals, no R API. Every buffer is owned +// by the call; callbacks receive the caller's userdata. + +#include "steihaug_types.h" + +#include +#include +#include +#include +#include + +// Forbid FMA contraction (a*b + c -> fma) in this translation unit so the +// kernels below keep basin's (rustc's) exact IEEE operation sequence even +// when the package is built with -march=native / -mfma. Placed after the +// system headers so only this file's own functions are affected. +#if defined(__clang__) +#pragma clang fp contract(off) +#elif defined(__GNUC__) +#pragma GCC optimize("fp-contract=off") +#endif + +namespace { + +using Vec = std::vector; + +// --------------------------------------------------------------------------- +// core/math/vec.rs and core/math/dense.rs kernels +// --------------------------------------------------------------------------- + +// vec.rs `impl Dot for Vec`: iter().zip().map(a*b).sum() (seed -0.0). +inline double dot(const Vec &a, const Vec &b) { + double s = -0.0; + const size_t n = a.size(); + for (size_t i = 0; i < n; i++) s = s + a[i] * b[i]; + return s; +} + +// vec.rs `impl NormSquared for Vec`: iter().map(x*x).sum(). +inline double norm_squared(const Vec &a) { + double s = -0.0; + const size_t n = a.size(); + for (size_t i = 0; i < n; i++) s = s + a[i] * a[i]; + return s; +} + +// vec.rs `impl ScaledAdd for Vec`: x = x + scalar * y. +inline void scaled_add(Vec &x, double scalar, const Vec &y) { + const size_t n = x.size(); + for (size_t i = 0; i < n; i++) x[i] = x[i] + scalar * y[i]; +} + +// vec.rs `impl ScaleInPlace for Vec`: x = x * scalar. +inline void scale_in_place(Vec &x, double scalar) { + for (double &v : x) v = v * scalar; +} + +// vec.rs `impl NegInPlace for Vec`: x = -x. +inline void neg_in_place(Vec &x) { + for (double &v : x) v = -v; +} + +// dense.rs `impl MatVec> for DenseMatrix`: row-major +// y[i] = sum_j A[i*cols + j] * x[j] (seed -0.0). +inline void matvec(const Vec &a, int n, const Vec &x, Vec &y) { + const size_t nn = static_cast(n); + for (size_t i = 0; i < nn; i++) { + const double *row = a.data() + i * nn; + double s = -0.0; + for (size_t j = 0; j < nn; j++) s = s + row[j] * x[j]; + y[i] = s; + } +} + +inline bool is_finite(double x) { return std::isfinite(x); } + +// --------------------------------------------------------------------------- +// Problem wrapper: core/problem.rs `Problem

` counted calls +// --------------------------------------------------------------------------- + +enum class Err { NONE = 0, OBJFUN, HESSVEC }; + +struct Problem { + int n; + steihaug_c_objfun_t objfun; + steihaug_c_hessvec_t hessvec; + void *userdata; + long long cost_evals = 0; + long long gradient_evals = 0; + long long hessian_evals = 0; + long long hessvec_evals = 0; + + // problem.rs Problem::cost_and_gradient (counts bumped before the call) + bool cost_and_gradient(const Vec &x, double &cost, Vec &grad) { + cost_evals += 1; + gradient_evals += 1; + grad.assign(static_cast(n), 0.0); + return objfun(n, x.data(), &cost, grad.data(), nullptr, userdata) >= 0; + } + // problem.rs Problem::cost + bool cost(const Vec &x, double &cost) { + cost_evals += 1; + return objfun(n, x.data(), &cost, nullptr, nullptr, userdata) >= 0; + } + // problem.rs Problem::gradient + bool gradient(const Vec &x, Vec &grad) { + gradient_evals += 1; + grad.assign(static_cast(n), 0.0); + return objfun(n, x.data(), nullptr, grad.data(), nullptr, userdata) >= 0; + } + // problem.rs Problem::hessian + bool hessian(const Vec &x, Vec &h) { + hessian_evals += 1; + h.assign(static_cast(n) * static_cast(n), 0.0); + return objfun(n, x.data(), nullptr, nullptr, h.data(), userdata) >= 0; + } + // problem.rs Problem::hessian_product + bool hessian_product(const Vec &x, const Vec &v, Vec &hv) { + hessvec_evals += 1; + hv.assign(static_cast(n), 0.0); + return hessvec(n, x.data(), v.data(), hv.data(), userdata) >= 0; + } +}; + +// --------------------------------------------------------------------------- +// solver/trust_region.rs +// --------------------------------------------------------------------------- + +// trust_region.rs `struct Step`. +struct Step { + Vec d; + double predicted_reduction; + bool hit_boundary; + int cg_iter; // port-only diagnostic for the trace +}; + +// trust_region.rs `model_decrease_from_bd`: -g.dot(d) - half * d.dot(bd). +inline double model_decrease_from_bd(const Vec &g, const Vec &d, + const Vec &bd) { + const double half = 0.5; + return -dot(g, d) - half * dot(d, bd); +} + +// trust_region.rs `tau_to_boundary`. +inline double tau_to_boundary(const Vec &z, const Vec &d, double radius) { + double dd = dot(d, d); + double zd = dot(z, d); + double zz = dot(z, z); + double rr = radius * radius; + double disc = zd * zd - dd * (zz - rr); + disc = disc < 0.0 ? 0.0 : disc; + return (-zd + std::sqrt(disc)) / dd; +} + +// The Hessian-vector product closure `bv` of both modes: exact mode wraps +// DenseMatrix::matvec (trust_region.rs Subproblem for Steihaug, infallible), +// matrix-free mode wraps the counted Problem::hessian_product. +struct HessOp { + Problem *problem; + const Vec *x; + const Vec *hessian; // non-null in exact mode + // Returns false on a hessvec failure (Err propagation). + bool operator()(const Vec &v, Vec &out) { + if (hessian != nullptr) { + out.resize(v.size()); + matvec(*hessian, problem->n, v, out); + return true; + } + return problem->hessian_product(*x, v, out); + } +}; + +// steihaug.rs `Steihaug::solve_with`. Returns false on a product error. +bool steihaug_solve_with(const Vec &g, double radius, int cfg_max_iter, + double kappa, double theta, HessOp &bv, Step &out) { + const int n = static_cast(g.size()); + const int max_iter = cfg_max_iter > 0 ? cfg_max_iter : (n > 1 ? n : 1); + out.cg_iter = 0; + + // z0 = 0, r0 = g, d0 = -r0. + Vec z = g; + scale_in_place(z, 0.0); + Vec r = g; + double r_dot = dot(r, r); + + const double g_norm = std::sqrt(r_dot); + if (g_norm == 0.0) { + out.d = std::move(z); + out.predicted_reduction = 0.0; + out.hit_boundary = false; + return true; + } + + const double half = 0.5; + double power; + if (theta == 0.0) { + power = 1.0; + } else if (theta == half) { + power = std::sqrt(g_norm); + } else if (theta == 1.0) { + power = g_norm; + } else { + power = std::pow(g_norm, theta); + } + const double tol = (power < kappa ? power : kappa) * g_norm; + + Vec d = r; + neg_in_place(d); + Vec bd, bz, z_next, d_next; + + for (int it = 0; it < max_iter; it++) { + out.cg_iter = it + 1; + if (!bv(d, bd)) return false; + double dbd = dot(d, bd); + + // Non-positive curvature: walk to the boundary and stop. + if (dbd <= 0.0) { + double tau = tau_to_boundary(z, d, radius); + scaled_add(z, tau, d); + if (!bv(z, bz)) return false; + out.predicted_reduction = model_decrease_from_bd(g, z, bz); + out.d = std::move(z); + out.hit_boundary = true; + return true; + } + + double alpha = r_dot / dbd; + + // Tentative iterate z + alpha d; clip to the boundary if outside. + z_next = z; + scaled_add(z_next, alpha, d); + if (std::sqrt(norm_squared(z_next)) >= radius) { + double tau = tau_to_boundary(z, d, radius); + scaled_add(z, tau, d); + if (!bv(z, bz)) return false; + out.predicted_reduction = model_decrease_from_bd(g, z, bz); + out.d = std::move(z); + out.hit_boundary = true; + return true; + } + z.swap(z_next); + + // r <- r + alpha B d. + scaled_add(r, alpha, bd); + double r_dot_next = dot(r, r); + double residual_norm = std::sqrt(r_dot_next); + bool converged = residual_norm == 0.0 || residual_norm < tol; + if (converged) { + if (!bv(z, bz)) return false; + out.predicted_reduction = model_decrease_from_bd(g, z, bz); + out.d = std::move(z); + out.hit_boundary = false; + return true; + } + + // d <- -r + beta d. + double beta = r_dot_next / r_dot; + d_next = r; + neg_in_place(d_next); + scaled_add(d_next, beta, d); + d.swap(d_next); + r_dot = r_dot_next; + } + + // Iteration cap reached: best interior iterate. + if (!bv(z, bz)) return false; + out.predicted_reduction = model_decrease_from_bd(g, z, bz); + out.d = std::move(z); + out.hit_boundary = false; + return true; +} + +// --------------------------------------------------------------------------- +// State: core/state.rs BasicState, f64> (fields used here) +// --------------------------------------------------------------------------- + +struct State { + Vec param; + double cost = 0.0; + Vec gradient; + long long iter = 0; + bool has_best = false; // best_param.is_some() + double best_cost = HUGE_VAL; + + // state.rs BasicState::update_best (cost is always Some after init). + void update_best() { + if (!has_best || cost < best_cost) { + has_best = true; + best_cost = cost; + } + } +}; + +// --------------------------------------------------------------------------- +// Trace buffer (port-only diagnostic) +// --------------------------------------------------------------------------- + +struct TraceRow { + int iter; + double radius, cost, gradnorm, trial_cost, pred, rho, step_norm; + int accept, hit_boundary, cg_iter; +}; + +// --------------------------------------------------------------------------- +// convergence.rs: ConfiguredSolver checks (G = GradientChecks, +// X = StepChecks, C = CostChecks; simplex slot unused) +// --------------------------------------------------------------------------- + +struct Convergence { + // GradientChecks + bool abs_grad_on, rel_grad_on; + double abs_grad, rel_grad; + bool rel_grad_anchor_set = false; + double rel_grad_initial = 0.0; + // StepChecks + bool abs_step_on, rel_step_on; + double abs_step, rel_step; + bool has_last_param = false; + Vec last_param; + // CostChecks + bool abs_cost_on, rel_cost_on; + double abs_cost, rel_cost; + bool abs_cost_has_last = false, rel_cost_has_last = false; + double abs_cost_last = 0.0, rel_cost_last = 0.0; + + // convergence.rs `impl Check for GradientChecks`, with + // termination.rs GradientTolerance / RelativeGradientTolerance. + int check_gradient(const State &s) { + if (!abs_grad_on && !rel_grad_on) return -1; // `()` slot + double ns = norm_squared(s.gradient); + if (!is_finite(ns)) return -1; + if (abs_grad_on) { + if (norm_squared(s.gradient) <= abs_grad * abs_grad) + return STEIHAUG_GRADIENT_TOLERANCE; + } + if (rel_grad_on) { + double norm_sq = norm_squared(s.gradient); + if (!rel_grad_anchor_set) { + rel_grad_anchor_set = true; + rel_grad_initial = norm_sq; + } + if (norm_sq <= rel_grad * rel_grad * rel_grad_initial) + return STEIHAUG_RELATIVE_GRADIENT_TOLERANCE; + } + return -1; + } + + // convergence.rs `impl Check for StepChecks`. + int check_step(const State &s) { + if (!abs_step_on && !rel_step_on) return -1; + const Vec ¤t = s.param; + // let last = self.last.replace(current.clone())?; + if (!has_last_param) { + has_last_param = true; + last_param = current; + return -1; + } + Vec last = last_param; + last_param = current; + Vec difference = current; + scaled_add(difference, -1.0, last); + double step = std::sqrt(norm_squared(difference)); + if (!is_finite(step)) return -1; + if (abs_step_on && step <= abs_step) return STEIHAUG_PARAM_TOLERANCE; + if (rel_step_on) { + bool hit; + if (rel_step == 0.0) { + hit = step == 0.0; + } else { + double norm = std::sqrt(norm_squared(current)); + double bound; + if (is_finite(norm)) { + bound = rel_step * norm; + } else { + Vec scaled = current; + scaled_add(scaled, -1.0, current); + scaled_add(scaled, rel_step, current); + bound = std::sqrt(norm_squared(scaled)); + } + hit = step <= bound; + } + if (hit) return STEIHAUG_RELATIVE_PARAM_TOLERANCE; + } + return -1; + } + + // convergence.rs `impl Check for CostChecks`, with termination.rs + // CostTolerance / RelativeCostTolerance (both evaluated, absolute wins). + int check_cost(const State &s) { + if (!abs_cost_on && !rel_cost_on) return -1; + const double curr = s.cost; + if (!is_finite(curr)) { + abs_cost_has_last = false; + rel_cost_has_last = false; + return -1; + } + int absolute = -1, relative = -1; + if (abs_cost_on) { + bool trig = abs_cost_has_last && + (std::fabs(abs_cost_last - curr) <= abs_cost && + is_finite(curr)); + abs_cost_has_last = true; + abs_cost_last = curr; + if (trig) absolute = STEIHAUG_COST_TOLERANCE; + } + if (rel_cost_on) { + bool trig = rel_cost_has_last && + (is_finite(curr) && + std::fabs(rel_cost_last - curr) <= + rel_cost * std::fabs(rel_cost_last)); + rel_cost_has_last = true; + rel_cost_last = curr; + if (trig) relative = STEIHAUG_RELATIVE_COST_TOLERANCE; + } + return absolute >= 0 ? absolute : relative; + } + + // convergence.rs ConfiguredSolver::check_convergence: gradient, then + // step, then cost (the per-boundary memo never hits within one run: + // every executor step either increments `iter` or stops). + int check(const State &s) { + int r = check_gradient(s); + if (r >= 0) return r; + r = check_step(s); + if (r >= 0) return r; + return check_cost(s); + } +}; + +// Outcome of one `Solver::next_iter`. +enum class IterOutcome { CONTINUE, CONVERGED, FAILED, ERROR }; + +struct Solver { + const steihaug_options_t *opts; + int n; + double radius; + bool exact; + Err err = Err::NONE; + bool trace; + std::vector rows; + + // trust_region.rs tr_init. + bool init(Problem &problem, State &state) { + radius = opts->initial_radius; + double cost = 0.0; + Vec grad; + if (!problem.cost_and_gradient(state.param, cost, grad)) { + err = Err::OBJFUN; + return false; + } + state.cost = cost; + state.gradient = std::move(grad); + return true; + } + + // trust_region.rs tr_next_iter plus the mode-specific `next_iter` + // bodies (`impl Solver for TrustRegion` evaluates + // one Hessian up front; `MatrixFree` goes through hessian_product). + // On success `next` holds the new state; on ERROR it is unspecified. + IterOutcome next_iter(Problem &problem, const State &state, State &next) { + Vec b; + if (exact) { + if (!problem.hessian(state.param, b)) { + err = Err::OBJFUN; + return IterOutcome::ERROR; + } + } + next = state; + const Vec &g = state.gradient; + const double cost_old = state.cost; + const double quarter = 0.25; + const double three_quarters = 0.75; + const double two = 2.0; + + HessOp bv{&problem, &state.param, exact ? &b : nullptr}; + Step step; + Vec trial; + const double gradnorm = trace ? std::sqrt(norm_squared(g)) : 0.0; + + for (int k = 0; k < opts->max_inner; k++) { + const double radius_used = radius; + if (!steihaug_solve_with(g, radius, opts->cg_max_iter, opts->kappa, + opts->theta, bv, step)) { + err = Err::HESSVEC; + return IterOutcome::ERROR; + } + TraceRow row{static_cast(state.iter), radius_used, cost_old, + gradnorm, NAN, step.predicted_reduction, NAN, NAN, 0, + step.hit_boundary ? 1 : 0, step.cg_iter}; + + if (!is_finite(step.predicted_reduction)) { + if (trace) rows.push_back(row); + return IterOutcome::FAILED; + } + if (step.predicted_reduction <= 0.0) { + if (trace) rows.push_back(row); + return IterOutcome::CONVERGED; + } + + trial = state.param; + scaled_add(trial, 1.0, step.d); + double cost_trial = 0.0; + if (!problem.cost(trial, cost_trial)) { + err = Err::OBJFUN; + return IterOutcome::ERROR; + } + + double rho = (cost_old - cost_trial) / step.predicted_reduction; + double step_norm = std::sqrt(norm_squared(step.d)); + + if (rho < quarter || !is_finite(rho)) { + radius = quarter * step_norm; + } else if (rho > three_quarters && step.hit_boundary) { + double grown = two * radius; + radius = grown < opts->max_radius ? grown : opts->max_radius; + } + + row.trial_cost = cost_trial; + row.rho = rho; + row.step_norm = step_norm; + + if (rho > opts->eta) { + row.accept = 1; + if (trace) rows.push_back(row); + next.param = trial; + next.cost = cost_trial; + if (!problem.gradient(next.param, next.gradient)) { + err = Err::OBJFUN; + return IterOutcome::ERROR; + } + return IterOutcome::CONTINUE; + } + if (trace) rows.push_back(row); + } + // Inner attempts exhausted: keep iterate, shrunken radius. + return IterOutcome::CONTINUE; + } +}; + +bool valid_tol(double t) { + // Negative = disabled; otherwise basin's optional_tolerance assertion. + if (t < 0.0) return true; + return is_finite(t) && t >= 0.0; +} + +bool validate(int n, const double *parinit, steihaug_c_objfun_t objfun, + const steihaug_options_t *o) { + if (n < 1 || parinit == nullptr || objfun == nullptr || o == nullptr) + return false; + // TrustRegion::with_radius / with_max_radius: `> 0` (NaN rejected). + if (!(o->initial_radius > 0.0)) return false; + if (!(o->max_radius > 0.0)) return false; + // with_eta: eta in [0, 1/4). + if (!(o->eta >= 0.0 && o->eta < 0.25)) return false; + // with_max_inner_attempts: >= 1. + if (o->max_inner < 1) return false; + // Steihaug::with_max_iter: >= 1 (0 here selects the default n). + if (o->cg_max_iter < 0) return false; + // with_forcing_parameters. + if (!(is_finite(o->kappa) && o->kappa >= 0.0 && o->kappa < 1.0)) + return false; + if (!(is_finite(o->theta) && o->theta >= 0.0)) return false; + if (o->max_iter < 0) return false; + // RunControl::target_cost: finite. + if (o->has_target_cost && !is_finite(o->target_cost)) return false; + if (!valid_tol(o->abs_gradient_tol) || !valid_tol(o->rel_gradient_tol) || + !valid_tol(o->abs_step_tol) || !valid_tol(o->rel_step_tol) || + !valid_tol(o->abs_cost_change_tol) || !valid_tol(o->rel_cost_change_tol)) + return false; + // NaN tolerances: `t < 0` is false and is_finite fails -> rejected above. + return true; +} + +double *dup_doubles(const double *src, size_t count) { + size_t bytes = (count > 0 ? count : 1) * sizeof(double); + double *p = static_cast(malloc(bytes)); + if (p == nullptr) throw std::bad_alloc(); + if (src != nullptr && count > 0) memcpy(p, src, count * sizeof(double)); + return p; +} + +int *alloc_ints(size_t count) { + int *p = static_cast(malloc((count > 0 ? count : 1) * sizeof(int))); + if (p == nullptr) throw std::bad_alloc(); + return p; +} + +void fill_state(steihaug_result_t *res, const State &s, int n) { + res->value = s.cost; + res->iterations = static_cast(s.iter); + res->argument = dup_doubles(s.param.data(), static_cast(n)); + res->gradient = dup_doubles( + s.gradient.size() == static_cast(n) ? s.gradient.data() : nullptr, + static_cast(n)); + if (s.gradient.size() != static_cast(n)) + for (int i = 0; i < n; i++) res->gradient[i] = NAN; +} + +void fill_trace(steihaug_result_t *res, const std::vector &rows) { + size_t m = rows.size(); + res->trace_iter = alloc_ints(m); + res->trace_radius = dup_doubles(nullptr, m); + res->trace_cost = dup_doubles(nullptr, m); + res->trace_gradnorm = dup_doubles(nullptr, m); + res->trace_trial_cost = dup_doubles(nullptr, m); + res->trace_pred = dup_doubles(nullptr, m); + res->trace_rho = dup_doubles(nullptr, m); + res->trace_step_norm = dup_doubles(nullptr, m); + res->trace_accept = alloc_ints(m); + res->trace_hit_boundary = alloc_ints(m); + res->trace_cg_iter = alloc_ints(m); + for (size_t i = 0; i < m; i++) { + const TraceRow &r = rows[i]; + res->trace_iter[i] = r.iter; + res->trace_radius[i] = r.radius; + res->trace_cost[i] = r.cost; + res->trace_gradnorm[i] = r.gradnorm; + res->trace_trial_cost[i] = r.trial_cost; + res->trace_pred[i] = r.pred; + res->trace_rho[i] = r.rho; + res->trace_step_norm[i] = r.step_norm; + res->trace_accept[i] = r.accept; + res->trace_hit_boundary[i] = r.hit_boundary; + res->trace_cg_iter[i] = r.cg_iter; + } + res->trace_len = static_cast(m); +} + +// executor.rs Executor::into_stepper + Stepper::run_to_end + step_once, +// with run_control.rs RunControl::check. +int solve(int n, const double *parinit, steihaug_c_objfun_t objfun, + steihaug_c_hessvec_t hessvec, void *userdata, + const steihaug_options_t *o, steihaug_result_t *res) { + Problem problem{n, objfun, hessvec, userdata, 0, 0, 0, 0}; + Solver solver{o, n, o->initial_radius, hessvec == nullptr, Err::NONE, + o->trace != 0, {}}; + + Convergence conv; + conv.abs_grad_on = o->abs_gradient_tol >= 0.0; + conv.abs_grad = o->abs_gradient_tol; + conv.rel_grad_on = o->rel_gradient_tol >= 0.0; + conv.rel_grad = o->rel_gradient_tol; + conv.abs_step_on = o->abs_step_tol >= 0.0; + conv.abs_step = o->abs_step_tol; + conv.rel_step_on = o->rel_step_tol >= 0.0; + conv.rel_step = o->rel_step_tol; + conv.abs_cost_on = o->abs_cost_change_tol >= 0.0; + conv.abs_cost = o->abs_cost_change_tol; + conv.rel_cost_on = o->rel_cost_change_tol >= 0.0; + conv.rel_cost = o->rel_cost_change_tol; + + State state; + state.param.assign(parinit, parinit + n); + + int status = STEIHAUG_ERR_INTERNAL; + State next; + bool ok = solver.init(problem, state); + if (!ok) { + // basin returns Err from into_stepper; report the starting point. + status = STEIHAUG_ERR_OBJFUN; + state.cost = NAN; + } else { + state.update_best(); + for (;;) { + // RunControl::check. + if (state.iter >= o->max_iter) { + status = STEIHAUG_MAX_ITER; + break; + } + if (o->max_cost_evals >= 0 && problem.cost_evals >= o->max_cost_evals) { + status = STEIHAUG_MAX_COST_EVALS; + break; + } + if (o->max_gradient_evals >= 0 && + problem.gradient_evals >= o->max_gradient_evals) { + status = STEIHAUG_MAX_GRADIENT_EVALS; + break; + } + if (o->has_target_cost && state.best_cost <= o->target_cost) { + status = STEIHAUG_TARGET_COST; + break; + } + // Solver::check_convergence. + int reason = conv.check(state); + if (reason >= 0) { + status = reason; + break; + } + // Solver::next_iter. + IterOutcome out = solver.next_iter(problem, state, next); + if (out == IterOutcome::ERROR) { + status = solver.err == Err::HESSVEC ? STEIHAUG_ERR_HESSVEC + : STEIHAUG_ERR_OBJFUN; + break; + } + if (out == IterOutcome::CONVERGED || out == IterOutcome::FAILED) { + // mid-iteration stop: state unchanged apart from update_best. + state.update_best(); + status = out == IterOutcome::CONVERGED ? STEIHAUG_SOLVER_CONVERGED + : STEIHAUG_SOLVER_FAILED; + break; + } + state.param.swap(next.param); + state.cost = next.cost; + state.gradient.swap(next.gradient); + state.iter += 1; + state.update_best(); + } + } + + res->n = n; + res->status = status; + res->converged = (status >= STEIHAUG_TARGET_COST && + status <= STEIHAUG_SOLVER_CONVERGED) + ? 1 + : 0; + res->radius = solver.radius; + res->cost_evals = problem.cost_evals; + res->gradient_evals = problem.gradient_evals; + res->hessian_evals = problem.hessian_evals; + res->hessvec_evals = problem.hessvec_evals; + fill_state(res, state, n); + if (solver.trace) fill_trace(res, solver.rows); + return status; +} + +} // namespace + +extern "C" void steihaug_result_zero(steihaug_result_t *res) { + if (res == nullptr) return; + memset(res, 0, sizeof(*res)); +} + +extern "C" void steihaug_result_free(steihaug_result_t *res) { + if (res == nullptr) return; + free(res->argument); + free(res->gradient); + free(res->trace_iter); + free(res->trace_radius); + free(res->trace_cost); + free(res->trace_gradnorm); + free(res->trace_trial_cost); + free(res->trace_pred); + free(res->trace_rho); + free(res->trace_step_norm); + free(res->trace_accept); + free(res->trace_hit_boundary); + free(res->trace_cg_iter); + memset(res, 0, sizeof(*res)); +} + +extern "C" int steihaug_solve_c(int n, const double *parinit, + steihaug_c_objfun_t objfun, + steihaug_c_hessvec_t hessvec_or_null, + void *userdata, const steihaug_options_t *opts, + steihaug_result_t *result) { + if (result == nullptr) return STEIHAUG_ERR_INVALID_OPTIONS; + steihaug_result_zero(result); + if (!validate(n, parinit, objfun, opts)) { + result->n = n; + result->status = STEIHAUG_ERR_INVALID_OPTIONS; + return result->status; + } + try { + return solve(n, parinit, objfun, hessvec_or_null, userdata, opts, result); + } catch (const std::bad_alloc &) { + steihaug_result_free(result); + result->n = n; + result->status = STEIHAUG_ERR_NOMEM; + } catch (...) { + steihaug_result_free(result); + result->n = n; + result->status = STEIHAUG_ERR_INTERNAL; + } + return result->status; +} diff --git a/src/steihaug_r_interface.cpp b/src/steihaug_r_interface.cpp new file mode 100644 index 0000000..701c132 --- /dev/null +++ b/src/steihaug_r_interface.cpp @@ -0,0 +1,181 @@ +// R-objfun entry point for the Steihaug trust-region port, called by the +// shim in R/steihaug.R. Drives the same thread-safe steihaug_solve_c() a +// C/C++ consumer calls; only the callbacks (which evaluate R closures, so +// are main-thread only) differ. +#include +#include +#include +#include "steihaug_types.h" +using namespace Rcpp; + +namespace { + +struct SteihaugRObjfun { + SEXP fn, gr, hess, hessvec; // hess/hessvec may be R_NilValue + std::exception_ptr error; +}; + +void steihaug_r_copy(SEXP v, int len, double *out, const char *what) { + if (!Rf_isNumeric(v) || Rf_length(v) != len) + Rcpp::stop("'%s' must return a numeric of length %d", what, len); + NumericVector nv(v); + std::copy(nv.begin(), nv.end(), out); +} + +int steihaug_r_objfun(int n, const double *x, double *value, double *gradient, + double *hessian, void *userdata) { + SteihaugRObjfun *d = static_cast(userdata); + try { + NumericVector xx(x, x + n); + if (value != nullptr) { + Function fn(d->fn); + SEXP v = fn(xx); + if (!Rf_isNumeric(v) || Rf_length(v) != 1) + Rcpp::stop("'fn' must return a single numeric value"); + *value = Rf_asReal(v); + } + if (gradient != nullptr) { + Function gr(d->gr); + steihaug_r_copy(gr(xx), n, gradient, "gr"); + } + if (hessian != nullptr) { + Function hs(d->hess); + SEXP h = hs(xx); + if (!Rf_isMatrix(h) || Rf_nrows(h) != n || Rf_ncols(h) != n) + Rcpp::stop("'hess' must return a %d by %d numeric matrix", n, n); + NumericMatrix hm(h); + // The C contract is row-major. + for (int i = 0; i < n; i++) + for (int j = 0; j < n; j++) hessian[i * n + j] = hm(i, j); + } + return 0; + } catch (...) { + d->error = std::current_exception(); + return -1; + } +} + +int steihaug_r_hessvec(int n, const double *x, const double *v, double *hv, + void *userdata) { + SteihaugRObjfun *d = static_cast(userdata); + try { + NumericVector xx(x, x + n), vv(v, v + n); + Function hvf(d->hessvec); + steihaug_r_copy(hvf(xx, vv), n, hv, "hessvec"); + return 0; + } catch (...) { + d->error = std::current_exception(); + return -1; + } +} + +const char *steihaug_status_name(int status) { + switch (status) { + case STEIHAUG_MAX_ITER: return "MaxIter"; + case STEIHAUG_MAX_COST_EVALS: return "MaxCostEvals"; + case STEIHAUG_MAX_GRADIENT_EVALS: return "MaxGradientEvals"; + case STEIHAUG_TARGET_COST: return "TargetCost"; + case STEIHAUG_GRADIENT_TOLERANCE: return "GradientTolerance"; + case STEIHAUG_RELATIVE_GRADIENT_TOLERANCE: return "RelativeGradientTolerance"; + case STEIHAUG_PARAM_TOLERANCE: return "ParamTolerance"; + case STEIHAUG_RELATIVE_PARAM_TOLERANCE: return "RelativeParamTolerance"; + case STEIHAUG_COST_TOLERANCE: return "CostTolerance"; + case STEIHAUG_RELATIVE_COST_TOLERANCE: return "RelativeCostTolerance"; + case STEIHAUG_SOLVER_CONVERGED: return "SolverConverged"; + case STEIHAUG_SOLVER_FAILED: return "SolverFailed"; + default: return "Error"; + } +} + +double ctrl_dbl(List ctrl, const char *nm) { return as(ctrl[nm]); } + +// NULL in the R control list disables a tolerance / budget. +double ctrl_tol(List ctrl, const char *nm) { + SEXP v = ctrl[nm]; + return Rf_isNull(v) ? STEIHAUG_DISABLED : as(v); +} + +} // namespace + +// [[Rcpp::export]] +List steihaug_solve_r(NumericVector par, Function fn, Function gr, + RObject hess, RObject hessvec, List control) { + int n = par.size(); + SteihaugRObjfun d{fn, gr, hess, hessvec, nullptr}; + + steihaug_options_t o = steihaug_options_default(); + o.initial_radius = ctrl_dbl(control, "rinit"); + o.max_radius = ctrl_dbl(control, "rmax"); + o.eta = ctrl_dbl(control, "eta"); + o.max_inner = as(control["maxInner"]); + o.cg_max_iter = as(control["cgMaxit"]); + o.kappa = ctrl_dbl(control, "kappa"); + o.theta = ctrl_dbl(control, "theta"); + o.max_iter = as(control["maxit"]); + SEXP mce = control["maxCostEvals"], mge = control["maxGradEvals"], + tc = control["targetCost"]; + o.max_cost_evals = Rf_isNull(mce) ? -1 : static_cast(as(mce)); + o.max_gradient_evals = + Rf_isNull(mge) ? -1 : static_cast(as(mge)); + o.has_target_cost = Rf_isNull(tc) ? 0 : 1; + o.target_cost = Rf_isNull(tc) ? 0.0 : as(tc); + o.abs_gradient_tol = ctrl_tol(control, "gradTol"); + o.rel_gradient_tol = ctrl_tol(control, "relGradTol"); + o.abs_step_tol = ctrl_tol(control, "stepTol"); + o.rel_step_tol = ctrl_tol(control, "relStepTol"); + o.abs_cost_change_tol = ctrl_tol(control, "costTol"); + o.rel_cost_change_tol = ctrl_tol(control, "relCostTol"); + o.trace = as(control["trace"]) ? 1 : 0; + + steihaug_result_t res; + steihaug_solve_c(n, par.begin(), steihaug_r_objfun, + hessvec.isNULL() ? nullptr : steihaug_r_hessvec, &d, &o, + &res); + + if (d.error) { + steihaug_result_free(&res); + std::rethrow_exception(d.error); + } + if (res.status == STEIHAUG_ERR_INVALID_OPTIONS) { + steihaug_result_free(&res); + Rcpp::stop("invalid steihaug() control settings"); + } + if (res.status < 0 || res.argument == nullptr) { + int code = res.status; + steihaug_result_free(&res); + Rcpp::stop("steihaug solver failed with internal error code %d", code); + } + + NumericVector counts = NumericVector::create( + _["fn"] = static_cast(res.cost_evals), + _["gr"] = static_cast(res.gradient_evals), + _["hess"] = static_cast(res.hessian_evals), + _["hessvec"] = static_cast(res.hessvec_evals)); + List out = List::create( + _["par"] = NumericVector(res.argument, res.argument + n), + _["value"] = res.value, + _["gradient"] = NumericVector(res.gradient, res.gradient + n), + _["iterations"] = res.iterations, _["converged"] = res.converged != 0, + _["status"] = res.status, _["message"] = steihaug_status_name(res.status), + _["radius"] = res.radius, _["counts"] = counts); + if (o.trace) { + int m = res.trace_len; + DataFrame tr = DataFrame::create( + _["iter"] = IntegerVector(res.trace_iter, res.trace_iter + m), + _["radius"] = NumericVector(res.trace_radius, res.trace_radius + m), + _["value"] = NumericVector(res.trace_cost, res.trace_cost + m), + _["gradnorm"] = NumericVector(res.trace_gradnorm, res.trace_gradnorm + m), + _["trialValue"] = + NumericVector(res.trace_trial_cost, res.trace_trial_cost + m), + _["preddiff"] = NumericVector(res.trace_pred, res.trace_pred + m), + _["rho"] = NumericVector(res.trace_rho, res.trace_rho + m), + _["stepnorm"] = NumericVector(res.trace_step_norm, res.trace_step_norm + m), + _["accept"] = LogicalVector(res.trace_accept, res.trace_accept + m), + _["hitBoundary"] = + LogicalVector(res.trace_hit_boundary, res.trace_hit_boundary + m), + _["cgIter"] = IntegerVector(res.trace_cg_iter, res.trace_cg_iter + m)); + out["trace"] = tr; + } + steihaug_result_free(&res); + return out; +} diff --git a/src/steihaug_types.h b/src/steihaug_types.h new file mode 100644 index 0000000..c3ddb85 --- /dev/null +++ b/src/steihaug_types.h @@ -0,0 +1,5 @@ +#ifndef STEIHAUG_TYPES_SRC_FORWARD_H +#define STEIHAUG_TYPES_SRC_FORWARD_H +/* Canonical definitions live in inst/include/steihaug_types.h. */ +#include "../inst/include/steihaug_types.h" +#endif diff --git a/src/trust_register.cpp b/src/trust_register.cpp index 13d0a3d..0800bdd 100644 --- a/src/trust_register.cpp +++ b/src/trust_register.cpp @@ -4,7 +4,7 @@ // n1qn1c/inst/include/n1qn1c.h), and separately registers the same // pointers via R_RegisterCCallable for completeness/introspection. // -// Both trust_solve_c AND trust_result_free must be exposed this way: a +// Every solver AND its matching *_result_free must be exposed this way: a // consumer never links against RcppTrust's shared library, so it cannot // call either one directly by name -- only through the resolved pointer. // @@ -14,24 +14,32 @@ // initialization via `// [[Rcpp::init]]` rather than a hand-written // src/init.c (which would collide with the generated one). #include +#include "minqa_types.h" +#include "steihaug_types.h" #include "trust_types.h" using namespace Rcpp; +// Slot order is part of the ABI consumed by inst/include/RcppTrust.h: +// only ever append, never reorder or remove. // [[Rcpp::export]] SEXP trust_ptr() { -#define nVec 2 - SEXP p0 = PROTECT(R_MakeExternalPtrFn((DL_FUNC)&trust_solve_c, R_NilValue, R_NilValue)); - SEXP p1 = - PROTECT(R_MakeExternalPtrFn((DL_FUNC)&trust_result_free, R_NilValue, R_NilValue)); + static const char *names[] = {"trust_solve_c", "trust_result_free", + "bobyqa_solve_c", "newuoa_solve_c", + "minqa_result_free", "steihaug_solve_c", + "steihaug_result_free"}; + DL_FUNC fns[] = {(DL_FUNC)&trust_solve_c, (DL_FUNC)&trust_result_free, + (DL_FUNC)&bobyqa_solve_c, (DL_FUNC)&newuoa_solve_c, + (DL_FUNC)&minqa_result_free, (DL_FUNC)&steihaug_solve_c, + (DL_FUNC)&steihaug_result_free}; + const int nVec = sizeof(fns) / sizeof(fns[0]); SEXP ret = PROTECT(Rf_allocVector(VECSXP, nVec)); SEXP retN = PROTECT(Rf_allocVector(STRSXP, nVec)); - SET_VECTOR_ELT(ret, 0, p0); - SET_STRING_ELT(retN, 0, Rf_mkChar("trust_solve_c")); - SET_VECTOR_ELT(ret, 1, p1); - SET_STRING_ELT(retN, 1, Rf_mkChar("trust_result_free")); + for (int i = 0; i < nVec; i++) { + SET_VECTOR_ELT(ret, i, R_MakeExternalPtrFn(fns[i], R_NilValue, R_NilValue)); + SET_STRING_ELT(retN, i, Rf_mkChar(names[i])); + } Rf_setAttrib(ret, R_NamesSymbol, retN); - UNPROTECT(nVec + 2); -#undef nVec + UNPROTECT(2); return ret; } @@ -39,4 +47,10 @@ SEXP trust_ptr() { void trust_register_ccallable(DllInfo *dll) { R_RegisterCCallable("RcppTrust", "trust_solve_c", (DL_FUNC)&trust_solve_c); R_RegisterCCallable("RcppTrust", "trust_result_free", (DL_FUNC)&trust_result_free); + R_RegisterCCallable("RcppTrust", "bobyqa_solve_c", (DL_FUNC)&bobyqa_solve_c); + R_RegisterCCallable("RcppTrust", "newuoa_solve_c", (DL_FUNC)&newuoa_solve_c); + R_RegisterCCallable("RcppTrust", "minqa_result_free", (DL_FUNC)&minqa_result_free); + R_RegisterCCallable("RcppTrust", "steihaug_solve_c", (DL_FUNC)&steihaug_solve_c); + R_RegisterCCallable("RcppTrust", "steihaug_result_free", + (DL_FUNC)&steihaug_result_free); } diff --git a/tests/testthat/test-minqa.R b/tests/testthat/test-minqa.R new file mode 100644 index 0000000..c9921e7 --- /dev/null +++ b/tests/testthat/test-minqa.R @@ -0,0 +1,207 @@ +# The BOBYQA/NEWUOA ports must reproduce minqa 1.2.8's results exactly +# (same evaluations, same iterates) for runs that never enter BOBYQA's +# RESCUE step, where minqa's rescue.f evaluates at uninitialized memory. + +fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +extRosen <- function(x) { + n <- length(x) + sum(100 * (x[-1] - x[-n]^2)^2 + (1 - x[-n])^2) +} +chebyquad <- function(x) { + n <- length(x) + res <- numeric(n) + for (i in 1:n) { + rr <- 0 + for (k in 1:n) { + z7 <- 1; z2 <- 2 * x[k] - 1; z8 <- z2; j <- 1 + while (j < i) { z6 <- z7; z7 <- z8; z8 <- 2 * z2 * z7 - z6; j <- j + 1 } + rr <- rr + z8 + } + rr <- rr / n + if (2 * trunc(i / 2) == i) rr <- rr + 1 / (i * i - 1) + res[i] <- rr + } + sum(res * res) +} + +# Bitwise agreement is established on x86_64, where neither gfortran nor +# the C++ compiler contracts to FMA. Elsewhere minqa's Fortran may be +# contracted differently, so only numeric agreement is required. +bitwise <- R.version$arch %in% c("x86_64", "amd64") + +# `wellPosed = FALSE` marks runs (e.g. a bound range of 1e-7) whose end +# point is sensitive to rounding, so contracted and uncontracted builds +# legitimately stop at different points. +expectSameAsMinqa <- function(ours, theirs, wellPosed = TRUE) { + expect_identical(class(ours), class(theirs)) + if (bitwise) { + expect_identical(ours$par, theirs$par) + expect_identical(ours$fval, theirs$fval) + expect_identical(ours$feval, theirs$feval) + expect_identical(ours$ierr, theirs$ierr) + expect_identical(ours$msg, theirs$msg) + } else if (wellPosed) { + expect_equal(ours$par, theirs$par, tolerance = 1e-4) + expect_equal(ours$ierr, theirs$ierr) + } +} + +test_that("bobyqa() matches minqa::bobyqa() exactly", { + skip_if_not_installed("minqa") + cases <- list( + list(par = c(1, 2), fn = fr, lower = c(0, 0), upper = c(4, 4)), + list(par = c(-1.2, 1), fn = fr, lower = -Inf, upper = Inf), + list(par = rep(0.5, 6), fn = extRosen, lower = -2, upper = 2, + control = list(npt = 13)), + list(par = seq(0.1, 0.9, length.out = 6), fn = chebyquad, lower = 0, + upper = 1), + list(par = c(1, 2), fn = fr, lower = c(0, 0), upper = c(4, 4), + control = list(maxfun = 50)), + list(par = c(4, 4), fn = fr, lower = c(0, 3.9999999), upper = c(4, 4), + wellPosed = FALSE) + ) + for (cs in cases) { + ctrl <- if (is.null(cs$control)) list() else cs$control + ours <- suppressWarnings(bobyqa(cs$par, cs$fn, cs$lower, cs$upper, ctrl)) + theirs <- suppressWarnings(minqa::bobyqa(cs$par, cs$fn, cs$lower, + cs$upper, ctrl)) + expectSameAsMinqa(ours, theirs, wellPosed = !isFALSE(cs$wellPosed)) + } +}) + +test_that("newuoa() matches minqa::newuoa() exactly", { + skip_if_not_installed("minqa") + cases <- list( + list(par = c(-1.2, 1), fn = fr), + list(par = rep(0.5, 6), fn = extRosen, control = list(npt = 13)), + list(par = seq(0.1, 0.9, length.out = 6), fn = chebyquad, + control = list(npt = 28)), + list(par = rep(pi, 4), fn = function(x) -(10 - sum(x * seq_along(x))^2), + control = list(maxfun = 25)) + ) + for (cs in cases) { + ctrl <- if (is.null(cs$control)) list() else cs$control + ours <- suppressWarnings(newuoa(cs$par, cs$fn, ctrl)) + theirs <- suppressWarnings(minqa::newuoa(cs$par, cs$fn, ctrl)) + expectSameAsMinqa(ours, theirs) + } +}) + +test_that("minqa iprint output matches minqa", { + skip_if_not_installed("minqa") + skip_if_not(bitwise) + # On Windows, Rprintf() (used by minqa) and the C++ snprintf() used by the + # port's print callback format "%#14.8g" differently (e.g. "196.00" vs + # "196.00000"), so the text can only be compared elsewhere. + skip_on_os("windows") + ours <- capture.output(newuoa(c(1, 2), fr, control = list(iprint = 3))) + theirs <- capture.output(minqa::newuoa(c(1, 2), fr, + control = list(iprint = 3))) + expect_identical(ours, theirs) + ours <- capture.output(bobyqa(c(1, 2), fr, 0, 4, control = list(iprint = 2))) + theirs <- capture.output(minqa::bobyqa(c(1, 2), fr, 0, 4, + control = list(iprint = 2))) + expect_identical(ours, theirs) +}) + +test_that("minqa-style error codes and messages", { + r <- bobyqa(c(1, 2), fr, lower = c(0, 0), upper = c(4, 4), + control = list(maxfun = 50)) + expect_equal(r$ierr, 1) + expect_match(r$msg, "maximum number of function evaluations") + expect_s3_class(r, c("bobyqa", "minqa")) + expect_output(print(r), "parameter estimates") + r <- newuoa(c(-1.2, 1), fr) + expect_equal(r$ierr, 0) + expect_equal(r$msg, "Normal exit from newuoa") + expect_equal(r$par, c(1, 1), tolerance = 1e-4) +}) + +test_that("R errors inside fn propagate unchanged", { + bad <- function(x) if (x[1] > 1.1) stop("boom") else fr(x) + expect_error(newuoa(c(1, 2), bad), "boom") + expect_error(bobyqa(c(1, 2), bad, lower = 0, upper = 4), "boom") + expect_error(bobyqa(c(5, 2), fr, lower = 0, upper = 4), + "Starting values violate bounds") +}) + +test_that("extra arguments and names are passed to fn", { + seen <- NULL + f <- function(x, a) { + seen <<- names(x) + sum((x - a)^2) + } + r <- newuoa(c(p = 0.5, q = 0.5), f, a = c(1, 2)) + expect_equal(seen, c("p", "q")) + expect_equal(r$par, c(1, 2), tolerance = 1e-5) +}) + +test_that("bobyqa/newuoa C cores give identical results across OpenMP threads", { + for (solver in c("bobyqa", "newuoa")) { + res <- RcppTrust:::solver_openmp_stress_test(solver, 6L, 64L, 2L) + expect_true(res$identical) + } +}) + +test_that("NEWUOA's BIGDEN safeguard path matches minqa", { + skip_if_not_installed("minqa") + # An ill-conditioned quadratic with npt = (n+1)(n+2)/2 drives NEWUOA into + # BIGDEN (the denominator-maximizing alternative step). + dq <- function(x) sum(10^(6 * (seq_along(x) - 1) / (length(x) - 1)) * x^2) + ctrl <- list(npt = 36, rhobeg = 0.5, rhoend = 1e-10, maxfun = 20000) + ours <- suppressWarnings(newuoa(rep(1, 7), dq, control = ctrl)) + theirs <- suppressWarnings(minqa::newuoa(rep(1, 7), dq, control = ctrl)) + expectSameAsMinqa(ours, theirs) +}) + +test_that("BOBYQA's RESCUE path runs deterministically", { + # A Hilbert-matrix quadratic with a tiny rhoend enters RESCUE, where minqa + # 1.2.8 itself evaluates uninitialized memory, so there is no minqa + # reference: the port must converge and repeat exactly. + hilb <- function(x) { + n <- length(x) + drop(x %*% (1 / (outer(0:(n - 1), 0:(n - 1), "+") + 1)) %*% x) + } + ctrl <- list(npt = 36, rhobeg = 0.5, rhoend = 1e-10, maxfun = 20000) + a <- suppressWarnings(bobyqa(rep(1, 7), hilb, -2, 2, control = ctrl)) + b <- suppressWarnings(bobyqa(rep(1, 7), hilb, -2, 2, control = ctrl)) + expect_identical(a, b) + expect_true(a$ierr %in% c(0, 3, 5)) + expect_lt(a$fval, 1e-4) +}) + +test_that("minqa R wrapper argument handling", { + expect_warning(newuoa(c(1, 2), fr, control = list(foo = 1)), + "unused control arguments") + expect_warning(newuoa(c(1, 2), fr, control = list(npt = 6)), + "not recommended") + expect_error(newuoa(c(1, 2), function(x) c(1, 2)), "single numeric") + expect_error(bobyqa(c(1, 2), function(x) "a", 0, 4), "single numeric") + expect_warning(bobyqa(c(5, 2), fr, lower = 0, upper = 4, + control = list(obstop = FALSE)), + "adjusted to nearest bound") + expect_output(bobyqa(c(1, 2), fr, 0, 4, control = list(iprint = 7)), + "At return") + if (bitwise) { + # An unbounded linear objective ends in the ierr = 3 exit only through + # rounding at huge magnitudes, which is x86_64-specific. + r <- newuoa(c(1, 1, 1), function(x) sum(x), control = list(npt = 5)) + expect_equal(r$ierr, 3) + expect_match(r$msg, "failed to reduce q") + } +}) + +test_that("minqa C entry points reject bad input and report callback failures", { + codes <- RcppTrust:::solver_c_api_edge_test() + expect_equal(codes[["newuoa_null_opts"]], 0L) + expect_equal(codes[["bobyqa_null_opts"]], 0L) + expect_equal(codes[["newuoa_zero_start"]], -3L) + expect_equal(codes[["bobyqa_negative_n"]], -3L) + expect_equal(codes[["newuoa_null_result"]], -3L) + expect_equal(codes[["newuoa_bad_npt"]], 2L) + expect_equal(codes[["bobyqa_bad_npt"]], 2L) + expect_equal(codes[["bobyqa_range"]], 4L) + expect_equal(codes[["newuoa_objfun_error"]], -1L) + expect_equal(codes[["bobyqa_objfun_error"]], -1L) + expect_equal(codes[["newuoa_nonfinite_x"]], -2L) +}) diff --git a/tests/testthat/test-steihaug.R b/tests/testthat/test-steihaug.R new file mode 100644 index 0000000..1a1234b --- /dev/null +++ b/tests/testthat/test-steihaug.R @@ -0,0 +1,131 @@ +fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +grr <- function(x) c(-400 * x[1] * (x[2] - x[1]^2) - 2 * (1 - x[1]), + 200 * (x[2] - x[1]^2)) +hr <- function(x) matrix(c(1200 * x[1]^2 - 400 * x[2] + 2, -400 * x[1], + -400 * x[1], 200), 2, 2) +hv <- function(x, v) drop(hr(x) %*% v) + +test_that("steihaug() minimizes Rosenbrock with basin's evaluation pattern", { + r <- steihaug(c(-1.2, 1), fr, grr, hr) + expect_true(r$converged) + expect_equal(r$message, "GradientTolerance") + expect_equal(r$par, c(1, 1), tolerance = 1e-8) + # Reference counts from basin 1.12.0 (TrustRegion, + # absolute gradient tolerance 1e-8): 27 iterations, 31 cost, + # 28 gradient and 27 Hessian evaluations. + expect_equal(r$iterations, 27L) + expect_equal(unname(r$counts), c(31, 28, 27, 0)) +}) + +test_that("matrix-free mode follows the same path as exact mode", { + e <- steihaug(c(-1.2, 1), fr, grr, hr) + m <- steihaug(c(-1.2, 1), fr, grr, hessvec = hv) + expect_identical(e$par, m$par) + expect_identical(e$iterations, m$iterations) + expect_equal(unname(m$counts), c(31, 28, 0, 76)) +}) + +test_that("control settings and termination reasons", { + r <- steihaug(c(-1.2, 1), fr, grr, hr, control = list(maxit = 5)) + expect_equal(r$message, "MaxIter") + expect_false(r$converged) + expect_equal(r$iterations, 5L) + + r <- steihaug(c(-1.2, 1), fr, grr, hr, + control = list(gradTol = NULL, targetCost = 1e-6)) + expect_equal(r$message, "TargetCost") + expect_lte(r$value, 1e-6) + + r <- steihaug(c(-1.2, 1), fr, grr, hr, control = list(trace = TRUE)) + expect_s3_class(r$trace, "data.frame") + expect_equal(sum(r$trace$accept), r$iterations) + + expect_error(steihaug(c(-1.2, 1), fr, grr, hr, control = list(eta = 0.5)), + "invalid") + expect_warning(steihaug(c(-1.2, 1), fr, grr, hr, control = list(foo = 1)), + "unused control") + expect_error(steihaug(c(-1.2, 1), fr, grr), "hess") + expect_error(steihaug(c(-1.2, 1), fr, grr, hr, control = list(maxit = Inf)), + "maxit") + expect_error(steihaug(numeric(0), fr, grr, hr), "non-empty") +}) + +test_that("errors and malformed returns in R callbacks propagate", { + expect_error(steihaug(c(-1.2, 1), fr, function(x) stop("gradfail"), hr), + "gradfail") + expect_error(steihaug(c(-1.2, 1), fr, function(x) 1, hr), "length 2") + expect_error(steihaug(c(-1.2, 1), fr, grr, function(x) diag(3)), "2 by 2") +}) + +test_that("infinite trial values are rejected, not accepted", { + f <- function(x) if (any(x <= 0)) Inf else sum(x - log(x)) + g <- function(x) 1 - 1 / x + h <- function(x) diag(1 / x^2, length(x)) + r <- steihaug(c(3, 0.2), f, g, h) + expect_true(r$converged) + expect_equal(r$par, c(1, 1), tolerance = 1e-6) +}) + +test_that("steihaug C core gives identical results across OpenMP threads", { + for (solver in c("steihaug", "steihaug_hessvec")) { + res <- RcppTrust:::solver_openmp_stress_test(solver, 8L, 64L, 2L) + expect_true(res$identical) + expect_gt(res$nNearOptimum, 0L) + } +}) + +test_that("every Steihaug stopping rule is reachable from R", { + run <- function(...) steihaug(c(-1.2, 1), fr, grr, hr, + control = c(list(gradTol = NULL), list(...))) + expect_equal(run(relGradTol = 1e-6)$message, "RelativeGradientTolerance") + expect_equal(run(stepTol = 1e-8)$message, "ParamTolerance") + expect_equal(run(relStepTol = 1e-8)$message, "RelativeParamTolerance") + expect_equal(run(costTol = 1e-14)$message, "CostTolerance") + expect_equal(run(relCostTol = 0.5)$message, "RelativeCostTolerance") + expect_equal(run(maxCostEvals = 10)$message, "MaxCostEvals") + expect_equal(run(maxGradEvals = 5)$message, "MaxGradientEvals") + r <- run(maxit = 1000) + expect_equal(r$message, "SolverConverged") + expect_true(r$converged) + # General forcing exponent (not 0, 0.5 or 1) and a CG cap. + r <- steihaug(c(-1.2, 1), fr, grr, hr, + control = list(theta = 0.7, kappa = 0.1, cgMaxit = 1, + maxit = 50)) + expect_equal(r$message, "MaxIter") + r <- steihaug(c(-1.2, 1), fr, grr, hr, control = list(theta = 0)) + expect_true(r$converged) + # A NaN gradient is a failure, not convergence. + r <- steihaug(c(1, 1), fr, function(x) c(NaN, 0), hr) + expect_equal(r$message, "SolverFailed") + expect_false(r$converged) +}) + +test_that("steihaug() validates its inputs", { + expect_error(steihaug(c(1, NA), fr, grr, hr), "finite") + expect_error(steihaug(c(1, 1), 1, grr, hr), "fn must") + expect_error(steihaug(c(1, 1), fr, 1, hr), "gr must") + expect_error(steihaug(c(1, 1), fr, grr, 1), "hess must") + expect_error(steihaug(c(1, 1), fr, grr, hessvec = 1), "hessvec must") + expect_error(steihaug(c(1, 1), fr, grr, hr, control = 1), "list") + expect_error(steihaug(c(1, 1), fr, grr, hr, control = list(rinit = NA)), + "rinit") + expect_error(steihaug(c(1, 1), fr, grr, hr, control = list(gradTol = "a")), + "gradTol") + expect_error(steihaug(c(1, 1), function(x) c(1, 2), grr, hr), "single") + expect_error(steihaug(c(-1.2, 1), fr, grr, hessvec = function(x, v) 1), + "length 2") + expect_error(steihaug(c(-1.2, 1), fr, grr, + hessvec = function(x, v) stop("hvx")), + "hvx") +}) + +test_that("Steihaug C entry point rejects bad input and reports failures", { + codes <- RcppTrust:::solver_c_api_edge_test() + expect_equal(codes[["steihaug_ok"]], 4L) + expect_equal(codes[["steihaug_null_opts"]], -3L) + expect_equal(codes[["steihaug_bad_eta"]], -3L) + expect_equal(codes[["steihaug_nan_tol"]], -3L) + expect_equal(codes[["steihaug_objfun_error"]], -1L) + expect_equal(codes[["steihaug_hessvec_error"]], -2L) + expect_equal(codes[["steihaug_zero_n"]], -3L) +}) diff --git a/vignettes/RcppTrust.Rmd b/vignettes/RcppTrust.Rmd index f181cbb..4d0564d 100644 --- a/vignettes/RcppTrust.Rmd +++ b/vignettes/RcppTrust.Rmd @@ -21,6 +21,12 @@ package actually needs to know: what carries over unchanged, what's new, and how to call the new thread-safe C interface from your own package. +The package also includes three more trust-region optimizers built the +same way, each with an R function and a thread-safe C core: `steihaug()` +(truncated-CG trust region, ported from the Rust crate basin), and +`bobyqa()` and `newuoa()` (Powell's derivative-free methods, ported +from `minqa`). They are covered in `vignette("trust-region-methods")`. + ## Similarities: what carries over unchanged `RcppTrust::trust()` is a drop-in replacement for `trust::trust()`. It @@ -283,7 +289,10 @@ reproduces in a single self-contained file for demonstration. } ``` - After that, `trust_solve_c_ptr` and `trust_result_free_ptr` are + After that, `trust_solve_c_ptr` and `trust_result_free_ptr` (and, + for the other optimizers, `steihaug_solve_c_ptr`, + `bobyqa_solve_c_ptr`, `newuoa_solve_c_ptr` and their `*_free_ptr` + partners; see `vignette("trust-region-methods")`) are live function pointers with the same signatures as `trust_solve_c()`/`trust_result_free()`, usable anywhere in your package's C++ -- including inside an OpenMP loop fitting many diff --git a/vignettes/trust-region-methods.Rmd b/vignettes/trust-region-methods.Rmd new file mode 100644 index 0000000..90a1756 --- /dev/null +++ b/vignettes/trust-region-methods.Rmd @@ -0,0 +1,297 @@ +--- +title: "More Trust-Region Methods: Steihaug, BOBYQA and NEWUOA" +author: "Matthew Fidler" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{More Trust-Region Methods: Steihaug, BOBYQA and NEWUOA} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>") +``` + +Besides `trust()`, `RcppTrust` ships three more trust-region optimizers. +Each one has the same two layers as `trust()`: an R function for +interactive use, and a thread-safe C core with no R API calls and no +global state. The C core can run as an inner or outer optimizer inside +parallel C++ code such as `nlmixr2est`. + +| R function | Ported from | Derivatives needed | Bounds | Thread-safe C entry point | +|---|---|---|---|---| +| `trust()` | CRAN `trust` (Geyer) | gradient + Hessian | no | `trust_solve_c()` | +| `steihaug()` | Rust crate [basin](https://github.com/jolars/basin) | gradient + Hessian, or Hessian-vector products | no | `steihaug_solve_c()` | +| `bobyqa()` | Powell's BOBYQA Fortran, via CRAN `minqa` | none | box | `bobyqa_solve_c()` | +| `newuoa()` | Powell's NEWUOA Fortran, via CRAN `minqa` | none | no | `newuoa_solve_c()` | + +## How the methods differ + +All four repeat the same loop: build a quadratic model of the +objective, minimize it within a radius around the current point, +compare the actual decrease with the predicted one, and grow or shrink +the radius. They differ in where the model comes from and how the +subproblem is solved. + +- **`trust()`** uses the exact gradient and Hessian, and solves the + subproblem nearly exactly with an eigendecomposition. That is robust, + but each iteration costs O(n^3). +- **`steihaug()`** uses the same derivative-based model, but solves the + subproblem approximately by conjugate gradients (CG). CG stops early + when it reaches the trust-region boundary or finds a direction of + negative curvature. The Hessian is never factorized. If you supply + only Hessian-vector products (`hessvec`), the Hessian is never formed + at all. +- **`bobyqa()` and `newuoa()`** never use derivatives. They fit the + quadratic model through `npt` previously evaluated points (usually + `2n + 1`), and take up the model's remaining freedom with the + smallest change to its Hessian. The step is found by truncated CG, so + NEWUOA's subproblem solver is close in spirit to Steihaug's; BOBYQA's + also respects box bounds. They track two radii: `rho`, a lower bound + that only shrinks, from `rhobeg` to `rhoend`, and controls + termination; and `delta`, the step radius, which can grow and shrink + above it. + +## Steihaug truncated-CG trust region + +`steihaug()` takes separate objective, gradient and Hessian functions, +because basin requests each one separately. It reproduces basin's +evaluation pattern: + +- `fn` and `gr` once at the start; +- `hess` once per outer iteration; +- `fn` at each trial point; +- `gr` after each accepted step. + +```{r} +library(RcppTrust) + +fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +grr <- function(x) c(-400 * x[1] * (x[2] - x[1]^2) - 2 * (1 - x[1]), + 200 * (x[2] - x[1]^2)) +hr <- function(x) matrix(c(1200 * x[1]^2 - 400 * x[2] + 2, -400 * x[1], + -400 * x[1], 200), 2, 2) + +r <- steihaug(c(-1.2, 1), fr, grr, hr) +r[c("par", "value", "iterations", "message", "counts")] +``` + +In matrix-free mode you supply `hessvec(x, v)` instead of `hess`. The +iterates are the same, but CG calls `hessvec` once per product instead +of forming the matrix: + +```{r} +hv <- function(x, v) drop(hr(x) %*% v) +m <- steihaug(c(-1.2, 1), fr, grr, hessvec = hv) +identical(m$par, r$par) +m$counts +``` + +`control$trace = TRUE` returns one row per subproblem attempt, with the +radius, predicted and actual reduction, `rho`, whether the step was +accepted, whether it hit the boundary, and how many CG iterations it +took: + +```{r} +tr <- steihaug(c(-1.2, 1), fr, grr, hr, control = list(trace = TRUE))$trace +head(tr) +``` + +### What matches basin + +The C++ port reproduces basin's arithmetic in the same order, with +floating-point contraction turned off. On 33 test setups, each run in +both exact and matrix-free mode, it matches a basin reference program +bit for bit: every evaluation point, iteration count, termination +reason and evaluation count. + +The differences from basin are deliberate: + +- **Defaults:** `maxit` is 100 (basin's executor allows 1000) and the + absolute gradient tolerance is on at `1e-8` (off in basin). Every + other tolerance is off unless you set it in `control`, as in basin. +- **Errors:** an error in an R callback is raised again as the same R + error. In C, the solver returns an error code together with the state + at the start of the failing iteration, where basin throws the state + away. +- **Not ported:** basin's wall-clock limits, observers and cancellation + tokens. + +## BOBYQA and NEWUOA + +`bobyqa()` and `newuoa()` are drop-in replacements for `minqa::bobyqa()` +and `minqa::newuoa()`. The arguments, `control` settings, defaults, +warnings, printed output and return values are the same: + +```{r} +fr <- function(x) 100 * (x[2] - x[1]^2)^2 + (1 - x[1])^2 +bobyqa(c(1, 2), fr, lower = c(0, 0), upper = c(4, 4)) +newuoa(c(-1.2, 1), fr) +``` + +Powell's Fortran 77 code (the unmodified originals are archived in +[PRIMA](https://github.com/libprima/prima/tree/main/fortran/original)), +in the modified form distributed with `minqa`, was translated line by +line into C++ (Powell, 2006; Powell, 2009). The port keeps +Powell's variable names, workspace layout, `goto` control flow and +order of operations. Compared with `minqa`, the parameters, objective +values, evaluation counts and error codes are bitwise identical: + +```{r, eval = requireNamespace("minqa", quietly = TRUE)} +extRosen <- function(x) { + n <- length(x) + sum(100 * (x[-1] - x[-n]^2)^2 + (1 - x[-n])^2) +} +ours <- bobyqa(rep(0.5, 6), extRosen, lower = -2, upper = 2, + control = list(npt = 13)) +theirs <- minqa::bobyqa(rep(0.5, 6), extRosen, lower = -2, upper = 2, + control = list(npt = 13)) +identical(unclass(ours), unclass(theirs)) +``` + +**One intentional difference.** In `minqa` 1.2.8, BOBYQA's `RESCUE` +routine calls the objective as `CALFUN(N,X,IPRINT)`, but `X` is not +defined inside `RESCUE`. As a result, `minqa` evaluates the objective +at whatever is in uninitialized memory, and the same run can give +different results from one call to the next. The port evaluates the +point Powell's original code intended, `W(1..N)`. `RESCUE` is only +entered on badly conditioned problems, so ordinary runs never hit it. +The runs that do enter `RESCUE` were checked against a copy of `minqa` +with only that line fixed, and matched it exactly. + +UOBYQA from `minqa` is not included. It needs `(n+1)(n+2)/2` points, +which grows as O(n^2), and NEWUOA covers the same unconstrained, +derivative-free case with far fewer points. + +## The thread-safe C interfaces + +Each solver has a plain C header, installed with the package: + +- `minqa_types.h`: `bobyqa_solve_c()`, `newuoa_solve_c()`, + `minqa_result_free()`, `minqa_options_default()`; +- `steihaug_types.h`: `steihaug_solve_c()`, `steihaug_result_free()`, + `steihaug_options_default()`. + +The conventions are the same as for `trust_solve_c()`: + +- Options live in a plain struct. +- The objective receives an opaque `userdata` pointer. +- Results are written to a caller-supplied struct that owns its buffers + until you call the matching `*_result_free()`. +- There are no locks and no shared mutable state, so any number of + threads can each run their own solve. + +For the minqa solvers, printing (`iprint`) goes through an optional +callback instead of `Rprintf()`, and is silent by default. + +A consuming package reaches these cores through the same header-only +pointer table described in `vignette("RcppTrust")`. After +`iniRcppTrustPtrs()` runs, `bobyqa_solve_c_ptr`, `newuoa_solve_c_ptr`, +`minqa_result_free_ptr`, `steihaug_solve_c_ptr` and +`steihaug_result_free_ptr` are available alongside `trust_solve_c_ptr`. +New slots are only ever appended to the table. When the installed +`RcppTrust` is older than the header a consumer was built against, the +missing pointers are left `NULL`, so check them before use. + +The example below runs NEWUOA and matrix-free Steihaug on many starting +points inside an OpenMP loop, through the resolved pointers: + +```{r} +cpp_code <- ' +// [[Rcpp::depends(RcppTrust)]] +#include +#include + +extern "C" { +#define iniRcppTrustPtrs _vignette2_iniRcppTrustPtrs +#include +iniRcppTrust +} + +// Derivative-free objective for NEWUOA. +extern "C" int rosen_f(int n, const double *x, double *f, void *) { + double t = x[1] - x[0] * x[0]; + *f = 100.0 * t * t + (1.0 - x[0]) * (1.0 - x[0]); + return 0; +} + +// Value/gradient on request, for Steihaug. The Hessian is never requested +// in matrix-free mode. +extern "C" int rosen_vg(int n, const double *x, double *value, + double *gradient, double *hessian, void *) { + double t = x[1] - x[0] * x[0]; + if (value) *value = 100.0 * t * t + (1.0 - x[0]) * (1.0 - x[0]); + if (gradient) { + gradient[0] = -400.0 * x[0] * t - 2.0 * (1.0 - x[0]); + gradient[1] = 200.0 * t; + } + return 0; +} + +extern "C" int rosen_hv(int n, const double *x, const double *v, double *hv, + void *) { + double h11 = 1200.0 * x[0] * x[0] - 400.0 * x[1] + 2.0, h12 = -400.0 * x[0]; + hv[0] = h11 * v[0] + h12 * v[1]; + hv[1] = h12 * v[0] + 200.0 * v[1]; + return 0; +} + +// [[Rcpp::export]] +Rcpp::NumericMatrix fit_many(SEXP ptrTable, int nStarts) { + _vignette2_iniRcppTrustPtrs(ptrTable); // normally done once in .onLoad() + Rcpp::NumericMatrix out(nStarts, 4); + std::vector res(4 * nStarts); + // Build with OpenMP (e.g. -fopenmp in the package Makevars) to run + // this loop in parallel; without it the pragma is ignored. + #pragma omp parallel for num_threads(2) + for (int i = 0; i < nStarts; i++) { + double start[2] = {-1.2 + 0.05 * i, 1.0}; + + minqa_options_t mo = minqa_options_default(2, start); + minqa_result_t mr; + newuoa_solve_c_ptr(2, start, rosen_f, nullptr, &mo, &mr); + + steihaug_options_t so = steihaug_options_default(); + steihaug_result_t sr; + steihaug_solve_c_ptr(2, start, rosen_vg, rosen_hv, nullptr, &so, &sr); + + res[4 * i] = mr.par[0]; + res[4 * i + 1] = mr.feval; + res[4 * i + 2] = sr.argument[0]; + res[4 * i + 3] = sr.iterations; + minqa_result_free_ptr(&mr); + steihaug_result_free_ptr(&sr); + } + for (int i = 0; i < nStarts; i++) + for (int j = 0; j < 4; j++) out(i, j) = res[4 * i + j]; + Rcpp::colnames(out) = Rcpp::CharacterVector::create( + "newuoa_x1", "newuoa_feval", "steihaug_x1", "steihaug_iter"); + return out; +} +' +Rcpp::sourceCpp(code = cpp_code) +head(fit_many(RcppTrust:::.RcppTrustPtr(), 16L)) +``` + +Every call inside the loop gets its own options, result and workspace, +so the threads need no coordination. The package's test suite runs each +solver on 64 starting points both sequentially and across OpenMP +threads, and checks that the two sets of results are bitwise identical. + +## References + +Powell, M. J. D. (2006). The NEWUOA software for unconstrained +optimization without derivatives. In G. Di Pillo and M. Roma (eds), +*Large-Scale Nonlinear Optimization*, 255-297. Springer. + + +Powell, M. J. D. (2009). *The BOBYQA algorithm for bound constrained +optimization without derivatives*. Report DAMTP 2009/NA06, Centre for +Mathematical Sciences, University of Cambridge. + +Powell, M. J. D. Original Fortran 77 source code for NEWUOA and BOBYQA, +archived at . + +Steihaug, T. (1983). The conjugate gradient method and trust regions in +large scale optimization. *SIAM Journal on Numerical Analysis*, 20(3), +626-637.