Running 'BIC.R' [2s/2s]
  Running 'ICtab.R' [2s/2s]
  Running 'RUnit-tests.R' [0s/1s]
  Running 'binomtest1.R' [1s/2s]
  Running 'boundstest.R' [0s/1s]
  Running 'controleval.R' [2s/2s]
  Running 'eval.R' [2s/2s]
  Running 'formulatest.R' [2s/3s]
  Running 'glmcomp.R' [2s/2s]
  Running 'gradient_vecpar_profile.R' [2s/2s]
  Running 'grtest1.R' [1s/2s]
  Running 'methods.R' [2s/2s]
  Running 'mortanal.R' [2s/2s]
  Running 'optimize.R' [1s/2s]
  Running 'optimizers.R' [2s/2s]
  Running 'optimx.R' [2s/2s]
  Running 'order.R' [2s/2s]
  Running 'parscale.R' [1s/2s]
  Running 'predict.R' [2s/2s]
  Running 'prof_newmin.R' [2s/2s]
  Running 'prof_spec.R' [2s/2s]
  Running 'profbound.R' [2s/2s]
  Running 'richards.R' [2s/3s]
  Running 'startvals.R' [2s/2s]
  Running 'startvals2.R' [2s/2s]
  Running 'test-relist1.R' [2s/2s]
  Running 'testbounds.R' [2s/2s]
  Running 'testderiv.R' [2s/2s]
  Running 'testenv.R' [2s/2s]
  Running 'testparpred.R' [2s/2s]
  Running 'tmptest.R' [2s/2s]
  Running 'update.R' [2s/2s]
Running the tests in 'tests/BIC.R' failed.
Complete output:
  > require(bbmle)
  Loading required package: bbmle
  Loading required package: stats4
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > fit <- mle2(y~dpois(lambda=ymax/(1+x/xhalf)), start=list(ymax=25,xhalf=3),data=d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = ymax/(1 + x/xhalf)), start = list(ymax = 25, 
      xhalf = 3), data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = ymax/(1 + x/xhalf)), start = list(ymax = 25, 
      xhalf = 3), data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x21274b8>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/ICtab.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > set.seed(101)
  > z = rpois(100,lambda=5)
  > 
  > m1 = mle2(z~dpois(lambda=L),start=list(L=4),data=data.frame(z))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(z ~ dpois(lambda = L), start = list(L = 4), data = data.frame(z))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(z ~ dpois(lambda = L), start = list(L = 4), data = data.frame(z))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x254b670>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/binomtest1.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > funcresp <-
  + structure(list(Initial = as.integer(c(5, 5, 10, 10, 15, 15, 20, 
  + 20, 30, 30, 50, 50, 75, 75, 100, 100)), Killed = as.integer(c(1, 
  + 2, 5, 6, 10, 9, 7, 10, 11, 15, 5, 21, 32, 18, 25, 35))), .Names = c("Initial", 
  + "Killed"), class = "data.frame", row.names = c("1", "2", "3", 
  + "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", 
  + "16"))
  > 
  > binomNLL2 = function(p) {
  +   a = p[1]
  +   h = p[2]
  +   ##  cat(a,h,"\n")
  +   p = a/(1+a*h*N)
  +   -sum(dbinom(k,prob=p,size=N,log=TRUE))
  + }
  > 
  > N=0; k=0
  > parnames(binomNLL2) = c("a","h")
  > m2a = mle2(binomNLL2,start=c(a=0.5,h=0.0125),
  +       data=with(funcresp,list(N=Initial,k=Killed)))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(binomNLL2, start = c(a = 0.5, h = 0.0125), data = with(funcresp, 
      list(N = Initial, k = Killed)))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(binomNLL2, start = c(a = 0.5, h = 0.0125), data = with(funcresp, 
      list(N = Initial, k = Killed)))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x34eebe8>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/controleval.R' failed.
Complete output:
  > require(bbmle)
  Loading required package: bbmle
  Loading required package: stats4
  > mle2a <- function(...)
  +   mle2(...)
  > 
  > mle2b <- function(...)
  +   mle2a(...)
  > 
  > ## some data
  > d <- data.frame(x=0:10,y=c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8))
  > ym <- mean(d$y)
  > 
  > ## some fits
  > 
  > (fit0 <- mle2(y~dpois(lambda=ymean),start=list(ymean=ym),data=d)) # okay
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = ymean), start = list(ymean = ym), data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = ymean), start = list(ymean = ym), data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x1719560>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/eval.R' failed.
Complete output:
  > ## I am experiencing difficulties with one of my modeling function (bbmle::mle2)
  > ## which, like other modeling functions in R, uses match.call() to
  > ## retrieve and save the original function call for future use.
  > ## I'll describe the problem for bbmle and then show that I can
  > ## provoke a similar problem with lm().
  > 
  > ## ============
  > ## PART I: mle2()
  > 
  >   library(bbmle)
  Loading required package: stats4
  > 
  >   x <- 0:10
  >   y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  >   d <- data.frame(x,y)
  > 
  > ## The key is to call the modeling function from within another
  > ## function which passes additional arguments via ... 
  > 
  >   ff <- function(d,...) {
  +     mle2(y~dpois(lambda=ymean),start=list(ymean=mean(y)),data=d,...)
  +   }
  > 
  >   ff(d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = ymean), start = list(ymean = mean(y)), 
      data = d, ...)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = ymean), start = list(ymean = mean(y)), 
      data = d, ...)
  where 2: ff(d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x28c6ce8>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/formulatest.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > set.seed(1001)
  > 
  > ## test 1
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > suppressWarnings(m1 <- mle2(y~dpois(lambda=ymax/(1+x/xhalf)),
  +            parameters=list(ymax~1,xhalf~1),
  +            start=list(ymax=1,xhalf=1),data=d))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = ymax/(1 + x/xhalf)), parameters = list(ymax ~ 
      1, xhalf ~ 1), start = list(ymax = 1, xhalf = 1), data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = ymax/(1 + x/xhalf)), parameters = list(ymax ~ 
      1, xhalf ~ 1), start = list(ymax = 1, xhalf = 1), data = d)
  where 2: withCallingHandlers(expr, warning = function(w) invokeRestart("muffleWarning"))
  where 3: suppressWarnings(m1 <- mle2(y ~ dpois(lambda = ymax/(1 + x/xhalf)), 
      parameters = list(ymax ~ 1, xhalf ~ 1), start = list(ymax = 1, 
          xhalf = 1), data = d))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x1e41f20>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/glmcomp.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > library(testthat)
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > LL <- function(ymax=15, xhalf=6)
  +     -sum(stats::dpois(y, lambda=ymax/(1+x/xhalf), log=TRUE))
  > mfit0 <- mle2(y~dpois(lambda=exp(interc)),
  +               start=list(interc=log(mean(y))),data=d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = exp(interc)), start = list(interc = log(mean(y))), 
      data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = exp(interc)), start = list(interc = log(mean(y))), 
      data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x24159f0>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/gradient_vecpar_profile.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > ## Simulate data
  > 
  > set.seed(1)
  > x <- 1:5
  > y <- 2*x+1
  > noise <- rnorm(5, 0, 0.1)
  > mydata <- data.frame(x = x, y=y+noise)
  > 
  > ## Model definition
  > 
  > model <- function(a, b) with(mydata, a*x+b)
  > 
  > ## Negative log-likelihood
  > 
  > nll <- function(par) with(mydata, {
  +   a <- par[1]
  +   b <- par[2]
  +   sum(0.5*((y-model(a,b))/0.1)^2)
  +   
  + })
  > 
  > gr <- function(par) with(mydata, {
  +   a <- par[1]
  +   b <- par[2]
  +   dnllda <- -sum(((y-model(a,b))/0.1)*x/0.1)
  +   dnlldb <- -sum(((y-model(a,b))/0.1)*1/0.1)
  +   return(c(dnllda, dnlldb))
  + })
  > 
  > ## optimization
  > 
  > parnames(nll) <- c("a", "b")
  > parnames(gr) <- c("a", "b")
  > 
  > fit <- mle2(nll, c(a = 1, b=2), gr=gr)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(nll, c(a = 1, b = 2), gr = gr)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(nll, c(a = 1, b = 2), gr = gr)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x14a5628>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/grtest1.R' failed.
