* using log directory ‘/data/gannet/ripley/R/packages/tests-LENGTH1/TBSSurvival.Rcheck’ * using R Under development (unstable) (2022-04-03 r82074) * using platform: x86_64-pc-linux-gnu (64-bit) * using session charset: UTF-8 * using option ‘--no-stop-on-test-error’ * checking for file ‘TBSSurvival/DESCRIPTION’ ... OK * this is package ‘TBSSurvival’ version ‘1.3’ * checking package namespace information ... OK * checking package dependencies ... OK * checking if this is a source package ... OK * checking if there is a namespace ... OK * checking for executable files ... OK * checking for hidden files and directories ... OK * checking for portable file names ... OK * checking for sufficient/correct file permissions ... OK * checking whether package ‘TBSSurvival’ can be installed ... [15s/22s] OK * checking package directory ... OK * checking ‘build’ directory ... OK * checking DESCRIPTION meta-information ... OK * checking top-level files ... OK * checking for left-over files ... OK * checking index information ... OK * checking package subdirectories ... OK * checking R files for non-ASCII characters ... OK * checking R files for syntax errors ... OK * checking whether the package can be loaded ... OK * checking whether the package can be loaded with stated dependencies ... OK * checking whether the package can be unloaded cleanly ... OK * checking whether the namespace can be loaded with stated dependencies ... OK * checking whether the namespace can be unloaded cleanly ... OK * checking loading without being on the library search path ... OK * checking use of S3 registration ... OK * checking dependencies in R code ... OK * checking S3 generic/method consistency ... OK * checking replacement functions ... OK * checking foreign function calls ... OK * checking R code for possible problems ... [27s/38s] OK * checking Rd files ... OK * checking Rd metadata ... OK * checking Rd line widths ... OK * checking Rd cross-references ... OK * checking for missing documentation entries ... OK * checking for code/documentation mismatches ... OK * checking Rd \usage sections ... OK * checking Rd contents ... OK * checking for unstated dependencies in examples ... OK * checking contents of ‘data’ directory ... OK * checking data for non-ASCII characters ... OK * checking data for ASCII and uncompressed saves ... OK * checking sizes of PDF files under ‘inst/doc’ ... OK * checking installed files from ‘inst/doc’ ... OK * checking files in ‘vignettes’ ... OK * checking examples ... [10s/15s] ERROR Running examples in ‘TBSSurvival-Ex.R’ failed The error most likely occurred in: > ### Name: tbs.survreg.mle > ### Title: MLE of the TBS Model for Failure Data > ### Aliases: tbs.survreg.mle > > ### ** Examples > > # Alloy - T7987: data extracted from Meeker and Escobar (1998), pp. 131. > data(alloyT7987) > alloyT7987$time <- as.double(alloyT7987$time) > alloyT7987$delta <- as.double(alloyT7987$delta) > > # MLE estimation with logistic error > formula <- survival::Surv(alloyT7987$time,alloyT7987$delta == 1) ~ 1 > tbs.mle <- tbs.survreg.mle(formula,dist=dist.error("logistic"),method="Nelder-Mead",nstart=3) ----------- FAILURE REPORT -------------- --- failure: length > 1 in coercion to logical --- --- srcref --- : --- package (from environment) --- TBSSurvival --- call from context --- .tbs.survreg(formula, dist = dist, method = method[i], verbose = verbose, max.time = max.time, nstart = nstart, gradient = gradient) --- call from argument --- valik > -Inf || is.na(est) --- R stacktrace --- where 1: .tbs.survreg(formula, dist = dist, method = method[i], verbose = verbose, max.time = max.time, nstart = nstart, gradient = gradient) where 2: fn.aux(formula, dist, method, verbose, nstart, max.time) where 3: tbs.survreg.mle(formula, dist = dist.error("logistic"), method = "Nelder-Mead", nstart = 3) --- value of length: 6 type: logical --- par value counts convergence message hessian FALSE FALSE FALSE FALSE FALSE FALSE --- function from context --- function (formula, dist = dist.error("norm"), method = "BFGS", guess = NULL, nstart = 10, verbose = FALSE, max.time = -1, gradient = TRUE) { initial.time <- .gettime() if (max.time <= 0) { max.time <- 1e+10 } if (attributes(formula)$class != "formula") stop("A formula argument is required") grad = NULL if (gradient && (method != "SANN")) grad = .grad.tbs mf <- model.frame(formula = formula) x <- model.matrix(attr(mf, "terms"), data = mf) y <- model.response(mf) time <- y[, 1] delta <- y[, 2] x.k <- dim(x)[2] n <- dim(x)[1] if (any((delta != 0) & (delta != 1))) { stop("Only uncesored or right censored data are allowed") } out <- NULL nparam <- 2 if (!is.null(x)) { if (is.matrix(x)) nparam <- nparam + length(x[1, ]) else nparam <- nparam + 1 } if (is.null(guess)) { guess <- 20 * runif(nparam) - 10 guess[1] <- 5 * runif(1) + 1e-04 guess[2] <- 10 * runif(1) + 1e-04 } if (nparam != length(guess)) stop("Number of parameters in the formula and length of the initial guess do not match") if (method == "Rsolnp") { out$method <- method LB = rep(-100, nparam) UB = rep(100, nparam) LB[1] = 1e-04 LB[2] = 1e-04 UB[2] = 1000 if (verbose) cat("RSOLNP: ") for (itk in 1:3) { ans = try(withTimeout(gosolnp(pars = NULL, fixed = NULL, fun = function(pars, n) { -.lik.tbs(pars, time = time, delta = delta, x = x, dist = dist, notinf = TRUE) }, LB = LB, UB = UB, control = list(outer.iter = 200, trace = 0, tol = 1e-04, delta = 1e-06), distr = rep(1, length(LB)), distr.opt = list(), n.restarts = nstart, n.sim = 3000, rseed = runif(n = 1, min = 1, max = 1e+07), n = nparam), timeout = max.time * 60, onTimeout = "error")) if (class(ans) != "try-error" && ans$convergence == 0 && length(ans$values) > 0 && ans$values[length(ans$values)] < 1e+10) { break } } if (class(ans) != "try-error" && ans$convergence == 0 && length(ans$values) > 0 && ans$values[length(ans$values)] < 1e+10) { out$lambda <- ans$par[1] out$xi <- ans$par[2] out$beta <- ans$par[3:length(ans$par)] options(warn = -1) aux <- try(sqrt(diag(solve(-(ans$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NA, nparam) if (class(aux) != "try-error") std.error <- aux out$lambda.se <- std.error[1] out$xi.se <- std.error[2] out$beta.se <- std.error[3:length(std.error)] out$log.lik <- -ans$values[length(ans$values)] if (verbose) cat(out$log.lik, "PARS:", ans$pars, "TIME:", ans$elapsed, "\n") out$error.dist <- dist out$AIC <- 2 * nparam - 2 * out$log.lik out$AICc <- 2 * nparam - 2 * out$log.lik + 2 * nparam * (nparam + 1)/(length(time) - nparam - 1) out$BIC <- -2 * out$log.lik + nparam * log(length(time)) out$convergence <- TRUE aux <- .test.tbs(out$lambda, out$xi, out$beta, x, time, type = "d") out$time <- time out$delta <- delta[order(time)] out$error <- c(.g.lambda(log(out$time), out$lambda) - .g.lambda(c(aux$x %*% aux$beta), out$lambda))[order(time)] out$time <- time[order(time)] names(out$time) <- NULL names(out$error) <- NULL if (length(out$beta) == 1) { if (unique(aux$x[, 1]) == 1) { out$x <- 1 attr(out$x, "plot") <- 1 } else if (length(unique(aux$x[, 1]) <= 4)) { out$x <- unique(aux$x[, 1]) attr(out$x, "plot") <- 2 } } else if ((length(out$beta) == 2) && (unique(aux$x[, 1]) == 1) && (length(unique(aux$x[, 2])) <= 4)) { out$x <- unique(aux$x[, 2]) attr(out$x, "plot") <- 3 } out$run.time <- .gettime() - initial.time } else { if (verbose) cat(" failed\n") out$run.time <- .gettime() - initial.time out$convergence <- FALSE cat(paste(method, ": It was not possible to find a feasible solution\n")) } return(out) } i <- 1 est = NA ii = 1 if (verbose) cat(method, ": ", sep = "") inimethod = method wasnan = TRUE inilooptime = .gettime() while (.gettime() < inilooptime + max.time) { valik = .lik.tbs(guess, time = time, delta = delta, x = x, dist = dist) if (!is.na(valik) && (valik > -Inf || is.na(est))) { aux <- try(withTimeout(optim(guess, fn = .lik.tbs, gr = grad, time = time, delta = delta, dist = dist, x = x, notinf = FALSE, method = inimethod, control = list(fnscale = -1), hessian = TRUE), timeout = max.time * 60, onTimeout = "error"), silent = TRUE) if (class(aux) != "try-error") { if ((inimethod == "SANN") || (aux$convergence != 0)) { for (itx in 1:10) { aux1 <- try(withTimeout(optim(aux$par, fn = .lik.tbs, gr = grad, time = time, delta = delta, dist = dist, x = x, notinf = FALSE, method = method, control = list(fnscale = -1), hessian = TRUE), timeout = max.time * 60, onTimeout = "error"), silent = TRUE) if (class(aux1) != "try-error") { if (aux1$value < aux$value + 1e-04) { break } aux = aux1 } else { break } } } if (is.na(est) || aux$value > est$value || wasnan) { options(warn = -1) aux1 <- try(sqrt(diag(solve(-(aux$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NaN, nparam) if (class(aux1) != "try-error") std.error <- aux1 willnan <- is.nan(sum(std.error)) if (is.na(est) || (wasnan && !willnan) || (aux$value > est$value && wasnan == willnan)) { wasnan = is.nan(sum(std.error)) est = aux inimethod = method } } i = i + 1 if (verbose) cat("@") } else { if (verbose) cat("*") ii = ii + 1 } } else { ii = ii + 1 } guess <- 20 * runif(nparam) - 10 guess[1] <- 5 * runif(1) + 1e-04 guess[2] <- 10 * runif(1) + 1e-04 if (ii > 100 && is.na(est)) { inimethod = "SANN" grad = NULL if (verbose) cat("$") } if (i > nstart || ii > max(nstart, 1000)) { break } } out$method <- method if (!is.na(est) && est$value > -Inf) { out$lambda <- est$par[1] out$xi <- est$par[2] out$beta <- est$par[3:length(est$par)] options(warn = -1) aux <- try(sqrt(diag(solve(-(est$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NA, nparam) if (class(aux) != "try-error") std.error <- aux out$lambda.se <- std.error[1] out$xi.se <- std.error[2] out$beta.se <- std.error[3:length(std.error)] if (is.nan(sum(std.error))) { warning(paste("tbs.survreg.mle: optimization method", method, "failed to compute standard errors -- possibly it is not in a local optimum")) } out$log.lik <- est$value out$error.dist <- dist out$AIC <- 2 * nparam - 2 * est$value out$AICc <- 2 * nparam - 2 * est$value + 2 * nparam * (nparam + 1)/(length(time) - nparam - 1) out$BIC <- -2 * est$value + nparam * log(length(time)) out$convergence <- TRUE aux <- .test.tbs(out$lambda, out$xi, out$beta, x, time, type = "d") out$time <- time out$delta <- delta[order(time)] out$error <- c(.g.lambda(log(out$time), out$lambda) - .g.lambda(c(aux$x %*% aux$beta), out$lambda))[order(time)] out$time <- time[order(time)] names(out$time) <- NULL names(out$error) <- NULL if (length(out$beta) == 1) { if (unique(aux$x[, 1]) == 1) { out$x <- 1 attr(out$x, "plot") <- 1 } else if (length(unique(aux$x[, 1]) <= 4)) { out$x <- unique(aux$x[, 1]) attr(out$x, "plot") <- 2 } } else if ((length(out$beta) == 2) && (unique(aux$x[, 1]) == 1) && (length(unique(aux$x[, 2])) <= 4)) { out$x <- unique(aux$x[, 2]) attr(out$x, "plot") <- 3 } out$run.time <- .gettime() - initial.time if (verbose) cat(" ", out$log.lik, "TIME:", out$run.time, "\n") } else { if (verbose) cat(" failed\n") out$convergence <- FALSE out$run.time <- .gettime() - initial.time cat(paste(method, ": It was not possible to find a feasible solution\n")) } return(out) } --- function search by body --- Function .tbs.survreg in namespace TBSSurvival has this body. ----------- END OF FAILURE REPORT -------------- Fatal error: length > 1 in coercion to logical * checking for unstated dependencies in ‘tests’ ... OK * checking tests ... Running ‘simple.r’ ERROR Running the tests in ‘tests/simple.r’ failed. Complete output: > # TBSSurvival package for R (http://www.R-project.org) > # Copyright (C) 2012 Adriano Polpo, Cassio de Campos, Debajyoti Sinha > # Jianchang Lin and Stuart Lipsitz. > # > # This program is free software: you can redistribute it and/or modify > # it under the terms of the GNU General Public License as published by > # the Free Software Foundation, either version 3 of the License, or > # (at your option) any later version. > # > # This program is distributed in the hope that it will be useful, > # but WITHOUT ANY WARRANTY; without even the implied warranty of > # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the > # GNU General Public License for more details. > # > # You should have received a copy of the GNU General Public License > # along with this program. If not, see . > > ## This code is used for testing purposes. The TBSSurvival library does not > ## depend on it for any of its functionalities > > ## installpacks <- function(loc=NULL,repos="http://stat.ethz.ch/CRAN/") { > ## ## set the repository to use > ## options(repos=repos) > ## ## install the packages > ## install.packages("coda",lib=loc) > ## install.packages("mcmc",lib=loc) > ## install.packages("normalp",lib=loc) > ## install.packages("R.methodsS3",lib=loc) > ## install.packages("R.oo",lib=loc) > ## install.packages("R.utils",lib=loc) > ## install.packages("Rsolnp",lib=loc) > ## install.packages("survival",lib=loc) > ## # install.packages("e1071",lib=loc) > ## # install.packages("eha",lib=loc) > ## install.packages("truncnorm",lib=loc) > ## install.packages("BMS",lib=loc) > > ## ## this following line install the TBS package itself, so nothing else is needed. > ## ## For testing, sometimes it is better to work without installing it for a while... > ## ## install.packages('./TBSSurvival_version.tar.gz',repos=NULL,type="source") > ## } > > ## loadlibs <- function(libdir=NULL) { > ## w <- options("warn") > ## options("warn" = -1) > ## if (require("TBSSurvival",quietly=TRUE)==FALSE) { > ## library("BMS",lib.loc=libdir) > ## library("coda",lib.loc=libdir) > ## library("mcmc",lib.loc=libdir) > ## library("normalp",lib.loc=libdir) > ## library("R.methodsS3",lib.loc=libdir) > ## library("R.oo",lib.loc=libdir) > ## library("R.utils",lib.loc=libdir) > ## library("Rsolnp",lib.loc=libdir) > ## library("survival",lib.loc=libdir) > ## # library("e1071",lib.loc=libdir) > ## # library("eha",lib.loc=libdir) > ## library("truncnorm",lib.loc=libdir) > ## source("../R/tbs.survreg.be.r") > ## source("../R/ptbs.r") > ## source("../R/qtbs.r") > ## source("../R/dtbs.r") > ## source("../R/rtbs.r") > ## source("../R/htbs.r") > ## source("../R/tbs.survreg.mle.r") > ## source("../R/local.r") > ## source("../R/dt2.r") > ## source("../R/dlogis2.r") > ## source("../R/dist.error.r") > > ## } else { > ## library("TBSSurvival") > ## } > ## options("warn" = w[[1]]) > ## } > > ## ## Load data > ## alloyT7987 <- read.table("../data/alloyT7987.txt",header=TRUE) > > library("TBSSurvival") TBSSurvival 1.2 loaded > > ## loadlibs() > set.seed(1) > > #################### > ## simple test with the GBSG2 (German Breast Cancer Group 2) data set from the ipred package > ## SLOW ON CRAN > ## library(ipred) > ## data(GBSG2) > ## cat('Running MLE on GBSG2 (from ipred package) without covariates\n') > ## s=tbs.survreg.mle(survival::Surv(GBSG2$time,GBSG2$cens==1) ~ 1,verbose=TRUE) ## as optim method not given, it tries all methods > ## plot(s) > ## lines(s$cauchy,col=2) > ## lines(s$t,col=3) > ## lines(s$doubexp,col=4) > ## lines(s$logistic,col=5) > ## lines(s$logistic,col=5,lwd=4) > > ## #################### > ## test with the colon data set from the survival package > ## SLOW ON CRAN > library(survival) > data(colon) Warning message: In data(colon) : data set 'colon' not found > cat('Running MLE on colon (from survival package) without covariates\n') Running MLE on colon (from survival package) without covariates > s=tbs.survreg.mle(survival::Surv(colon$time,colon$status==1) ~ 1,dist="norm",method=c("BFGS","Nelder-Mead"),verbose=TRUE,gradient=FALSE) BFGS: ***@ ----------- FAILURE REPORT -------------- --- failure: length > 1 in coercion to logical --- --- srcref --- : --- package (from environment) --- TBSSurvival --- call from context --- .tbs.survreg(formula, dist = dist, method = method[i], verbose = verbose, max.time = max.time, nstart = nstart, gradient = gradient) --- call from argument --- valik > -Inf || is.na(est) --- R stacktrace --- where 1: .tbs.survreg(formula, dist = dist, method = method[i], verbose = verbose, max.time = max.time, nstart = nstart, gradient = gradient) where 2: fn.aux(formula, dist, method, verbose, nstart, max.time) where 3: tbs.survreg.mle(survival::Surv(colon$time, colon$status == 1) ~ 1, dist = "norm", method = c("BFGS", "Nelder-Mead"), verbose = TRUE, gradient = FALSE) --- value of length: 6 type: logical --- par value counts convergence message hessian FALSE FALSE FALSE FALSE FALSE FALSE --- function from context --- function (formula, dist = dist.error("norm"), method = "BFGS", guess = NULL, nstart = 10, verbose = FALSE, max.time = -1, gradient = TRUE) { initial.time <- .gettime() if (max.time <= 0) { max.time <- 1e+10 } if (attributes(formula)$class != "formula") stop("A formula argument is required") grad = NULL if (gradient && (method != "SANN")) grad = .grad.tbs mf <- model.frame(formula = formula) x <- model.matrix(attr(mf, "terms"), data = mf) y <- model.response(mf) time <- y[, 1] delta <- y[, 2] x.k <- dim(x)[2] n <- dim(x)[1] if (any((delta != 0) & (delta != 1))) { stop("Only uncesored or right censored data are allowed") } out <- NULL nparam <- 2 if (!is.null(x)) { if (is.matrix(x)) nparam <- nparam + length(x[1, ]) else nparam <- nparam + 1 } if (is.null(guess)) { guess <- 20 * runif(nparam) - 10 guess[1] <- 5 * runif(1) + 1e-04 guess[2] <- 10 * runif(1) + 1e-04 } if (nparam != length(guess)) stop("Number of parameters in the formula and length of the initial guess do not match") if (method == "Rsolnp") { out$method <- method LB = rep(-100, nparam) UB = rep(100, nparam) LB[1] = 1e-04 LB[2] = 1e-04 UB[2] = 1000 if (verbose) cat("RSOLNP: ") for (itk in 1:3) { ans = try(withTimeout(gosolnp(pars = NULL, fixed = NULL, fun = function(pars, n) { -.lik.tbs(pars, time = time, delta = delta, x = x, dist = dist, notinf = TRUE) }, LB = LB, UB = UB, control = list(outer.iter = 200, trace = 0, tol = 1e-04, delta = 1e-06), distr = rep(1, length(LB)), distr.opt = list(), n.restarts = nstart, n.sim = 3000, rseed = runif(n = 1, min = 1, max = 1e+07), n = nparam), timeout = max.time * 60, onTimeout = "error")) if (class(ans) != "try-error" && ans$convergence == 0 && length(ans$values) > 0 && ans$values[length(ans$values)] < 1e+10) { break } } if (class(ans) != "try-error" && ans$convergence == 0 && length(ans$values) > 0 && ans$values[length(ans$values)] < 1e+10) { out$lambda <- ans$par[1] out$xi <- ans$par[2] out$beta <- ans$par[3:length(ans$par)] options(warn = -1) aux <- try(sqrt(diag(solve(-(ans$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NA, nparam) if (class(aux) != "try-error") std.error <- aux out$lambda.se <- std.error[1] out$xi.se <- std.error[2] out$beta.se <- std.error[3:length(std.error)] out$log.lik <- -ans$values[length(ans$values)] if (verbose) cat(out$log.lik, "PARS:", ans$pars, "TIME:", ans$elapsed, "\n") out$error.dist <- dist out$AIC <- 2 * nparam - 2 * out$log.lik out$AICc <- 2 * nparam - 2 * out$log.lik + 2 * nparam * (nparam + 1)/(length(time) - nparam - 1) out$BIC <- -2 * out$log.lik + nparam * log(length(time)) out$convergence <- TRUE aux <- .test.tbs(out$lambda, out$xi, out$beta, x, time, type = "d") out$time <- time out$delta <- delta[order(time)] out$error <- c(.g.lambda(log(out$time), out$lambda) - .g.lambda(c(aux$x %*% aux$beta), out$lambda))[order(time)] out$time <- time[order(time)] names(out$time) <- NULL names(out$error) <- NULL if (length(out$beta) == 1) { if (unique(aux$x[, 1]) == 1) { out$x <- 1 attr(out$x, "plot") <- 1 } else if (length(unique(aux$x[, 1]) <= 4)) { out$x <- unique(aux$x[, 1]) attr(out$x, "plot") <- 2 } } else if ((length(out$beta) == 2) && (unique(aux$x[, 1]) == 1) && (length(unique(aux$x[, 2])) <= 4)) { out$x <- unique(aux$x[, 2]) attr(out$x, "plot") <- 3 } out$run.time <- .gettime() - initial.time } else { if (verbose) cat(" failed\n") out$run.time <- .gettime() - initial.time out$convergence <- FALSE cat(paste(method, ": It was not possible to find a feasible solution\n")) } return(out) } i <- 1 est = NA ii = 1 if (verbose) cat(method, ": ", sep = "") inimethod = method wasnan = TRUE inilooptime = .gettime() while (.gettime() < inilooptime + max.time) { valik = .lik.tbs(guess, time = time, delta = delta, x = x, dist = dist) if (!is.na(valik) && (valik > -Inf || is.na(est))) { aux <- try(withTimeout(optim(guess, fn = .lik.tbs, gr = grad, time = time, delta = delta, dist = dist, x = x, notinf = FALSE, method = inimethod, control = list(fnscale = -1), hessian = TRUE), timeout = max.time * 60, onTimeout = "error"), silent = TRUE) if (class(aux) != "try-error") { if ((inimethod == "SANN") || (aux$convergence != 0)) { for (itx in 1:10) { aux1 <- try(withTimeout(optim(aux$par, fn = .lik.tbs, gr = grad, time = time, delta = delta, dist = dist, x = x, notinf = FALSE, method = method, control = list(fnscale = -1), hessian = TRUE), timeout = max.time * 60, onTimeout = "error"), silent = TRUE) if (class(aux1) != "try-error") { if (aux1$value < aux$value + 1e-04) { break } aux = aux1 } else { break } } } if (is.na(est) || aux$value > est$value || wasnan) { options(warn = -1) aux1 <- try(sqrt(diag(solve(-(aux$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NaN, nparam) if (class(aux1) != "try-error") std.error <- aux1 willnan <- is.nan(sum(std.error)) if (is.na(est) || (wasnan && !willnan) || (aux$value > est$value && wasnan == willnan)) { wasnan = is.nan(sum(std.error)) est = aux inimethod = method } } i = i + 1 if (verbose) cat("@") } else { if (verbose) cat("*") ii = ii + 1 } } else { ii = ii + 1 } guess <- 20 * runif(nparam) - 10 guess[1] <- 5 * runif(1) + 1e-04 guess[2] <- 10 * runif(1) + 1e-04 if (ii > 100 && is.na(est)) { inimethod = "SANN" grad = NULL if (verbose) cat("$") } if (i > nstart || ii > max(nstart, 1000)) { break } } out$method <- method if (!is.na(est) && est$value > -Inf) { out$lambda <- est$par[1] out$xi <- est$par[2] out$beta <- est$par[3:length(est$par)] options(warn = -1) aux <- try(sqrt(diag(solve(-(est$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NA, nparam) if (class(aux) != "try-error") std.error <- aux out$lambda.se <- std.error[1] out$xi.se <- std.error[2] out$beta.se <- std.error[3:length(std.error)] if (is.nan(sum(std.error))) { warning(paste("tbs.survreg.mle: optimization method", method, "failed to compute standard errors -- possibly it is not in a local optimum")) } out$log.lik <- est$value out$error.dist <- dist out$AIC <- 2 * nparam - 2 * est$value out$AICc <- 2 * nparam - 2 * est$value + 2 * nparam * (nparam + 1)/(length(time) - nparam - 1) out$BIC <- -2 * est$value + nparam * log(length(time)) out$convergence <- TRUE aux <- .test.tbs(out$lambda, out$xi, out$beta, x, time, type = "d") out$time <- time out$delta <- delta[order(time)] out$error <- c(.g.lambda(log(out$time), out$lambda) - .g.lambda(c(aux$x %*% aux$beta), out$lambda))[order(time)] out$time <- time[order(time)] names(out$time) <- NULL names(out$error) <- NULL if (length(out$beta) == 1) { if (unique(aux$x[, 1]) == 1) { out$x <- 1 attr(out$x, "plot") <- 1 } else if (length(unique(aux$x[, 1]) <= 4)) { out$x <- unique(aux$x[, 1]) attr(out$x, "plot") <- 2 } } else if ((length(out$beta) == 2) && (unique(aux$x[, 1]) == 1) && (length(unique(aux$x[, 2])) <= 4)) { out$x <- unique(aux$x[, 2]) attr(out$x, "plot") <- 3 } out$run.time <- .gettime() - initial.time if (verbose) cat(" ", out$log.lik, "TIME:", out$run.time, "\n") } else { if (verbose) cat(" failed\n") out$convergence <- FALSE out$run.time <- .gettime() - initial.time cat(paste(method, ": It was not possible to find a feasible solution\n")) } return(out) } --- function search by body --- Function .tbs.survreg in namespace TBSSurvival has this body. ----------- END OF FAILURE REPORT -------------- Fatal error: length > 1 in coercion to logical * checking for unstated dependencies in vignettes ... OK * checking package vignettes in ‘inst/doc’ ... OK * checking re-building of vignette outputs ... ERROR Error(s) in re-building vignettes: --- re-building ‘TBSSurvival.Rnw’ using Sweave TBSSurvival 1.2 loaded ----------- FAILURE REPORT -------------- --- failure: length > 1 in coercion to logical --- --- srcref --- : --- package (from environment) --- TBSSurvival --- call from context --- .tbs.survreg(formula, dist = dist, method = method[i], verbose = verbose, max.time = max.time, nstart = nstart, gradient = gradient) --- call from argument --- valik > -Inf || is.na(est) --- R stacktrace --- where 1: .tbs.survreg(formula, dist = dist, method = method[i], verbose = verbose, max.time = max.time, nstart = nstart, gradient = gradient) where 2: fn.aux(formula, dist, method, verbose, nstart, max.time) where 3: tbs.survreg.mle(formula, dist = mynormal, nstart = 3, method = "Nelder-Mead") where 4: eval(expr, .GlobalEnv) where 5: eval(expr, .GlobalEnv) where 6: withVisible(eval(expr, .GlobalEnv)) where 7: doTryCatch(return(expr), name, parentenv, handler) where 8: tryCatchOne(expr, names, parentenv, handlers[[1L]]) where 9: tryCatchList(expr, classes, parentenv, handlers) where 10: 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, nlines = 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 11: try(withVisible(eval(expr, .GlobalEnv)), silent = TRUE) where 12: evalFunc(ce, options) where 13: tryCatchList(expr, classes, parentenv, handlers) where 14: tryCatch(evalFunc(ce, options), finally = { cat("\n") sink() }) where 15: driver$runcode(drobj, chunk, chunkopts) where 16: utils::Sweave(...) where 17: engine$weave(file, quiet = quiet, encoding = enc) where 18: doTryCatch(return(expr), name, parentenv, handler) where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]]) where 20: tryCatchList(expr, classes, parentenv, handlers) where 21: 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) } outputs <- c(outputs, output) }, error = function(e) { thisOK <<- FALSE fails <<- c(fails, file) message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s", file, conditionMessage(e))) }) where 22: tools:::buildVignettes(dir = "/data/gannet/ripley/R/packages/tests-LENGTH1/TBSSurvival.Rcheck/vign_test/TBSSurvival") --- value of length: 6 type: logical --- par value counts convergence message FALSE FALSE FALSE FALSE FALSE hessian FALSE --- function from context --- function (formula, dist = dist.error("norm"), method = "BFGS", guess = NULL, nstart = 10, verbose = FALSE, max.time = -1, gradient = TRUE) { initial.time <- .gettime() if (max.time <= 0) { max.time <- 1e+10 } if (attributes(formula)$class != "formula") stop("A formula argument is required") grad = NULL if (gradient && (method != "SANN")) grad = .grad.tbs mf <- model.frame(formula = formula) x <- model.matrix(attr(mf, "terms"), data = mf) y <- model.response(mf) time <- y[, 1] delta <- y[, 2] x.k <- dim(x)[2] n <- dim(x)[1] if (any((delta != 0) & (delta != 1))) { stop("Only uncesored or right censored data are allowed") } out <- NULL nparam <- 2 if (!is.null(x)) { if (is.matrix(x)) nparam <- nparam + length(x[1, ]) else nparam <- nparam + 1 } if (is.null(guess)) { guess <- 20 * runif(nparam) - 10 guess[1] <- 5 * runif(1) + 1e-04 guess[2] <- 10 * runif(1) + 1e-04 } if (nparam != length(guess)) stop("Number of parameters in the formula and length of the initial guess do not match") if (method == "Rsolnp") { out$method <- method LB = rep(-100, nparam) UB = rep(100, nparam) LB[1] = 1e-04 LB[2] = 1e-04 UB[2] = 1000 if (verbose) cat("RSOLNP: ") for (itk in 1:3) { ans = try(withTimeout(gosolnp(pars = NULL, fixed = NULL, fun = function(pars, n) { -.lik.tbs(pars, time = time, delta = delta, x = x, dist = dist, notinf = TRUE) }, LB = LB, UB = UB, control = list(outer.iter = 200, trace = 0, tol = 1e-04, delta = 1e-06), distr = rep(1, length(LB)), distr.opt = list(), n.restarts = nstart, n.sim = 3000, rseed = runif(n = 1, min = 1, max = 1e+07), n = nparam), timeout = max.time * 60, onTimeout = "error")) if (class(ans) != "try-error" && ans$convergence == 0 && length(ans$values) > 0 && ans$values[length(ans$values)] < 1e+10) { break } } if (class(ans) != "try-error" && ans$convergence == 0 && length(ans$values) > 0 && ans$values[length(ans$values)] < 1e+10) { out$lambda <- ans$par[1] out$xi <- ans$par[2] out$beta <- ans$par[3:length(ans$par)] options(warn = -1) aux <- try(sqrt(diag(solve(-(ans$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NA, nparam) if (class(aux) != "try-error") std.error <- aux out$lambda.se <- std.error[1] out$xi.se <- std.error[2] out$beta.se <- std.error[3:length(std.error)] out$log.lik <- -ans$values[length(ans$values)] if (verbose) cat(out$log.lik, "PARS:", ans$pars, "TIME:", ans$elapsed, "\n") out$error.dist <- dist out$AIC <- 2 * nparam - 2 * out$log.lik out$AICc <- 2 * nparam - 2 * out$log.lik + 2 * nparam * (nparam + 1)/(length(time) - nparam - 1) out$BIC <- -2 * out$log.lik + nparam * log(length(time)) out$convergence <- TRUE aux <- .test.tbs(out$lambda, out$xi, out$beta, x, time, type = "d") out$time <- time out$delta <- delta[order(time)] out$error <- c(.g.lambda(log(out$time), out$lambda) - .g.lambda(c(aux$x %*% aux$beta), out$lambda))[order(time)] out$time <- time[order(time)] names(out$time) <- NULL names(out$error) <- NULL if (length(out$beta) == 1) { if (unique(aux$x[, 1]) == 1) { out$x <- 1 attr(out$x, "plot") <- 1 } else if (length(unique(aux$x[, 1]) <= 4)) { out$x <- unique(aux$x[, 1]) attr(out$x, "plot") <- 2 } } else if ((length(out$beta) == 2) && (unique(aux$x[, 1]) == 1) && (length(unique(aux$x[, 2])) <= 4)) { out$x <- unique(aux$x[, 2]) attr(out$x, "plot") <- 3 } out$run.time <- .gettime() - initial.time } else { if (verbose) cat(" failed\n") out$run.time <- .gettime() - initial.time out$convergence <- FALSE cat(paste(method, ": It was not possible to find a feasible solution\n")) } return(out) } i <- 1 est = NA ii = 1 if (verbose) cat(method, ": ", sep = "") inimethod = method wasnan = TRUE inilooptime = .gettime() while (.gettime() < inilooptime + max.time) { valik = .lik.tbs(guess, time = time, delta = delta, x = x, dist = dist) if (!is.na(valik) && (valik > -Inf || is.na(est))) { aux <- try(withTimeout(optim(guess, fn = .lik.tbs, gr = grad, time = time, delta = delta, dist = dist, x = x, notinf = FALSE, method = inimethod, control = list(fnscale = -1), hessian = TRUE), timeout = max.time * 60, onTimeout = "error"), silent = TRUE) if (class(aux) != "try-error") { if ((inimethod == "SANN") || (aux$convergence != 0)) { for (itx in 1:10) { aux1 <- try(withTimeout(optim(aux$par, fn = .lik.tbs, gr = grad, time = time, delta = delta, dist = dist, x = x, notinf = FALSE, method = method, control = list(fnscale = -1), hessian = TRUE), timeout = max.time * 60, onTimeout = "error"), silent = TRUE) if (class(aux1) != "try-error") { if (aux1$value < aux$value + 1e-04) { break } aux = aux1 } else { break } } } if (is.na(est) || aux$value > est$value || wasnan) { options(warn = -1) aux1 <- try(sqrt(diag(solve(-(aux$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NaN, nparam) if (class(aux1) != "try-error") std.error <- aux1 willnan <- is.nan(sum(std.error)) if (is.na(est) || (wasnan && !willnan) || (aux$value > est$value && wasnan == willnan)) { wasnan = is.nan(sum(std.error)) est = aux inimethod = method } } i = i + 1 if (verbose) cat("@") } else { if (verbose) cat("*") ii = ii + 1 } } else { ii = ii + 1 } guess <- 20 * runif(nparam) - 10 guess[1] <- 5 * runif(1) + 1e-04 guess[2] <- 10 * runif(1) + 1e-04 if (ii > 100 && is.na(est)) { inimethod = "SANN" grad = NULL if (verbose) cat("$") } if (i > nstart || ii > max(nstart, 1000)) { break } } out$method <- method if (!is.na(est) && est$value > -Inf) { out$lambda <- est$par[1] out$xi <- est$par[2] out$beta <- est$par[3:length(est$par)] options(warn = -1) aux <- try(sqrt(diag(solve(-(est$hessian)))), silent = TRUE) options(warn = 0) std.error <- rep(NA, nparam) if (class(aux) != "try-error") std.error <- aux out$lambda.se <- std.error[1] out$xi.se <- std.error[2] out$beta.se <- std.error[3:length(std.error)] if (is.nan(sum(std.error))) { warning(paste("tbs.survreg.mle: optimization method", method, "failed to compute standard errors -- possibly it is not in a local optimum")) } out$log.lik <- est$value out$error.dist <- dist out$AIC <- 2 * nparam - 2 * est$value out$AICc <- 2 * nparam - 2 * est$value + 2 * nparam * (nparam + 1)/(length(time) - nparam - 1) out$BIC <- -2 * est$value + nparam * log(length(time)) out$convergence <- TRUE aux <- .test.tbs(out$lambda, out$xi, out$beta, x, time, type = "d") out$time <- time out$delta <- delta[order(time)] out$error <- c(.g.lambda(log(out$time), out$lambda) - .g.lambda(c(aux$x %*% aux$beta), out$lambda))[order(time)] out$time <- time[order(time)] names(out$time) <- NULL names(out$error) <- NULL if (length(out$beta) == 1) { if (unique(aux$x[, 1]) == 1) { out$x <- 1 attr(out$x, "plot") <- 1 } else if (length(unique(aux$x[, 1]) <= 4)) { out$x <- unique(aux$x[, 1]) attr(out$x, "plot") <- 2 } } else if ((length(out$beta) == 2) && (unique(aux$x[, 1]) == 1) && (length(unique(aux$x[, 2])) <= 4)) { out$x <- unique(aux$x[, 2]) attr(out$x, "plot") <- 3 } out$run.time <- .gettime() - initial.time if (verbose) cat(" ", out$log.lik, "TIME:", out$run.time, "\n") } else { if (verbose) cat(" failed\n") out$convergence <- FALSE out$run.time <- .gettime() - initial.time cat(paste(method, ": It was not possible to find a feasible solution\n")) } return(out) } --- function search by body --- Function .tbs.survreg in namespace TBSSurvival has this body. ----------- END OF FAILURE REPORT -------------- Fatal error: length > 1 in coercion to logical * checking PDF version of manual ... OK * checking for non-standard things in the check directory ... OK * checking for detritus in the temp directory ... OK * DONE Status: 3 ERRORs See ‘/data/gannet/ripley/R/packages/tests-LENGTH1/TBSSurvival.Rcheck/00check.log’ for details. Command exited with non-zero status 1 Time 3:13.49, 117.08 + 11.91