Merge branch 'main' into maintenance

nlmixr2 · Sep 20, 2023 · 9b71697 · 9b71697
2 parents 72f3c77 + 5c05694
commit 9b71697
Show file tree

Hide file tree

Showing 4 changed files with 102 additions and 84 deletions.
diff --git a/NEWS b/NEWS
diff --git a/NEWS.md b/NEWS.md
@@ -1,7 +1,27 @@
 # lbfgsb3c development changes
 
+* Now allow `rho=NULL` to work the same as if `rho` was not supplied
+
 * Be More careful about `$convergence` by adding a default value of `NA_INTEGER`
 
 * `$convergence` is now an integer instead of a real number
 
 * Added a `NEWS.md` file to track changes to the package.
+
+# News before lbfgsb3c
+
+To do
+
+Add test using a plain C function for optimization. lbfgsb3c is
+supposed to handle this.
+
+--------------------------------------------------------------
+2019-03-19
+    o Packages lbfgsb3 and lbfgsb3c merged into latter. Vignette added.
+    o Suppressed printout when trace>2 and starting (f not defined)
+
+2015-01-20
+    o Fixup line longer than 72 chars in lbfgsb.f. Undeclared
+      integer itask in errclb subroutine. Thanks to Berend Hasselman.
+
+New package lbfgsb3 2014.7.31
diff --git a/R/lbfgsb3.R b/R/lbfgsb3.R
@@ -101,6 +101,7 @@
 ##' program as well as adjustments to the tolerances that were not
 ##' present in the original CRAN package.  Also adjustments were made
 ##' to have outputs conform with R's optim routine.
+##'
 ##' @examples
 ##' # Rosenbrock's banana function
 ##' n=3; p=100