Complete output:
  > ## from Eric Weese
  > library(bbmle)
  Loading required package: stats4
  > f <- function(x=2,a=1) x^2 - a
  > f.g <- function(x,a) 2*x
  > f.g2 <- function(x,a) c(2*x,0)
  > options(digits=3)
  > m1 <- mle2(f,fixed=list(a=1))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(f, fixed = list(a = 1))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(f, fixed = list(a = 1))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x21ffc40>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/methods.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > LL <- function(ymax=15, xhalf=6)
  +     -sum(stats::dpois(y, lambda=ymax/(1+x/xhalf), log=TRUE))
  > options(digits=3)
  > mfit0 <- mle2(y~dpois(lambda=exp(interc)),
  +               start=list(interc=log(mean(y))),data=d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = exp(interc)), start = list(interc = log(mean(y))), 
      data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = exp(interc)), start = list(interc = log(mean(y))), 
      data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x1648070>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/mortanal.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > ## goby data in dump format
  > 
  > x <- structure(list(indiv = structure(as.integer(c(20, 77, 79, 21, 
  + 33, 40, 11, 28, 43, 85, 56, 49, 29, 37, 57, 36, 66, 65, 19, 69, 
  + 47, 60, 23, 25, 39, 84, 12, 5, 76, 55, 32, 10, 75, 4, 78, 80, 
  + 86, 48, 54, 22, 18, 61, 41, 74, 68, 14, 53, 45, 30, 17, 62, 3, 
  + 7, 50, 34, 82, 8, 70, 38, 52, 2, 63, 81, 15, 44, 58, 13, 26, 
  + 73, 83, 59, 42, 72, 67, 35, 16, 1, 46, 27, 64, 51, 24, 71, 6, 
  + 9, 31)), .Label = c("f10al1", "f10al2", "f10al3", "f10r1", "f10r2", 
  + "f11al1", "f11al2", "f11al3", "f11al4", "f11r1", "f11r2", "f11r3", 
  + "f12al1", "f12al2", "f12al3", "f12al4", "f12al5", "f12r1", "f12r2", 
  + "f12r3", "f12r4", "f12r5", "f12r6", "f13al1", "f13r1", "f14al1", 
  + "f14al2", "f14r1", "f14r2", "f15al1", "f15al2", "f15r1", "f15r2", 
  + "f18al1", "f18al2", "f18r1", "f18r2", "f19al1", "f19r1", "f19r2", 
  + "f1al1", "f1al2", "f1r1", "f20al1", "f20al2", "f20al3", "f20r1", 
  + "f20r2", "f20r3", "f2al1", "f2al2", "f2al3", "f2al4", "f2r1", 
  + "f2r2", "f2r3", "f2r4", "f3al1", "f3al2", "f3r1", "f3r2", "f4al1", 
  + "f5al1", "f5al2", "f5r1", "f5r2", "f6al1", "f6al2", "f6r1", "f7al1", 
  + "f7al2", "f7al3", "f7al4", "f7al5", "f7r1", "f7r2", "f7r3", "f7r4", 
  + "f7r5", "f7r6", "f9al1", "f9al2", "f9al4", "f9r1", "f9r2", "f9r3"
  + ), class = "factor"), group = structure(as.integer(c(5, 5, 5, 
  + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 
  + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, 3, 3, 
  + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 
  + 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)), .Label = c("AL", 
  + "AL-Rat5th", "AL-RatOv", "R", "R-ALat5th"), class = "factor"), 
  +     lifespan = as.integer(c(391, 370, 346, 341, 334, 320, 319, 
  +     317, 314, 307, 295, 260, 30, 10, 397, 380, 364, 355, 352, 
  +     341, 340, 339, 336, 320, 314, 312, 308, 302, 296, 290, 284, 
  +     267, 263, 263, 255, 253, 242, 222, 220, 181, 64, 36, 192, 
  +     192, 189, 186, 183, 181, 180, 176, 173, 171, 170, 169, 166, 
  +     11, 247, 235, 234, 233, 232, 224, 221, 220, 215, 210, 210, 
  +     204, 202, 17, 13, 301, 300, 296, 281, 271, 253, 250, 241, 
  +     239, 232, 221, 220, 214, 33, 30))), .Names = c("indiv", "group", 
  + "lifespan"), class = "data.frame", row.names = c("1", "2", "3", 
  + "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", 
  + "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", 
  + "27", "28", "29", "30", "31", "32", "33", "34", "35", "36", "37", 
  + "38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", 
  + "49", "50", "51", "52", "53", "54", "55", "56", "57", "58", "59", 
  + "60", "61", "62", "63", "64", "65", "66", "67", "68", "69", "70", 
  + "71", "72", "73", "74", "75", "76", "77", "78", "79", "80", "81", 
  + "82", "83", "84", "85", "86"))
  > 
  > mlife <- log(mean(x$lifespan))
  > Bm0w <- mle2(lifespan~dweibull(scale=exp(llambda),shape=alpha),
  +              start=list(llambda=mlife,alpha=1),
  +              data=x)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(lifespan ~ dweibull(scale = exp(llambda), shape = alpha), 
      start = list(llambda = mlife, alpha = 1), data = x)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(lifespan ~ dweibull(scale = exp(llambda), shape = alpha), 
      start = list(llambda = mlife, alpha = 1), data = x)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x28cf7a0>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/optimize.R' failed.
Complete output:
  > ## try to reconstruct error reported by Hofert Jan Marius
  > ## (simpler version)
  > 
  > Lfun <- function(x) {
  +   (x-5)^2
  + }
  > 
  > 
  > 
  > library(bbmle)
  Loading required package: stats4
  > 
  > lb <- 6
  > ## first try with L-BFGS-B and bounds
  > m1 <- mle2(Lfun,start=list(x=7),lower=6,method="L-BFGS-B")
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(Lfun, start = list(x = 7), lower = 6, method = "L-BFGS-B")
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(Lfun, start = list(x = 7), lower = 6, method = "L-BFGS-B")
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x35205a8>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/optimizers.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > old_opts <- options(digits=3)
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > suppressWarnings(fits <- lapply(c("optim","nlm","nlminb"),
  +                mle2,
  +                minuslogl=y~dpois(lambda=ymax/(1+x/xhalf)),
  +                start=list(ymax=15,xhalf=6),data=d,
  +                method="Nelder-Mead")) ## 'method' is ignored by nlm()/nlminb()
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  FUN(X[[i]], ...)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: FUN(X[[i]], ...)
  where 2: lapply(c("optim", "nlm", "nlminb"), mle2, minuslogl = y ~ dpois(lambda = ymax/(1 + 
      x/xhalf)), start = list(ymax = 15, xhalf = 6), data = d, 
      method = "Nelder-Mead")
  where 3: withCallingHandlers(expr, warning = function(w) invokeRestart("muffleWarning"))
  where 4: suppressWarnings(fits <- lapply(c("optim", "nlm", "nlminb"), 
      mle2, minuslogl = y ~ dpois(lambda = ymax/(1 + x/xhalf)), 
      start = list(ymax = 15, xhalf = 6), data = d, method = "Nelder-Mead"))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x1cbd430>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/optimx.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > old_opt <- options(digits=3)
  > if (require(optimx)) {
  + x <- 0:10
  + y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  + d <- data.frame(x,y)
  + 
  + ## breaks, don't try this
  + ## optimx(fn=Lfn,par=c(15,6),method="Rvmmin")
  + 
  + suppressWarnings(m1 <- mle2(minuslogl=y~dpois(lambda=ymax/(1+x/xhalf)),
  +      start=list(ymax=15,xhalf=6),data=d,
  +      optimizer="optimx",
  +            method=c("BFGS","Nelder-Mead","CG")))
  + 
  + ## FIXME!! fails (although not with an error, because
  + ##  errors are caught by profiling) due to npar now
  + ## being restricted to >1 in optimx 2012.05.24 ...
  + 
  + suppressWarnings(head(as.data.frame(profile(m1))))
  + detach("package:optimx")
  + }
  Loading required package: optimx
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(minuslogl = y ~ dpois(lambda = ymax/(1 + x/xhalf)), start = list(ymax = 15, 
      xhalf = 6), data = d, optimizer = "optimx", method = c("BFGS", 
      "Nelder-Mead", "CG"))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(minuslogl = y ~ dpois(lambda = ymax/(1 + x/xhalf)), start = list(ymax = 15, 
      xhalf = 6), data = d, optimizer = "optimx", method = c("BFGS", 
      "Nelder-Mead", "CG"))
  where 2: withCallingHandlers(expr, warning = function(w) invokeRestart("muffleWarning"))
  where 3: suppressWarnings(m1 <- mle2(minuslogl = y ~ dpois(lambda = ymax/(1 + 
      x/xhalf)), start = list(ymax = 15, xhalf = 6), data = d, 
      optimizer = "optimx", method = c("BFGS", "Nelder-Mead", "CG")))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x3a02888>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/order.R' failed.
