Last updated on 2019-11-26 00:51:44 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.0.20 | 8.18 | 107.32 | 115.50 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 1.0.20 | 6.44 | 86.42 | 92.86 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 1.0.20 | 161.18 | OK | |||
| r-devel-linux-x86_64-fedora-gcc | 1.0.20 | 158.01 | OK | |||
| r-devel-windows-ix86+x86_64 | 1.0.20 | 22.00 | 210.00 | 232.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 1.0.20 | 18.00 | 145.00 | 163.00 | OK | |
| r-patched-linux-x86_64 | 1.0.20 | 6.63 | 125.80 | 132.43 | OK | |
| r-patched-solaris-x86 | 1.0.20 | 212.10 | OK | |||
| r-release-linux-x86_64 | 1.0.20 | 6.67 | 129.36 | 136.03 | OK | |
| r-release-windows-ix86+x86_64 | 1.0.20 | 19.00 | 195.00 | 214.00 | OK | |
| r-release-osx-x86_64 | 1.0.20 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 1.0.20 | 9.00 | 141.00 | 150.00 | OK | |
| r-oldrel-osx-x86_64 | 1.0.20 | OK |
Version: 1.0.20
Check: examples
Result: ERROR
Running examples in 'bbmle-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: BIC-methods
> ### Title: Log likelihoods and model selection for mle2 objects
> ### Aliases: BIC-methods AIC-methods AICc-methods logLik-methods AICc
> ### AIC,mle2-method AICc,mle2-method AICc,logLik-method AICc,ANY-method
> ### AICc,ANY,mle2,logLik-method qAICc qAICc-methods qAICc,ANY-method
> ### qAICc,mle2-method qAICc,logLik-method qAIC qAIC-methods
> ### qAIC,ANY-method qAIC,mle2-method qAIC,logLik-method
> ### qAIC,ANY,mle2,logLik-method qAICc,ANY,mle2,logLik-method
> ### logLik,mle2-method anova,mle2-method
> ### Keywords: methods
>
> ### ** Examples
>
> d <- data.frame(x=0:10,y=c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8))
> (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: 0x2739b00>
<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
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.0.20
Check: tests
Result: ERROR
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' [1s/2s]
Running 'eval.R' [1s/2s]
Running 'formulatest.R' [2s/2s]
Running 'glmcomp.R' [2s/2s]
Running 'gradient_vecpar_profile.R' [2s/2s]
Running 'grtest1.R' [2s/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: 0x1302c70>
<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: 0x1d5d6a0>
<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: 0x14efc18>
<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: 0x2112ea0>
<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: 0xd93d58>
<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: 0x2017f90>
<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: 0x1f1dac0>
<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: 0x22596d8>
<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: 0x2f470c0>
<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: 0x20ab0e0>
<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: 0x2bb0c20>
<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: 0x28738d8>
<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: 0x1bf04a0>
<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: 0x32d2eb8>
<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: 0x1f35ef0>
<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: 0x22bbc18>
<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: 0x287fff0>
<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: 0x132e1b8>
<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: 0x1b4b1c8>
<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: 0x211ad90>
<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: 0x36a99c0>
<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: 0x25bb820>
<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: 0x10eaf08>
<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: 0x365ba98>
<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: 0x9ebe28>
<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: 0x14c8638>
<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: 0x10270a0>
<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: 0x1850540>
<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: 0xc89e40>
<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: 0x214ca48>
<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
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.0.20
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
...
--- re-building 'mle2.Rnw' using knitr
Loading required package: knitr
Loading required package: lattice
Loading required package: survival
Loading required package: Formula
Loading required package: ggplot2
Attaching package: 'Hmisc'
The following objects are masked from 'package:base':
format.pval, units
Loading required package: stats4
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
Warning in lbeta(theta * (1 - prob), theta * prob) : NaNs produced
Warning in lbeta(size - x + theta * (1 - prob), x + theta * prob) :
NaNs produced
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
bbmle
--- call from context ---
mle2(mtmp, start = list(prob = 0.2, theta = 9), data = list(size = 50))
--- 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(mtmp, start = list(prob = 0.2, theta = 9), data = list(size = 50))
where 2: eval(expr, envir, enclos)
where 3: eval(expr, envir, enclos)
where 4: withVisible(eval(expr, envir, enclos))
where 5: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, classes, parentenv, handlers)
where 9: tryCatch(expr, error = function(e) {
call <- conditionCall(e)
if (!is.null(call)) {
if (identical(call[[1L]], quote(doTryCatch)))
call <- sys.call(-4L)
dcall <- deparse(call)[1L]
prefix <- paste("Error in", dcall, ": ")
LONG <- 75L
sm <- strsplit(conditionMessage(e), "\n")[[1L]]
w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w")
if (is.na(w))
w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L],
type = "b")
if (w > LONG)
prefix <- paste0(prefix, "\n ")
}
else prefix <- "Error : "
msg <- paste0(prefix, conditionMessage(e), "\n")
.Internal(seterrmessage(msg[1L]))
if (!silent && isTRUE(getOption("show.error.messages"))) {
cat(msg, file = outFile)
.Internal(printDeferredWarnings())
}
invisible(structure(msg, class = "try-error", condition = e))
})
where 10: try(f, silent = TRUE)
where 11: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 12: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 13: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 14: evaluate::evaluate(...)
where 15: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 16: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 17: block_exec(params)
where 18: call_block(x)
where 19: process_group.block(group)
where 20: process_group(group)
where 21: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 22: process_file(text, output)
where 23: (if (grepl("\\.[Rr]md$", file)) knit2html_v1 else if (grepl("\\.[Rr]rst$",
file)) knit2pandoc else knit)(file, encoding = encoding,
quiet = quiet, envir = globalenv(), ...)
where 24: engine$weave(file, quiet = quiet, encoding = enc)
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
}, error = function(e) {
OK <<- FALSE
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 29: tools:::.buildOneVignette("mle2.Rnw", "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/bbmle.Rcheck/vign_test/bbmle",
TRUE, FALSE, "mle2", "UTF-8", "/tmp/Rtmpq1GeyR/file4ba17357d1fd.rds")
--- 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: 0x8db09b8>
<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
--- re-building 'quasi.Rnw' using knitr
--- finished re-building 'quasi.Rnw'
SUMMARY: processing the following file failed:
'mle2.Rnw'
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.0.20
Check: examples
Result: ERROR
Running examples in ‘bbmle-Ex.R’ failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: BIC-methods
> ### Title: Log likelihoods and model selection for mle2 objects
> ### Aliases: BIC-methods AIC-methods AICc-methods logLik-methods AICc
> ### AIC,mle2-method AICc,mle2-method AICc,logLik-method AICc,ANY-method
> ### AICc,ANY,mle2,logLik-method qAICc qAICc-methods qAICc,ANY-method
> ### qAICc,mle2-method qAICc,logLik-method qAIC qAIC-methods
> ### qAIC,ANY-method qAIC,mle2-method qAIC,logLik-method
> ### qAIC,ANY,mle2,logLik-method qAICc,ANY,mle2,logLik-method
> ### logLik,mle2-method anova,mle2-method
> ### Keywords: methods
>
> ### ** Examples
>
> d <- data.frame(x=0:10,y=c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8))
> (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: 0x563cc67ca240>
<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
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 1.0.20
Check: tests
Result: ERROR
Running ‘BIC.R’ [1s/3s]
Running ‘ICtab.R’ [1s/2s]
Running ‘RUnit-tests.R’ [0s/1s]
Running ‘binomtest1.R’ [1s/2s]
Running ‘boundstest.R’ [0s/1s]
Running ‘controleval.R’ [1s/2s]
Running ‘eval.R’ [1s/3s]
Running ‘formulatest.R’ [1s/2s]
Running ‘glmcomp.R’ [2s/3s]
Running ‘gradient_vecpar_profile.R’ [1s/3s]
Running ‘grtest1.R’ [1s/2s]
Running ‘methods.R’ [1s/2s]
Running ‘mortanal.R’ [1s/3s]
Running ‘optimize.R’ [1s/2s]
Running ‘optimizers.R’ [1s/2s]
Running ‘optimx.R’ [2s/3s]
Running ‘order.R’ [1s/3s]
Running ‘parscale.R’ [1s/2s]
Running ‘predict.R’ [1s/2s]
Running ‘prof_newmin.R’ [1s/2s]
Running ‘prof_spec.R’ [1s/2s]
Running ‘profbound.R’ [1s/2s]
Running ‘richards.R’ [2s/3s]
Running ‘startvals.R’ [1s/2s]
Running ‘startvals2.R’ [1s/2s]
Running ‘test-relist1.R’ [1s/2s]
Running ‘testbounds.R’ [1s/2s]
Running ‘testderiv.R’ [1s/2s]
Running ‘testenv.R’ [1s/2s]
Running ‘testparpred.R’ [2s/3s]
Running ‘tmptest.R’ [1s/2s]
Running ‘update.R’ [1s/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: 0x555f58b7e7c8>
<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)))
&