@@ -134,47 +135,47 @@
 ##' @export
 lbfgsb3c <- function(par, fn, gr=NULL, lower = -Inf, upper = Inf,
                      control=list(), ..., rho=NULL){
-# control defaults -- idea from spg
-    ctrl <- list(trace= 0L,
-                 maxit=100L,
-                 iprint= -1L,
-                 lmm=5,
-                 factr=1e7,
-                 pgtol=0,
-                 reltol=0,
-                 abstol=0,
-                 info=FALSE);
-    callstak <- sys.calls() # get the call stack
-    lcs <- length(callstak)
-    fstr <- as.character(callstak[lcs])
-    fstr <- strsplit(fstr, "(", fixed=TRUE)[[1]][1]
-    if (ctrl$trace > 0) { cat("Using function ",fstr,"\n") }
-    if ( (fstr == "lbfgsb3") || (fstr == "lbfgsb3f") ) { ctrl$info <- TRUE }
-    # This emits more information from lbfgsb3 Fortran code.
-    namc <- names(control)
-    if (!all(namc %in% names(ctrl)))
-        stop("unknown names in control: ", namc[!(namc %in% names(ctrl))])
-    ctrl[namc] <- control
-    if (missing(rho)){
-        rho <- as.environment(list(...));
+  # control defaults -- idea from spg
+  ctrl <- list(trace= 0L,
+               maxit=1000L,
+               iprint= -1L,
+               lmm=5,
+               factr=1e7,
+               pgtol=0,
+               reltol=1e-6,
+               abstol=0,
+               info=FALSE);
+  callstak <- sys.calls() # get the call stack
+  lcs <- length(callstak)
+  fstr <- as.character(callstak[lcs])
+  fstr <- strsplit(fstr, "(", fixed=TRUE)[[1]][1]
+  if (ctrl$trace > 0) { cat("Using function ",fstr,"\n") }
+  if ( (fstr == "lbfgsb3") || (fstr == "lbfgsb3f") ) { ctrl$info <- TRUE }
+  # This emits more information from lbfgsb3 Fortran code.
+  namc <- names(control)
+  if (!all(namc %in% names(ctrl)))
+    stop("unknown names in control: ", namc[!(namc %in% names(ctrl))])
+  ctrl[namc] <- control
+  if (missing(rho) || is.null(rho)) {
+    rho <- as.environment(list(...));
+  }
+  if (is.null(gr)){
+    gr <- function(x, ...){
+      numDeriv::grad(fn, x, ...);
     }
-    if (is.null(gr)){
-        gr <- function(x, ...){
-            numDeriv::grad(fn, x, ...);
-        }
+  }
+  if (is(fn, "function") & is (gr, "function")){
+    ##        cat("USING fnR, grR\n")
+    fnR <- function(x, rho){
+      do.call(fn, c(list(x), as.list(rho)));
     }
-    if (is(fn, "function") & is (gr, "function")){
-##        cat("USING fnR, grR\n")
-        fnR <- function(x, rho){
-            do.call(fn, c(list(x), as.list(rho)));
-        }
-        grR <- function(x, rho){
-            do.call(gr, c(list(x), as.list(rho)));
-        }
-        return(lbfgsb3cpp(par, fnR, grR, lower, upper, ctrl, rho));
-    } else {
-        return(lbfgsb3cpp(par, fn, gr, lower, upper, ctrl, rho));
+    grR <- function(x, rho){
+      do.call(gr, c(list(x), as.list(rho)));
     }
+    return(lbfgsb3cpp(par, fnR, grR, lower, upper, ctrl, rho));
+  } else {
+    return(lbfgsb3cpp(par, fn, gr, lower, upper, ctrl, rho));
+  }
 } # end of lbfgsb3()
 
 ##'@rdname lbfgsb3c

diff --git a/tests/testthat/test-genrose.R b/tests/testthat/test-genrose.R
@@ -1,31 +1,31 @@
 genrose.f <- function(x, gs = NULL) {
-    # objective function
-    ## One generalization of the Rosenbrock banana valley
-    #   function (n parameters)
-    n <- length(x)
-    if (is.null(gs)) {
-        gs = 100
-    }
-    fval <- 1 + sum(gs * (x[1:(n - 1)]^2 - x[2:n])^2 + (x[2:n] -
-        1)^2)
-    return(fval)
+  # objective function
+  ## One generalization of the Rosenbrock banana valley
+  #   function (n parameters)
+  n <- length(x)
+  if (is.null(gs)) {
+    gs = 100
+  }
+  fval <- 1 + sum(gs * (x[1:(n - 1)]^2 - x[2:n])^2 + (x[2:n] -
+                                                        1)^2)
+  return(fval)
 }
 
 genrose.g <- function(x, gs = NULL) {
-    # vectorized gradient for genrose.f
-    # Ravi Varadhan 2009-04-03
-    n <- length(x)
-    if (is.null(gs)) {
-        gs = 100
-    }
-    gg <- as.vector(rep(0, n))
-    tn <- 2:n
-    tn1 <- tn - 1
-    z1 <- x[tn] - x[tn1]^2
-    z2 <- 1 - x[tn]
-    gg[tn] <- 2 * (gs * z1 - z2)
-    gg[tn1] <- gg[tn1] - 4 * gs * x[tn1] * z1
-    gg
+  # vectorized gradient for genrose.f
+  # Ravi Varadhan 2009-04-03
+  n <- length(x)
+  if (is.null(gs)) {
+    gs = 100
+  }
+  gg <- as.vector(rep(0, n))
+  tn <- 2:n
+  tn1 <- tn - 1
+  z1 <- x[tn] - x[tn1]^2
+  z2 <- 1 - x[tn]
+  gg[tn] <- 2 * (gs * z1 - z2)
+  gg[tn1] <- gg[tn1] - 4 * gs * x[tn1] * z1
+  gg
 }
 
 # Unconstrained Genrose test with gradient
@@ -35,9 +35,9 @@ xx <- rep(3, nn)
 lo <- -Inf
 up <- Inf
 test_that("100u", {
-    ans100u <- lbfgsb3c(xx, genrose.f,
-                        genrose.g, gs = 10)
-    expect_equal(1, ans100u$value)
+  ans100u <- lbfgsb3c(xx, genrose.f,
+                      genrose.g, gs = 10)
+  expect_equal(1, ans100u$value)
 })
 
 
@@ -46,7 +46,20 @@ ans100un <- lbfgsb3c(xx, genrose.f,
                      gr = NULL, gs = 10)
 
 test_that("100u", {
-    ans100un <- lbfgsb3c(xx, genrose.f,
-                        gs = 10)
-    expect_equal(1, ans100un$value)
+  ans100un <- lbfgsb3c(xx, genrose.f,
+                       gs = 10)
+  expect_equal(1, ans100un$value)
 })
+
+## context("roskenbrock with 20", {
+
+## x0 <- rep(0.1, 20)
+
+## sol <- lbfgsb3c(x0, genrose.f, genrose.g)
+
+## sol2 <- lbfgsb3c(x0, genrose.f, genrose.g, lower=0, upper=0.5, control=list(factr=1e20))
+
+#optim(x0, genrose.f, genrose.g, method="L-BFGS-B", lower=0, upper=0.5)
+
+
+## })