fix Chwirut1 target + replicate lower/upper bounds

R/nls.R

@@ -67,8 +67,10 @@
 #' }
 #' @param control an optional list of control parameters to tune the least squares iterations and multistart algorithm.
 #' See \code{\link{gsl_nls_control}} for the available control parameters and their default values.
-#' @param lower	a named list or named numeric vector of parameter lower bounds. If missing (default), the parameters are unconstrained from below.
-#' @param upper a named list or named numeric vector of parameter upper bounds. If missing (default), the parameters are unconstrained from above.
+#' @param lower	a named list or named numeric vector of parameter lower bounds, or an unnamed numeric
+#' scalar to be replicated for all parameters. If missing (default), the parameters are unconstrained from below.
+#' @param upper a named list or named numeric vector of parameter upper bounds, or an unnamed numeric
+#' scalar to be replicated for all parameters. If missing (default), the parameters are unconstrained from above.
 #' @param jac either \code{NULL} (default) or a \link{function} returning the \code{n} by \code{p} dimensional Jacobian matrix of
 #' the nonlinear model \code{fn}, where \code{n} is the number of observations and \code{p} the
 #' number of parameters. If a function, the first argument must be the vector of parameters of length \code{p}.
@@ -470,8 +472,8 @@ gsl_nls.formula <- function(fn, data = parent.frame(), start,
 
   ## parameter constraints
   if(!missing(lower) || !missing(upper)) {
-    if(missing(lower)) lower <- structure(rep(-Inf, names = pnames))
-    if(missing(upper)) upper <- structure(rep(Inf, names = pnames))
+    if(missing(lower)) lower <- structure(rep(-Inf, length(pnames)), names = pnames)
+    if(missing(upper)) upper <- structure(rep(Inf, length(pnames)), names = pnames)
     if(is.list(lower)) {
       if(any(lengths(lower) != 1L))
         stop("List elements of 'lower' must have exactly length 1 to specify parameter lower bounds")
@@ -482,10 +484,14 @@ gsl_nls.formula <- function(fn, data = parent.frame(), start,
         stop("List elements of 'upper' must have exactly length 1 to specify parameter upper bounds")
       upper <- unlist(upper)
     }
-    if(any(is.na(match(names(lower), pnames))))
-      stop("Unrecognized parameter names present in 'lower'")
-    if(any(is.na(match(names(upper), pnames))))
-      stop("Unrecognized parameter names present in 'upper'")
+    if(is.null(names(lower)) && identical(length(lower), 1L) && length(pnames) > 1L)
+      lower <- structure(rep(lower, length(pnames)), names = pnames)
+    if(is.null(names(upper)) && identical(length(upper), 1L) && length(pnames) > 1L)
+      upper <- structure(rep(upper, length(pnames)), names = pnames)
+    if(is.null(names(lower)) || any(is.na(match(names(lower), pnames))))
+      stop("Failed to match parameter names between 'start' and 'lower'")
+    if(is.null(names(upper)) || any(is.na(match(names(upper), pnames))))
+      stop("Failed to match parameter names between 'start' and 'upper'")
     if(is.matrix(start))
       startnames <- colnames(start)
     else
@@ -768,8 +774,8 @@ gsl_nls.function <- function(fn, y, start,
       pnames <- colnames(.start)
     else
       pnames <- names(.start)
-    if(missing(lower)) lower <- structure(rep(-Inf, names = pnames))
-    if(missing(upper)) upper <- structure(rep(Inf, names = pnames))
+    if(missing(lower)) lower <- structure(rep(-Inf, length(pnames)), names = pnames)
+    if(missing(upper)) upper <- structure(rep(Inf, length(pnames)), names = pnames)
     if(is.list(lower)) {
       if(any(lengths(lower) != 1L))
         stop("List elements of 'lower' must have exactly length 1 to specify parameter lower bounds")
@@ -780,10 +786,14 @@ gsl_nls.function <- function(fn, y, start,
         stop("List elements of 'upper' must have exactly length 1 to specify parameter upper bounds")
       upper <- unlist(upper)
     }
-    if(any(is.na(match(names(lower), pnames))))
-      stop("Unrecognized parameter names present in 'lower'")
-    if(any(is.na(match(names(upper), pnames))))
-      stop("Unrecognized parameter names present in 'upper'")
+    if(is.null(names(lower)) && identical(length(lower), 1L) && length(pnames) > 1L)
+      lower <- structure(rep(lower, length(pnames)), names = pnames)
+    if(is.null(names(upper)) && identical(length(upper), 1L) && length(pnames) > 1L)
+      upper <- structure(rep(upper, length(pnames)), names = pnames)
+    if(is.null(names(lower)) || any(is.na(match(names(lower), pnames))))
+      stop("Failed to match parameter names between 'start' and 'lower'")
+    if(is.null(names(upper)) || any(is.na(match(names(upper), pnames))))
+      stop("Failed to match parameter names between 'start' and 'upper'")
     .lupars <- matrix(rep(c(-Inf, Inf), times = length(pnames)), nrow = 2L, ncol = length(pnames), dimnames = list(NULL, pnames))
     .lupars[1, match(names(lower), pnames)] <- unname(lower)
     .lupars[2, match(names(upper), pnames)] <- unname(upper)

R/nls_test.R

@@ -229,7 +229,7 @@ nls_test_problem <- function(name, p = NA, n = NA) {
                                 1.75, 1.75, 0.5, 0.75, 2.75, 3.75, 1.75, 1.75))
       .fn <- as.formula("y ~ exp(-b1*x)/(b2+b3*x)", env = environment())
       .start <- c(b1 = 0.1, b2 = 0.01, b3 = 0.02)
-      .target <- c(b1 = 1.9027818370E-01, b2 = 6.1314004477E-03, b4 = 1.0530908399E-02)
+      .target <- c(b1 = 1.9027818370E-01, b2 = 6.1314004477E-03, b3 = 1.0530908399E-02)
     } else if(identical(name, "Lanczos3")) {
       .data <- data.frame(y = c(2.5134, 2.0443, 1.6684, 1.3664, 1.1232,
                                 0.9269, 0.7679, 0.6389, 0.5338, 0.4479, 0.3776, 0.3197, 0.272,