Complete output:
  > set.seed(1001)
  > x <- runif(10)
  > y <- 1000+x+rnorm(10,sd=0.1)
  > d <- data.frame(x,y)
  > 
  > library(bbmle)
  Loading required package: stats4
  > ## warning
  > m1 = mle2(y~dnorm(a+b*x,sd=exp(s)),start=list(a=900,b=1,s=log(0.1)),
  +   control=list(parscale=c(1000,1,0.1)),data=d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dnorm(a + b * x, sd = exp(s)), start = list(a = 900, 
      b = 1, s = log(0.1)), control = list(parscale = c(1000, 1, 
      0.1)), data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dnorm(a + b * x, sd = exp(s)), start = list(a = 900, 
      b = 1, s = log(0.1)), control = list(parscale = c(1000, 1, 
      0.1)), data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x26dfae0>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/parscale.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > old_opt <- options(digits=3)
  > tracelevel <- 0
  > 
  > ## source("~/lib/R/pkgs/bbmle/pkg/R/mle.R
  > 
  > set.seed(1002)
  > X <- rexp(1000, rate = 0.0001)
  > f <- function(X, rate) {
  +   if (tracelevel>0 && rate<0) cat("rate<0: ",rate,"\n")
  +   -sum(dexp(X, rate = rate, log = TRUE))
  + }
  > if (FALSE) {
  +   ## L-BFGS-B violates bounds, and gets stuck at lower bound
  +   m <- mle2(minuslogl = f,
  +             data = list(X = X),
  +             start = list(rate = 0.01),
  +             method = "L-BFGS-B",
  +             control = list(trace = tracelevel, 
  +                            parscale = 1e-4),
  +             lower = c(rate = 1e-9))
  + 
  +   profile(m, std.err=0.0001) ## finds new optimum
  + 
  +   fsc <- function(X, rate) {
  +     -sum(dexp(X, rate = rate*1e-4, log = TRUE))
  +   }
  +   msc <- mle2(minuslogl = fsc,
  +             data = list(X = X),
  +             start = list(rate = 100),
  +             method = "L-BFGS-B",
  +             control = list(trace = tracelevel),
  +             lower = c(rate = 1e-5))
  + 
  +   ## does it work if we scale by hand?
  +   ##   no, identical problem
  + }
  > 
  > ## works fine with a better starting point
  > m <- mle2(minuslogl = f,
  +           data = list(X = X),
  +           start = list(rate = 0.001),
  +           method = "L-BFGS-B",
  +           control = list(trace = tracelevel,
  +                          parscale=1e-4),
  +               lower = c(rate = 1e-9))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(minuslogl = f, data = list(X = X), start = list(rate = 0.001), 
      method = "L-BFGS-B", control = list(trace = tracelevel, parscale = 1e-04), 
      lower = c(rate = 1e-09))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(minuslogl = f, data = list(X = X), start = list(rate = 0.001), 
      method = "L-BFGS-B", control = list(trace = tracelevel, parscale = 1e-04), 
      lower = c(rate = 1e-09))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x2e7edb8>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/predict.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > set.seed(1002)
  > lymax <- c(0,2)
  > lhalf <- 0
  > x <- runif(200)
  > g <- factor(rep(c("a","b"),each=100))
  > y <- rnbinom(200,mu=exp(lymax[g])/(1+x/exp(lhalf)),size=2)
  > d <- data.frame(x,g,y)
  > 
  > fit3 <- mle2(y~dnbinom(mu=exp(lymax)/(1+x/exp(lhalf)),size=exp(logk)),
  +     parameters=list(lymax~g),
  +     start=list(lymax=0,lhalf=0,logk=0),data=d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dnbinom(mu = exp(lymax)/(1 + x/exp(lhalf)), size = exp(logk)), 
      parameters = list(lymax ~ g), start = list(lymax = 0, lhalf = 0, 
          logk = 0), data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dnbinom(mu = exp(lymax)/(1 + x/exp(lhalf)), size = exp(logk)), 
      parameters = list(lymax ~ g), start = list(lymax = 0, lhalf = 0, 
          logk = 0), data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x317fb70>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/prof_newmin.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > 
  > ## uses default parameters of LL
  > fit <- mle2(y~dpois(exp(loglam)),
  +             data=d,
  +            start=list(loglam=0),control=list(maxit=2))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(exp(loglam)), data = d, start = list(loglam = 0), 
      control = list(maxit = 2))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(exp(loglam)), data = d, start = list(loglam = 0), 
      control = list(maxit = 2))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x139f148>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/prof_spec.R' failed.
Complete output:
  > ## test whether profiling works when custom optimizer is defined
  > ##  inside a function (GH #7)
  > 
  > library(bbmle)
  Loading required package: stats4
  > test <- function(t, X) {
  +   likfun <- function(p) {
  +     mu <- with(as.list(p), {
  +       exp(a+b*t)
  +     })
  +     -sum(dpois(X, mu, log=TRUE))
  +   }
  +   parnames(likfun) <- c("a", "b")
  +   
  +   optimfun <- function(par, fn, gr = NULL, ...,
  +                        method = NULL, lower = -Inf, upper = Inf,
  +                        control = NULL, hessian = FALSE) {
  +     ## cat("using custom optimfun!\n")
  +     optim(par, fn=fn, gr=gr, ...,
  +           method="BFGS", control=control, hessian=TRUE)
  +   }
  +   
  +   mle2(likfun, start=c(a=1,b=1), optimizer="user", optimfun=optimfun)
  + }
  > 
  > f <- test(0:5, round(exp(1:6)))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(likfun, start = c(a = 1, b = 1), optimizer = "user", optimfun = optimfun)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(likfun, start = c(a = 1, b = 1), optimizer = "user", optimfun = optimfun)
  where 2: test(0:5, round(exp(1:6)))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x20b4e28>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/profbound.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > old_opt <- options(digits=3)
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > 
  > fit0 <- mle2(y~dpois(lambda=ymean),start=list(ymean=mean(y)),data=d,
  +              method="L-BFGS-B",lower=10)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = ymean), start = list(ymean = mean(y)), 
      data = d, method = "L-BFGS-B", lower = 10)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = ymean), start = list(ymean = mean(y)), 
      data = d, method = "L-BFGS-B", lower = 10)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x165ad20>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/richards.R' failed.
Complete output:
  > ## implement richards-incidence (="revised superlogistic")
  > ##  with analytic gradients
  > 
  > ## from Junling's code:
  > model_richardson <- function(times, theta, N)
  + {	
  + 	x0 = theta[1]
  + 	lambda = theta[2]
  + 	K = theta[3] * N
  + 	alpha = theta[4]
  + 	return(K/(1+((K/x0)^alpha-1)*exp(-lambda*alpha*times))^(1/alpha))
  + }
  > 
  > ## equivalent model, in terms of sigma and as a symbolic expression
  > Rcum <- expression((sigma*N)/(1+(((sigma*N)/x0)^alpha-1)*exp(-lambda*alpha*times))^(1/alpha))
  > 
  > pnames <- c("x0","lambda","sigma","alpha")
  > 
  > ## function to compute gradient (and value), derived by R
  > Rderiv <- deriv(Rcum,pnames, function.arg=c(pnames,"N","times"))
  > 
  > ## equivalent (using Rcum): return incidence (incid=TRUE) or cumulative incidence (incid=FALSE)
  > calc_mean <- function(p,times,N,incid=TRUE) {
  +   ## this is more 'magic' than I would like it to be ...
  +   ##  have to create an environment and populate it with the contents of p (and N and times),
  +   ##  then evaluate the expression in this environment
  +   pp <- c(as.list(p),list(times=times,N=N))
  +   ##  e0 <- new.env()
  +   ## mapply(assign,names(pp),pp,MoreArgs=list(envir=e0))
  +   cumvals <- eval(Rcum,envir=pp)
  +   if (incid) diff(cumvals) else cumvals
  + }
  > 
  > ## Poisson likelihood function
  > likfun <- function(p,dat,times,N,incid=TRUE) {
  +   -sum(dpois(dat,calc_mean(p,times,N,incid=incid),log=TRUE))
  + }
  > 
  > ## deriv of P(x,lambda) = -sum(dpois(x,lambda,log=TRUE)) wrt lambda == sum(1-lambda/x) = N - lambda/(sum(x))
  > ## deriv of P(x,lambda) wrt p = dP/d(lambda) * d(lambda)/dp
  > 
  > ## compute gradient vector
  > gradlikfun <- function(p,dat,times,N,incid=TRUE) {
  +   gcall <- do.call(Rderiv,c(as.list(p),list(times=times,N=N))) ## values + gradient matrix
  +   lambda <- gcall
  +   attr(lambda,"gradient") <- NULL
  +   if (incid) lambda <- diff(lambda)
  +   gmat <- attr(gcall,"gradient") ## extract gradient
  +   if (incid) gmat <- apply(gmat,2,diff)  ## differences
  +   totderiv <- sweep(gmat,MARGIN=1,(1-dat/lambda),"*") ## apply chain rule (multiply columns of gmat by dP/dlambda)
  +   colSums(totderiv)  ## deriv of summed likelihood = sum of derivs of likelihod
  + }
  > 
  > N <- 1000
  > p0 <- c(x0=0.1,lambda=1,sigma=0.5,alpha=0.5)
  > t0 <- 1:10
  > ## deterministic versions of data  (cumulative and incidence)
  > dcdat <- model_richardson(t0,p0,N)
  > ddat <- diff(dcdat)
  > 
  > plot(t0,dcdat)
  > plot(t0[-1],ddat)
  > 
  > set.seed(1001)
  > ddat <- rpois(length(ddat),ddat)
  > 
  > likfun(p0,ddat,t0,N)
  [1] 22.3544
  > gradlikfun(p0,ddat,t0,N)
        x0   lambda    sigma    alpha 
  15.42028 30.95135 19.33690 30.04404 
  > 
  > library(numDeriv)
  > grad(likfun,p0,dat=ddat,times=t0,N=N)  ## finite differences
  [1] 15.42028 30.95135 19.33690 30.04404
  > ## matches!
  > 
  > library(bbmle)
  Loading required package: stats4
  > parnames(likfun) <- names(p0)
  > 
  > 
  > m1 <- mle2(likfun,start=p0,gr=gradlikfun,data=list(times=t0,N=N,dat=ddat),
  +            vecpar=TRUE)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(likfun, start = p0, gr = gradlikfun, data = list(times = t0, 
      N = N, dat = ddat), vecpar = TRUE)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(likfun, start = p0, gr = gradlikfun, data = list(times = t0, 
      N = N, dat = ddat), vecpar = TRUE)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x43e6800>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/startvals.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > ## copied from emdbook
  > dbetabinom <- function (x, prob, size, theta, shape1, shape2, log = FALSE) 
  + {
  +     if (missing(prob) && !missing(shape1) && !missing(shape2)) {
  +         prob = shape1/(shape1 + shape2)
  +         theta = shape1 + shape2
  +     }
  +     v <- lchoose(size, x) - lbeta(theta * (1 - prob), theta * 
  +         prob) + lbeta(size - x + theta * (1 - prob), x + theta * 
  +         prob)
  +     if (log) 
  +         v
  +     else exp(v)
  + }
  > 
  > ss <- data.frame(taken=c(0,1,2,5),available=c(5,5,5,5),
  +                  dist=rep(1,4))
  > 
  > SP.bb=mle2(taken~dbetabinom(prob,theta,size=available),
  +   start=list(prob=0.5,theta=1),data=ss)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(taken ~ dbetabinom(prob, theta, size = available), start = list(prob = 0.5, 
      theta = 1), data = ss)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(taken ~ dbetabinom(prob, theta, size = available), start = list(prob = 0.5, 
      theta = 1), data = ss)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x1b7d7b0>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/startvals2.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > ## fir data from emdbook package ...
  > firdata <- structure(list(TOTCONES = c(19, 42, 40, 68, 5, 0, 21, 114, 37, 
  + 92, 84, 102, 98, 63, 9, 31, 35, 216, 27, 297, 36, 127, 23, 46, 
  + 27, 66, 11, 20, 141, 3, 22, 39, 96, 206.5, 40, 231, 63.5, 202, 
  + 54, 32, 107.5, 142.5, 82, 65, 153, 123, 131, 43, 98, 37, 34, 
  + 10, 65, 35, 50, 19, 73, 33, 61, 9, 146, 0, 44, 42, 0, 61, 17, 
  + 53, 27, 0, 74, 36, 28, 56, 46, 0, 15, 26, 46, 15, 105, 0, 62, 
  + 24, 25, 41, 138, 77, 227.7, 28, 45, 57, 109, 28, 17, 91, 69, 
  + 87, 10, 65, 50, 27, 30, 86, 119, 22, 8, 54, 104, 14, 16, 5, 53, 
  + 40, 32, 114, 39, 37, 111, 226, 156, 42, 86, 94, 54, 1, 14, 44, 
  + 108, 116.5, 14, 73, 3, 16, 87, 61, 48, 0, 17, 5, 88, 11, 133, 
  + 121, 166, 171, 63, 23, 4, 51, 10, 14, 78, 47, 31, 42, 24, 42, 
  + 55, 19, 63, 127, 9, 74, 120, 85, 51, 19, 131, 7, 23, 7, 9, 23, 
  + 55, 48, 13, 2, 9, 3, 4, 16, 1, 88, 8, 27, 16, 184, 14, 22, 25, 
  + 52, 2, 134, 81, 85, 3, 56, 17, 8, 10, 6, 69, 58, 1, 22, 3, 11, 
  + 22, 2, 37, 8, 15, 61, 6, 18, 9, 109, 54, 4, 11, 30, 0, 0, 3, 
  + 0, 16, 22, 9, 56, 17, 64, 38, 59, 37, 22, 41, 1, 22, 16, 17, 
  + 4), DBH = c(9.4, 10.6, 7.7, 10.6, 8.7, 10.1, 8.1, 11.6, 10.1, 
  + 13.3, 10, 13.4, 9.7, 7.4, 8.7, 8.6, 7.9, 14.2, 9.5, 15.9, 6, 
  + 10.6, 7.3, 10.3, 8.4, 10.2, 13.8, 9.4, 8.1, 9.6, 7.3, 7.4, 10.3, 
  + 13.4, 9.2, 13.9, 10.9, 17.4, 10.2, 8.2, 11.3, 16.1, 12.3, 8.3, 
  + 12.4, 12.5, 11.3, 7.8, 11.6, 10, 7, 5.7, 7.7, 8.9, 8.5, 8.5, 
  + 10.7, 10.2, 10.8, 9, 9.4, 7.6, 10.6, 10, 8, 7.4, 9.1, 6.7, 9.7, 
  + 6.8, 8.6, 9.1, 6.3, 6.7, 10.9, 9.5, 9.9, 6.8, 9.8, 7.7, 12.1, 
  + 8.2, 10, 9.6, 9.2, 8.2, 11.3, 11.6, 15.7, 9.1, 8.9, 8.7, 11, 
  + 6.6, 7.1, 9, 12.4, 12.1, 7.5, 9, 8, 10.9, 9.2, 10.1, 12.1, 7, 
  + 6.8, 8.6, 11.6, 6.6, 6.7, 6.8, 8.5, 7.8, 7.9, 9.8, 6.2, 6.7, 
  + 15.4, 9.2, 12.9, 6.7, 9.6, 8.4, 8, 8.7, 6.7, 9.2, 9.5, 8, 5.5, 
  + 8.5, 5.7, 5.6, 8, 6.5, 9.6, 6.1, 7.9, 5.9, 11, 8.2, 12.8, 12.8, 
  + 12.5, 13.7, 11.8, 6.3, 6.3, 8.2, 6.2, 6.7, 9.8, 9.4, 6.7, 6, 
  + 4.9, 9.6, 7.5, 8.4, 7.4, 9.9, 7.4, 9.5, 13.9, 6.9, 9.4, 7.4, 
  + 12.8, 5.8, 7.2, 5.6, 6.9, 11.3, 9.6, 6.8, 6.9, 6.6, 4.8, 4.4, 
  + 4.8, 8.5, 7, 8.7, 6.6, 8.6, 5.3, 10.4, 6.4, 5.4, 8.2, 5.5, 6.2, 
  + 14.7, 10.5, 14.4, 5.8, 6.1, 6.2, 6.2, 7.2, 6, 10.6, 8.7, 7.5, 
  + 7.3, 5.2, 6.9, 6.6, 6.7, 5.2, 6.9, 7.5, 9, 5.9, 6.5, 6.6, 9.8, 
  + 4.7, 4.2, 4.8, 6.7, 6.5, 6.7, 5.9, 5.4, 6.9, 6.5, 6, 12, 7.5, 
  + 6.4, 7.3, 7.3, 6.4, 7, 5.9, 9.1, 6.7, 4, 6.5, 4.7), WAVE_NON = structure(c(1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
  + 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
  + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
  + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
  + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
  + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
  + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
  + 2L), .Label = c("n", "w"), class = "factor"), logcones = c(2.99573227355399, 
  + 3.76120011569356, 3.71357206670431, 4.23410650459726, 1.79175946922805, 
  + 0, 3.09104245335832, 4.74493212836325, 3.63758615972639, 4.53259949315326, 
  + 4.44265125649032, 4.63472898822964, 4.59511985013459, 4.15888308335967, 
  + 2.30258509299405, 3.46573590279973, 3.58351893845611, 5.37989735354046, 
  + 3.3322045101752, 5.6970934865054, 3.61091791264422, 4.85203026391962, 
  + 3.17805383034795, 3.85014760171006, 3.3322045101752, 4.20469261939097, 
  + 2.484906649788, 3.04452243772342, 4.95582705760126, 1.38629436111989, 
  + 3.13549421592915, 3.68887945411394, 4.57471097850338, 5.33513133967075, 
  + 3.71357206670431, 5.44673737166631, 4.16666522380173, 5.31320597904179, 
  + 4.00733318523247, 3.49650756146648, 4.68675017298051, 4.96633503519968, 
  + 4.4188406077966, 4.18965474202643, 5.03695260241363, 4.82028156560504, 
  + 4.88280192258637, 3.78418963391826, 4.59511985013459, 3.63758615972639, 
  + 3.55534806148941, 2.39789527279837, 4.18965474202643, 3.58351893845611, 
  + 3.93182563272433, 2.99573227355399, 4.30406509320417, 3.52636052461616, 
  + 4.12713438504509, 2.30258509299405, 4.99043258677874, 0, 3.80666248977032, 
  + 3.76120011569356, 0, 4.12713438504509, 2.89037175789616, 3.98898404656427, 
  + 3.3322045101752, 0, 4.31748811353631, 3.61091791264422, 3.36729582998647, 
  + 4.04305126783455, 3.85014760171006, 0, 2.77258872223978, 3.29583686600433, 
  + 3.85014760171006, 2.77258872223978, 4.66343909411207, 0, 4.14313472639153, 
  + 3.2188758248682, 3.25809653802148, 3.73766961828337, 4.93447393313069, 
  + 4.35670882668959, 5.43241110102874, 3.36729582998647, 3.8286413964891, 
  + 4.06044301054642, 4.70048036579242, 3.36729582998647, 2.89037175789616, 
  + 4.52178857704904, 4.24849524204936, 4.47733681447821, 2.39789527279837, 
  + 4.18965474202643, 3.93182563272433, 3.3322045101752, 3.43398720448515, 
  + 4.46590811865458, 4.78749174278205, 3.13549421592915, 2.19722457733622, 
  + 4.00733318523247, 4.65396035015752, 2.70805020110221, 2.83321334405622, 
  + 1.79175946922805, 3.98898404656427, 3.71357206670431, 3.49650756146648, 
  + 4.74493212836325, 3.68887945411394, 3.63758615972639, 4.71849887129509, 
  + 5.4249500174814, 5.05624580534831, 3.76120011569356, 4.46590811865458, 
  + 4.55387689160054, 4.00733318523247, 0.693147180559945, 2.70805020110221, 
  + 3.80666248977032, 4.69134788222914, 4.76643833358421, 2.70805020110221, 
  + 4.30406509320417, 1.38629436111989, 2.83321334405622, 4.47733681447821, 
  + 4.12713438504509, 3.89182029811063, 0, 2.89037175789616, 1.79175946922805, 
  + 4.48863636973214, 2.484906649788, 4.89783979995091, 4.80402104473326, 
  + 5.11799381241676, 5.14749447681345, 4.15888308335967, 3.17805383034795, 
  + 1.6094379124341, 3.95124371858143, 2.39789527279837, 2.70805020110221, 
  + 4.36944785246702, 3.87120101090789, 3.46573590279973, 3.76120011569356, 
  + 3.2188758248682, 3.76120011569356, 4.02535169073515, 2.99573227355399, 
  + 4.15888308335967, 4.85203026391962, 2.30258509299405, 4.31748811353631, 
  + 4.79579054559674, 4.45434729625351, 3.95124371858143, 2.99573227355399, 
  + 4.88280192258637, 2.07944154167984, 3.17805383034795, 2.07944154167984, 
  + 2.30258509299405, 3.17805383034795, 4.02535169073515, 3.89182029811063, 
  + 2.63905732961526, 1.09861228866811, 2.30258509299405, 1.38629436111989, 
  + 1.6094379124341, 2.83321334405622, 0.693147180559945, 4.48863636973214, 
  + 2.19722457733622, 3.3322045101752, 2.83321334405622, 5.22035582507832, 
  + 2.70805020110221, 3.13549421592915, 3.25809653802148, 3.97029191355212, 
  + 1.09861228866811, 4.90527477843843, 4.40671924726425, 4.45434729625351, 
  + 1.38629436111989, 4.04305126783455, 2.89037175789616, 2.19722457733622, 
  + 2.39789527279837, 1.94591014905531, 4.24849524204936, 4.07753744390572, 
  + 0.693147180559945, 3.13549421592915, 1.38629436111989, 2.484906649788, 
  + 3.13549421592915, 1.09861228866811, 3.63758615972639, 2.19722457733622, 
  + 2.77258872223978, 4.12713438504509, 1.94591014905531, 2.94443897916644, 
  + 2.30258509299405, 4.70048036579242, 4.00733318523247, 1.6094379124341, 
  + 2.484906649788, 3.43398720448515, 0, 0, 1.38629436111989, 0, 
  + 2.83321334405622, 3.13549421592915, 2.30258509299405, 4.04305126783455, 
  + 2.89037175789616, 4.17438726989564, 3.66356164612965, 4.0943445622221, 
  + 3.63758615972639, 3.13549421592915, 3.73766961828337, 0.693147180559945, 
  + 3.13549421592915, 2.83321334405622, 2.89037175789616, 1.6094379124341
  + )), .Names = c("TOTCONES", "DBH", "WAVE_NON", "logcones"), row.names = c(1L, 
  + 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 13L, 14L, 15L, 
  + 16L, 17L, 18L, 19L, 20L, 21L, 22L, 23L, 24L, 25L, 26L, 27L, 28L, 
  + 29L, 30L, 31L, 32L, 33L, 35L, 36L, 37L, 38L, 39L, 40L, 41L, 42L, 
  + 43L, 44L, 45L, 46L, 47L, 48L, 49L, 50L, 51L, 52L, 53L, 54L, 55L, 
  + 56L, 58L, 59L, 60L, 61L, 62L, 63L, 64L, 65L, 66L, 67L, 68L, 69L, 
  + 70L, 71L, 72L, 73L, 74L, 75L, 76L, 78L, 79L, 80L, 81L, 82L, 83L, 
  + 84L, 85L, 86L, 87L, 88L, 89L, 90L, 91L, 92L, 93L, 94L, 95L, 96L, 
  + 97L, 98L, 99L, 100L, 101L, 102L, 103L, 104L, 105L, 106L, 107L, 
  + 108L, 109L, 110L, 111L, 112L, 113L, 118L, 119L, 120L, 121L, 122L, 
  + 123L, 124L, 126L, 127L, 128L, 129L, 130L, 131L, 132L, 133L, 134L, 
  + 135L, 136L, 137L, 138L, 139L, 140L, 142L, 144L, 145L, 146L, 147L, 
  + 148L, 149L, 150L, 151L, 154L, 155L, 157L, 159L, 160L, 168L, 169L, 
  + 170L, 171L, 172L, 173L, 174L, 175L, 176L, 177L, 178L, 179L, 180L, 
  + 181L, 184L, 185L, 186L, 187L, 189L, 190L, 193L, 198L, 247L, 272L, 
  + 273L, 275L, 276L, 277L, 278L, 280L, 281L, 282L, 283L, 284L, 285L, 
  + 286L, 287L, 288L, 289L, 290L, 291L, 292L, 293L, 294L, 295L, 296L, 
  + 297L, 298L, 299L, 300L, 301L, 303L, 304L, 305L, 306L, 307L, 308L, 
  + 309L, 310L, 311L, 313L, 314L, 315L, 316L, 319L, 320L, 321L, 322L, 
  + 323L, 325L, 326L, 327L, 330L, 331L, 332L, 337L, 338L, 339L, 340L, 
  + 341L, 342L, 343L, 344L, 345L, 346L, 347L, 348L, 349L, 350L, 351L, 
  + 352L, 353L, 357L, 358L, 360L, 366L), na.action = structure(c(34L, 
  + 57L, 77L, 114L, 115L, 116L, 117L, 125L, 141L, 143L, 152L, 153L, 
  + 156L, 158L, 161L, 162L, 163L, 164L, 165L, 166L, 167L, 182L, 183L, 
  + 188L, 191L, 192L, 194L, 195L, 196L, 197L, 199L, 200L, 201L, 202L, 
  + 203L, 204L, 205L, 206L, 207L, 208L, 209L, 210L, 211L, 212L, 213L, 
  + 214L, 215L, 216L, 217L, 218L, 219L, 220L, 221L, 222L, 223L, 224L, 
  + 225L, 226L, 227L, 228L, 229L, 230L, 231L, 232L, 233L, 234L, 235L, 
  + 236L, 237L, 238L, 239L, 240L, 241L, 242L, 243L, 244L, 245L, 246L, 
  + 248L, 249L, 250L, 251L, 252L, 253L, 254L, 255L, 256L, 257L, 258L, 
  + 259L, 260L, 261L, 262L, 263L, 264L, 265L, 266L, 267L, 268L, 269L, 
  + 270L, 271L, 274L, 279L, 302L, 312L, 317L, 318L, 324L, 328L, 329L, 
  + 333L, 334L, 335L, 336L, 354L, 355L, 356L, 359L, 361L, 362L, 363L, 
  + 364L, 365L, 367L, 368L, 369L, 370L, 371L), .Names = c("34", "57", 
  + "77", "114", "115", "116", "117", "125", "141", "143", "152", 
  + "153", "156", "158", "161", "162", "163", "164", "165", "166", 
  + "167", "182", "183", "188", "191", "192", "194", "195", "196", 
  + "197", "199", "200", "201", "202", "203", "204", "205", "206", 
  + "207", "208", "209", "210", "211", "212", "213", "214", "215", 
  + "216", "217", "218", "219", "220", "221", "222", "223", "224", 
  + "225", "226", "227", "228", "229", "230", "231", "232", "233", 
  + "234", "235", "236", "237", "238", "239", "240", "241", "242", 
  + "243", "244", "245", "246", "248", "249", "250", "251", "252", 
  + "253", "254", "255", "256", "257", "258", "259", "260", "261", 
  + "262", "263", "264", "265", "266", "267", "268", "269", "270", 
  + "271", "274", "279", "302", "312", "317", "318", "324", "328", 
  + "329", "333", "334", "335", "336", "354", "355", "356", "359", 
  + "361", "362", "363", "364", "365", "367", "368", "369", "370", 
  + "371"), class = "omit"), class = "data.frame")
  > 
  > 
  > m1 <- mle2(logcones ~ dnorm(i + slope*log(DBH), sd),
  +            parameters= list(i ~ WAVE_NON-1, slope ~ WAVE_NON-1),
  +            data = firdata,
  +            start = list(i=c(-2,-2),slope=c(2.5,2.5),sd=1))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(logcones ~ dnorm(i + slope * log(DBH), sd), parameters = list(i ~ 
      WAVE_NON - 1, slope ~ WAVE_NON - 1), data = firdata, start = list(i = c(-2, 
      -2), slope = c(2.5, 2.5), sd = 1))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(logcones ~ dnorm(i + slope * log(DBH), sd), parameters = list(i ~ 
      WAVE_NON - 1, slope ~ WAVE_NON - 1), data = firdata, start = list(i = c(-2, 
      -2), slope = c(2.5, 2.5), sd = 1))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x23aae68>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/test-relist1.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > set.seed(1001)
  > f <- factor(rep(1:3,each=50))
  > kvals <- c(1,2,5)
  > muvals <- c(10,2,5)
  > y <- rnbinom(length(f),size=kvals[f],mu=muvals[f])
  > plot(y)
  > 
  > NLL <- function(p) {
  +   kvals <- p[1:3]
  +   muvals <- p[4:6]
  +   -sum(dnbinom(y,size=kvals[f],mu=muvals[f],log=TRUE))
  + }
  > parnames(NLL) <- c("k1","k2","k3","mu1","mu2","mu3")
  > svec <- c(kvals,muvals)
  > names(svec) <- parnames(NLL)
  > m1 <- mle2(NLL,start=svec,vecpar=TRUE)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(NLL, start = svec, vecpar = TRUE)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(NLL, start = svec, vecpar = TRUE)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x2fa7628>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/testbounds.R' failed.
Complete output:
  > x <- runif(10)
  > y <- 1+x+rnorm(10,sd=0.1)
  > d <- data.frame(x,y)
  > 
  > library(bbmle)
  Loading required package: stats4
  > m1 <- mle2(y~dnorm(a+b*x,sd=exp(s)),start=list(a=1,b=1,s=log(0.1)),data=d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dnorm(a + b * x, sd = exp(s)), start = list(a = 1, b = 1, 
      s = log(0.1)), data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dnorm(a + b * x, sd = exp(s)), start = list(a = 1, b = 1, 
      s = log(0.1)), data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x17d3e28>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/testderiv.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > old_opt <- options(digits=3)
  > ## source("../R/dists.R")
  > ## source("../R/mle.R")
  > 
  > ## an attempt to sketch out by hand
  > ##  how one would derive an analytic
  > ##  gradient function for a formula-specified
  > ##  likelihood and use it ...
  > 
  > ## chain rule should be:
  > 
  > ## deriv(probability distribution)/[prob params] *
  > ##    deriv([prob params])/[model params] *
  > ##   {OPTIONAL} deriv([model params])/[linear model params]
  > 
  > set.seed(1001)
  > x <- rbinom(50,size=10,prob=0.4)
  > suppressWarnings(mle2(x~dbinom(prob=p,size=10),start=list(p=0.3),data=data.frame(x)))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(x ~ dbinom(prob = p, size = 10), start = list(p = 0.3), 
      data = data.frame(x))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(x ~ dbinom(prob = p, size = 10), start = list(p = 0.3), 
      data = data.frame(x))
  where 2: withCallingHandlers(expr, warning = function(w) invokeRestart("muffleWarning"))
  where 3: suppressWarnings(mle2(x ~ dbinom(prob = p, size = 10), start = list(p = 0.3), 
      data = data.frame(x)))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x2d3b608>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/testenv.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > f <- function() {
  +   maxit <- 1000
  +   d <- data.frame(x=0:10,
  +                   y=c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8))
  +   mle2(y~dpois(lambda=exp(lymax)/(1+x/exp(lhalf))),
  +    start=list(lymax=0,lhalf=0),
  +    data=d,
  +    control=list(maxit=maxit),
  +    parameters=list(lymax~1,lhalf~1))
  + }
  > 
  > f2 <- function(method="BFGS") {
  +     d <- data.frame(x=0:10,
  +                     y=c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8))
  +     mle2(y~dpois(lambda=exp(lymax)/(1+x/exp(lhalf))),
  +          start=list(lymax=0,lhalf=0),
  +          data=d,
  +          method=method,
  +          parameters=list(lymax~1,lhalf~1))
  + }
  > 
  > m1 <- f()
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = exp(lymax)/(1 + x/exp(lhalf))), start = list(lymax = 0, 
      lhalf = 0), data = d, control = list(maxit = maxit), parameters = list(lymax ~ 
      1, lhalf ~ 1))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = exp(lymax)/(1 + x/exp(lhalf))), start = list(lymax = 0, 
      lhalf = 0), data = d, control = list(maxit = maxit), parameters = list(lymax ~ 
      1, lhalf ~ 1))
  where 2: f()
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x1c98030>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/testparpred.R' failed.
Complete output:
  > ## set up a data frame for prediction
  > 
  > set.seed(1001)
  > f = factor(rep(letters[1:4],each=20))
  > x = runif(80)
  > u = rnorm(4)
  > y = rnorm(80,mean=2+x*(3+u[f]),sd=0.1)
  > dat = data.frame(f,x,y)
  > 
  > ## fit a model ... could easily do by lm() but want to
  > ##   demonstrate the problem
  > 
  > library(bbmle)
  Loading required package: stats4
  > m1 = mle2(y~dnorm(a+b*x,sd=exp(logs)),parameters=list(b~f),data=dat,
  +   start=list(a=0,b=2,logs=-3))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dnorm(a + b * x, sd = exp(logs)), parameters = list(b ~ 
      f), data = dat, start = list(a = 0, b = 2, logs = -3))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dnorm(a + b * x, sd = exp(logs)), parameters = list(b ~ 
      f), data = dat, start = list(a = 0, b = 2, logs = -3))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x22180f8>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/tmptest.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > d <- data.frame(x=0:10,
  +                 y=c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8))
  > 
  > maxit <- 1000
  > mle2(y~dpois(lambda=exp(lymax)/(1+x/exp(lhalf))),
  +    start=list(lymax=0,lhalf=0),
  +    data=d,
  +      control=list(maxit=maxit),
  +    parameters=list(lymax~1,lhalf~1))
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = exp(lymax)/(1 + x/exp(lhalf))), start = list(lymax = 0, 
      lhalf = 0), data = d, control = list(maxit = maxit), parameters = list(lymax ~ 
      1, lhalf ~ 1))
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = exp(lymax)/(1 + x/exp(lhalf))), start = list(lymax = 0, 
      lhalf = 0), data = d, control = list(maxit = maxit), parameters = list(lymax ~ 
      1, lhalf ~ 1))
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x1f74d98>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1
Running the tests in 'tests/update.R' failed.
Complete output:
  > library(bbmle)
  Loading required package: stats4
  > 
  > x <- 0:10
  > y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
  > d <- data.frame(x,y)
  > oldopts <- options(warn=-1,digits=3)  ## ignore warnings
  > m1 <- mle2(y~dpois(lambda=ymax/(1+x/xhalf)),
  +            start=list(ymax=1,xhalf=1),data=d)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  bbmle
   --- call from context --- 
  mle2(y ~ dpois(lambda = ymax/(1 + x/xhalf)), start = list(ymax = 1, 
      xhalf = 1), data = d)
   --- call from argument --- 
  if (class(tmphess) == "try-error") {
      tvcov <- matrix(NA, length(coef), length(coef))
      warning("couldn't invert Hessian")
  } else tvcov <- tmphess
   --- R stacktrace ---
  where 1: mle2(y ~ dpois(lambda = ymax/(1 + x/xhalf)), start = list(ymax = 1, 
      xhalf = 1), data = d)
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (minuslogl, start, method, optimizer, fixed = NULL, 
      data = NULL, subset = NULL, default.start = TRUE, eval.only = FALSE, 
      vecpar = FALSE, parameters = NULL, parnames = NULL, skip.hessian = FALSE, 
      hessian.opts = NULL, use.ginv = TRUE, trace = FALSE, browse_obj = FALSE, 
      gr = NULL, optimfun, ...) 
  {
      if (missing(method)) 
          method <- mle2.options("optim.method")
      if (missing(optimizer)) 
          optimizer <- mle2.options("optimizer")
      L <- list(...)
      if (optimizer == "optimize" && (is.null(L$lower) || is.null(L$upper))) 
          stop("lower and upper bounds must be specified when using\n'optimize'")
      if (inherits(minuslogl, "formula")) {
          pf <- function(f) {
              if (is.null(f)) {
                  ""
              }
              else {
                  paste(f[2], "~", gsub(" ", "", as.character(f[3])), 
                    sep = "")
              }
          }
          if (missing(parameters)) {
              formula <- pf(minuslogl)
          }
          else {
              formula <- paste(pf(minuslogl), paste(sapply(parameters, 
                  pf), collapse = ", "), sep = ": ")
          }
          tmp <- calc_mle2_function(minuslogl, parameters, start = start, 
              parnames = parnames, data = data, trace = trace)
          minuslogl <- tmp$fn
          start <- tmp$start
          fdata <- tmp$fdata
          parameters <- tmp$parameters
      }
      else {
          formula <- ""
          fdata <- NULL
      }
      call <- match.call()
      call.orig <- call
      call$data <- eval.parent(call$data)
      call$upper <- eval.parent(call$upper)
      call$lower <- eval.parent(call$lower)
      call$gr <- eval.parent(call$gr)
      call$control <- eval.parent(call$control)
      call$method <- eval.parent(call$method)
      if (!missing(start)) 
          if (!is.list(start)) {
              if (is.null(names(start)) || !is.vector(start)) 
                  stop("'start' must be a named vector or named list")
              vecpar <- call$vecpar <- TRUE
              start <- as.list(start)
          }
      if (missing(start) && default.start) 
          start <- formals(minuslogl)
      if (!is.null(fixed) && !is.list(fixed)) {
          if (is.null(names(fixed)) || !is.vector(fixed)) 
              stop("'fixed' must be a named vector or named list")
          fixed <- as.list(fixed)
      }
      if (!is.null(data) && !is.list(data)) 
          stop("'data' must be a list")
      nfix <- names(unlist(namedrop(fixed)))
      if (!is.null(parnames(minuslogl))) {
          nfull <- parnames(minuslogl)
          fullcoef <- vector("list", length(nfull))
          names(fullcoef) <- nfull
      }
      else {
          fullcoef <- formals(minuslogl)
          nfull <- names(fullcoef)
      }
      if (any(!nfix %in% nfull)) 
          stop("some named arguments in 'fixed' are not arguments to the specified log-likelihood function")
      if (length(nfix) > 0) 
          start[nfix] <- NULL
      fullcoef[nfix] <- fixed
      nstart <- names(unlist(sapply(namedrop(start), eval.parent)))
      fullcoef[!nfull %in% nfix & !nfull %in% nstart] <- NULL
      nfull <- names(fullcoef)
      lc <- length(call$lower)
      lu <- length(call$upper)
      npnfix <- sum(!nfull %in% nfix)
      if (!npnfix == 0 && (lu > npnfix || lc > npnfix)) {
          warning("length mismatch between lower/upper ", "and number of non-fixed parameters: ", 
              "# lower=", lc, ", # upper=", lu, ", # non-fixed=", 
              npnfix)
      }
      template <- lapply(start, eval.parent)
      if (vecpar) 
          template <- unlist(template)
      start <- sapply(namedrop(start), eval.parent)
      nstart <- names(unlist(namedrop(start)))
      oo <- match(nstart, names(fullcoef))
      if (any(is.na(oo))) 
          stop("some named arguments in 'start' are not arguments to the specified log-likelihood function")
      start <- start[order(oo)]
      fix_order <- function(c1, name, default = NULL) {
          if (!is.null(c1)) {
              if (length(unique(c1)) > 1) {
                  if (is.null(names(c1)) && length(unique(c1)) > 
                    1) {
                    warning(name, " not named: rearranging to match 'start'")
                    oo2 <- oo
                  }
                  else oo2 <- match(names(unlist(namedrop(c1))), 
                    names(fullcoef))
                  c1 <- c1[order(oo2)]
              }
          }
          else c1 <- default
          c1
      }
      call$lower <- fix_order(call$lower, "lower bounds", -Inf)
      call$upper <- fix_order(call$upper, "upper bounds", Inf)
      call$control$parscale <- fix_order(call$control$parscale, 
          "parscale")
      call$control$ndeps <- fix_order(call$control$ndeps, "ndeps")
      if (is.null(call$control)) 
          call$control <- list()
      denv <- local(environment(), c(as.list(data), fdata, list(mleenvset = TRUE)))
      argnames.in.data <- names(data)[names(data) %in% names(formals(minuslogl))]
      args.in.data <- lapply(argnames.in.data, get, env = denv)
      names(args.in.data) <- argnames.in.data
      args.in.data
      objectivefunction <- function(p) {
          if (browse_obj) 
              browser()
          l <- relist2(p, template)
          names(p) <- nstart[order(oo)]
          l[nfix] <- fixed
          if (vecpar) {
              l <- namedrop(l[nfull])
              l <- unlist(l)
              args <- list(l)
              args <- c(list(l), args.in.data)
          }
          else {
              args <- c(l, args.in.data)
          }
          do.call("minuslogl", namedrop(args))
      }
      objectivefunctiongr <- if (!is.null(gr)) 
          function(p) {
              if (browse_obj) 
                  browser()
              l <- relist2(p, template)
              names(p) <- nstart[order(oo)]
              l[nfix] <- fixed
              if (vecpar) {
                  l <- namedrop(l[nfull])
                  l <- unlist(l)
                  args <- list(l)
                  args <- c(list(l), args.in.data)
              }
              else {
                  args <- c(l, args.in.data)
              }
              v <- do.call("gr", args)
              if (is.null(names(v))) {
                  if (length(v) == length(l) && !is.null(tt <- names(l))) {
                    vnames <- tt
                  }
                  else if (length(v) == length(p) && !is.null(tt <- names(p))) {
                    vnames <- tt
                  }
                  else if (!is.null(tt <- parnames(minuslogl))) {
                    vnames <- tt
                  }
                  else vnames <- names(formals(minuslogl))
                  if (length(vnames) != length(v)) 
                    stop("name/length mismatch in gradient function")
                  names(v) <- vnames
              }
              return(v[!names(v) %in% nfix])
          }
      if (!("mleenvset" %in% ls(envir = environment(minuslogl)))) {
          newenv <- new.env(hash = TRUE, parent = environment(minuslogl))
          d <- as.list(denv)
          mapply(assign, names(d), d, MoreArgs = list(envir = newenv))
          environment(minuslogl) <- newenv
          if (!is.null(gr)) {
              newenvgr <- new.env(hash = TRUE, parent = environment(minuslogl))
              mapply(assign, names(d), d, MoreArgs = list(envir = newenvgr))
              environment(gr) <- newenvgr
          }
      }
      if (length(start) == 0 || eval.only) {
          if (length(start) == 0) 
              start <- numeric(0)
          optimizer <- "none"
          skip.hessian <- TRUE
          oout <- list(par = start, value = objectivefunction(start), 
              hessian = matrix(NA, nrow = length(start), ncol = length(start)), 
              convergence = 0)
      }
      else {
          oout <- switch(optimizer, optim = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optim", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, optimx = {
              arglist <- list(...)
              arglist$lower <- arglist$upper <- arglist$control <- NULL
              do.call("optimx", c(list(par = start, fn = objectivefunction, 
                  method = method, hessian = FALSE, gr = objectivefunctiongr, 
                  control = call$control, lower = call$lower, upper = call$upper), 
                  arglist))
          }, nlm = nlm(f = objectivefunction, p = start, hessian = FALSE, 
              ...), nlminb = nlminb(start = start, objective = objectivefunction, 
              hessian = NULL, ...), constrOptim = constrOptim(theta = start, 
              f = objectivefunction, method = method, ...), optimize = , 
              optimise = optimize(f = objectivefunction, interval = c(call$lower, 
                  call$upper), ...), user = {
                  arglist <- list(...)
                  arglist$lower <- arglist$upper <- arglist$control <- NULL
                  do.call(optimfun, c(list(par = start, fn = objectivefunction, 
                    method = method, hessian = FALSE, gr = objectivefunctiongr, 
                    control = call$control, lower = call$lower, 
                    upper = call$upper), arglist))
              }, stop("unknown optimizer (choices are 'optim', 'nlm', 'nlminb', 'constrOptim', 'user', and 'optimi[sz]e')"))
      }
      optimval <- switch(optimizer, optim = , constrOptim = , optimx = , 
          user = , none = "value", nlm = "minimum", optimize = , 
          optimise = , nlminb = "objective")
      if (optimizer == "optimx") {
          fvals <- oout[["value"]]
          conv <- oout[["convcode"]]
          best <- which.min(fvals)
          oout <- list(par = as.numeric(unlist(oout[best, 1:attr(oout, 
              "npar")])), value = fvals[best], convergence = conv[best], 
              method.used = attr(oout, "details")[, "method"][[best]])
      }
      if (optimizer == "nlm") {
          oout$par <- oout$estimate
          oout$convergence <- oout$code
      }
      if (optimizer %in% c("optimise", "optimize")) {
          oout$par <- oout$minimum
          oout$convergence <- 0
      }
      if (optimizer %in% c("nlminb", "optimise", "optimize") || 
          is.null(names(oout$par))) {
          names(oout$par) <- names(start)
      }
      if (length(oout$par) == 0) 
          skip.hessian <- TRUE
      if (!skip.hessian) {
          if ((!is.null(call$upper) || !is.null(call$lower)) && 
              any(oout$par == call$upper) || any(oout$par == call$lower)) 
              warning("some parameters are on the boundary: variance-covariance calculations based on Hessian may be unreliable")
      }
      namatrix <- matrix(NA, nrow = length(start), ncol = length(start))
      if (!skip.hessian) {
          psc <- call$control$parscale
          if (is.null(gr)) {
              if (is.null(psc)) {
                  oout$hessian <- try(hessian(objectivefunction, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunction(x * psc)
                  }
                  oout$hessian <- try(hessian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
          else {
              if (is.null(psc)) {
                  oout$hessian <- try(jacobian(objectivefunctiongr, 
                    oout$par, method.args = hessian.opts))
              }
              else {
                  tmpf <- function(x) {
                    objectivefunctiongr(x * psc)
                  }
                  oout$hessian <- try(jacobian(tmpf, oout$par/psc, 
                    method.args = hessian.opts))/outer(psc, psc)
              }
          }
      }
      if (skip.hessian || inherits(oout$hessian, "try-error")) 
          oout$hessian <- namatrix
      coef <- oout$par
      nc <- names(coef)
      if (skip.hessian) {
          tvcov <- matrix(NA, length(coef), length(coef))
      }
      else {
          if (length(coef)) {
              if (use.ginv) {
                  tmphess <- try(MASS::ginv(oout$hessian), silent = TRUE)
              }
              else {
                  tmphess <- try(solve(oout$hessian, silent = TRUE))
              }
              if (class(tmphess) == "try-error") {
                  tvcov <- matrix(NA, length(coef), length(coef))
                  warning("couldn't invert Hessian")
              }
              else tvcov <- tmphess
          }
          else {
              tvcov <- matrix(numeric(0), 0, 0)
          }
      }
      dimnames(tvcov) <- list(nc, nc)
      min <- oout[[optimval]]
      fullcoef[nstart[order(oo)]] <- coef
      if (length(coef)) {
          gradvec <- if (!is.null(gr)) {
              objectivefunctiongr(coef)
          }
          else {
              if (inherits(tt <- try(grad(objectivefunction, coef), 
                  silent = TRUE), "try-error")) 
                  NA
              else tt
          }
          oout$maxgrad <- max(abs(gradvec))
          if (!skip.hessian) {
              if (inherits(ev <- try(eigen(oout$hessian)$value, 
                  silent = TRUE), "try-error")) 
                  ev <- NA
              oout$eratio <- min(Re(ev))/max(Re(ev))
          }
      }
      if (!is.null(conv <- oout$conv) && ((optimizer == "nlm" && 
          conv > 2) || (optimizer != "nlm" && conv != 0))) {
          if (is.null(oout$message)) {
              cmsg <- "unknown convergence failure: refer to optimizer documentation"
              if (optimizer == "optim") {
                  if (conv == 1) 
                    cmsg <- "iteration limit 'maxit' reached"
                  if (conv == 10) 
                    cmsg <- "degenerate Nelder-Mead simplex"
              }
              else if (optimizer == "nlm") {
                  if (conv == 3) 
                    cmsg <- "last global step failed to locate a point lower than 'estimate': see ?nlm"
                  if (conv == 4) 
                    cmsg <- "iteration limit exceeded"
                  if (conv == 5) 
                    cmsg <- "maximum step size 'stepmax' exceeded five consecutive times: see ?nlm"
              }
          }
          else cmsg <- oout$message
          warning(paste0("convergence failure: code=", conv, " (", 
              cmsg, ")"))
      }
      m <- new("mle2", call = call, call.orig = call.orig, coef = coef, 
          fullcoef = unlist(fullcoef), vcov = tvcov, min = min, 
          details = oout, minuslogl = minuslogl, method = method, 
          optimizer = optimizer, data = as.list(data), formula = formula)
      attr(m, "df") = length(m@coef)
      if (!missing(data)) 
          attr(m, "nobs") = length(data[[1]])
      environment(m) <- parent.frame()
      m
  }
  <bytecode: 0x16a49d8>
  <environment: namespace:bbmle>
   --- function search by body ---
  Function mle2 in namespace bbmle has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1