Running ‘testthat.R’ [6s/10s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
  > library(testthat)
  > library(rust)
  > 
  > test_check("rust")
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  rust
   --- call from context --- 
  ru(logf = function(x) -x^2/2, d = 1, n = 1, init = 0)
   --- call from argument --- 
  if (class(temp$hessian) == "try-error") {
      pos_def <- FALSE
  } else {
      hess_mat <- temp$hessian
      e_vals <- eigen(hess_mat, symmetric = TRUE, only.values = TRUE)$values
      if (any(e_vals < 1e-06)) {
          pos_def <- FALSE
      }
  }
   --- R stacktrace ---
  where 1 at testthat/test-ru.R#73: ru(logf = function(x) -x^2/2, d = 1, n = 1, init = 0)
  where 2: eval(code, test_env)
  where 3: eval(code, test_env)
  where 4: withCallingHandlers({
      eval(code, test_env)
      if (!handled && !is.null(test)) {
          skip_empty()
      }
  }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, 
      message = handle_message, error = handle_error)
  where 5: doTryCatch(return(expr), name, parentenv, handler)
  where 6: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 7: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 8: doTryCatch(return(expr), name, parentenv, handler)
  where 9: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 10: tryCatchList(expr, classes, parentenv, handlers)
  where 11: tryCatch(withCallingHandlers({
      eval(code, test_env)
      if (!handled && !is.null(test)) {
          skip_empty()
      }
  }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, 
      message = handle_message, error = handle_error), error = handle_fatal, 
      skip = function(e) {
      })
  where 12: test_code(NULL, exprs, env)
  where 13: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 14: force(code)
  where 15: doWithOneRestart(return(expr), restart)
  where 16: withOneRestart(expr, restarts[[1L]])
  where 17: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 18: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter, 
      {
          reporter$start_file(basename(path))
          lister$start_file(basename(path))
          source_file(path, new.env(parent = env), chdir = TRUE, 
              wrap = wrap)
          reporter$.end_context()
          reporter$end_file()
      })
  where 19: FUN(X[[i]], ...)
  where 20: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 21: force(code)
  where 22: doWithOneRestart(return(expr), restart)
  where 23: withOneRestart(expr, restarts[[1L]])
  where 24: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 25: with_reporter(reporter = current_reporter, results <- lapply(paths, 
      test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE, 
      load_helpers = FALSE, wrap = wrap))
  where 26: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 27: test_dir(path = test_path, reporter = reporter, env = env, filter = filter, 
      ..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, 
      wrap = wrap)
  where 28: test_package_dir(package = package, test_path = test_path, filter = filter, 
      reporter = reporter, ..., stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 29: test_check("rust")
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (logf, ..., n = 1, d = 1, init = NULL, trans = c("none", 
      "BC", "user"), phi_to_theta = NULL, log_j = NULL, user_args = list(), 
      lambda = rep(1L, d), lambda_tol = 1e-06, gm = NULL, rotate = ifelse(d == 
          1, FALSE, TRUE), lower = rep(-Inf, d), upper = rep(Inf, 
          d), r = 1/2, ep = 0L, a_algor = if (d == 1) "nlminb" else "optim", 
      b_algor = c("nlminb", "optim"), a_method = c("Nelder-Mead", 
          "BFGS", "CG", "L-BFGS-B", "SANN", "Brent"), b_method = c("Nelder-Mead", 
          "BFGS", "CG", "L-BFGS-B", "SANN", "Brent"), a_control = list(), 
      b_control = list(), var_names = NULL) 
  {
      if (r < 0) {
          stop("r must be non-negative")
      }
      a_algor <- match.arg(a_algor, c("optim", "nlminb"))
      a_method <- match.arg(a_method)
      b_algor <- match.arg(b_algor)
      b_method <- match.arg(b_method)
      if (any(upper <= lower)) {
          stop("upper must be greater than lower, componentwise.")
      }
      trans <- match.arg(trans)
      if (is.null(gm)) {
          gm <- rep(1, d)
      }
      if (trans == "BC") {
          lambda_type <- "numeric"
          if (is.list(lambda)) {
              lambda_type <- "list"
              if (is.null(lambda$lambda)) {
                  stop("The list lambda must contain the object lambda$lambda")
              }
              if (!is.null(lambda$gm)) {
                  gm <- lambda$gm
              }
              if (!is.null(lambda$init_psi)) {
                  init <- lambda$init_psi
              }
              if (a_algor == "optim" & is.null(a_control$parscale)) {
                  a_control <- c(a_control, list(parscale = lambda$sd_psi))
              }
              if (!is.null(lambda$phi_to_theta)) {
                  phi_to_theta <- lambda$phi_to_theta
              }
              if (!is.null(lambda$log_j)) {
                  log_j <- lambda$log_j
              }
              lambda <- lambda$lambda
          }
          lambda <- ifelse(abs(lambda) < lambda_tol, 0L, lambda)
          if (!is.vector(lambda)) {
              stop("lambda must be a numeric vector")
          }
          if (!(length(lambda) %in% c(1, d))) {
              if (lambda_type == "numeric") {
                  stop("lambda must be a numeric vector of length d")
              }
              if (lambda_type == "list") {
                  stop("lambda$lambda must be a numeric vector of length d")
              }
          }
          if (length(lambda) == 1) {
              lambda <- rep(lambda, d)
          }
          if (any(upper <= 0)) {
              stop("when trans = ``BC'' all elements of upper must be positive")
          }
          lower <- pmax(0, lower)
          lower <- ifelse(lambda == 0, gm * log(lower), (lower^lambda - 
              1)/(lambda * gm^(lambda - 1)))
          upper <- ifelse(lambda == 0, gm * log(upper), (upper^lambda - 
              1)/(lambda * gm^(lambda - 1)))
      }
      if (d == 1 & a_algor == "optim" & any(is.infinite(c(lower, 
          upper)))) {
          a_algor = "nlminb"
          warning("For d = 1 finite lower and upper bounds must be supplied when\n            using a_algor = `optim'.  a_algor has been changed to `nlminb'")
      }
      if (d == 1 & b_algor == "optim" & any(is.infinite(c(lower, 
          upper)))) {
          b_algor = "nlminb"
          warning("For d = 1 finite lower and upper bounds must be supplied when\n            using b_algor = `optim'.  b_algor has been changed to `nlminb'")
      }
      if (b_algor == "optim") {
          if (b_method == "BFGS" | b_method == "CG") {
              warning("Using optim with b_method==`BFGS' or `CG' can produce the error\n              message `non-finite finite-difference value'.  If you really want\n              to use BFGS or CG try setting ep to be positive but small, e.g.\n              ep=0.001.", 
                  immediate. = TRUE, noBreaks. = TRUE)
          }
      }
      if (d == 1) {
          a_method <- "Brent"
          b_method <- "Brent"
      }
      if (d == 1) {
          which_lam <- 1L
      }
      else {
          which_lam <- which(lambda != 1L)
      }
      if (is.null(init)) {
          init <- rep(1, d)
          warning("No initial estimate of the mode given: a vector of ones has\n            been used", 
              noBreaks. = TRUE)
      }
      len_init <- length(init)
      if (len_init == 1 & d > 1) {
          init <- rep(init, length.out = d)
          warning("d > 1 but init has length 1: a d-vector of inits has been used")
      }
      if (len_init != d & len_init != 1) {
          stop("the length of init is incompatible with d")
      }
      if (d == 1 & rotate) {
          rotate <- FALSE
          warning("rotation is not relevant when d=1: no rotation is used")
      }
      ep <- abs(ep)
      vals <- matrix(NA, ncol = d, nrow = 2 * d + 1)
      colnames(vals) <- paste("vals", 1:d, sep = "")
      conv <- rep(NA, 2 * d + 1)
      big_val <- Inf
      hscale <- 0
      psi_mode <- rep(0, d)
      if (trans == "none" & is.function(phi_to_theta)) {
          warning("phi_to_theta() not used when trans = ``none'': identity fn used")
      }
      if (!is.function(phi_to_theta) & !is.null(phi_to_theta)) {
          stop("phi_to_theta must be a function or NULL")
      }
      if (trans == "user" & is.null(phi_to_theta)) {
          stop("When trans = ``user'' phi_to_theta must be supplied")
      }
      if (is.function(phi_to_theta) & is.null(log_j)) {
          log_j <- function(x) 0
          warning("No Jacobian for phi_to_theta(): constant Jacobian has been used")
      }
      if (is.null(phi_to_theta)) {
          phi_to_theta <- identity
          log_j <- function(x) 0
      }
      rot_mat <- diag(1, d)
      if (rotate) {
          rho_to_psi <- function(rho) psi_mode + rho %*% rot_mat
      }
      else {
          rho_to_psi <- function(rho) psi_mode + rho
      }
      if (trans == "BC") {
          const <- lambda * gm^(lambda - 1)
          if (any(lambda == 0L)) {
              psi_to_phi <- function(psi) {
                  ifelse(lambda == 0, exp(psi/gm), (psi * const + 
                    1)^(1/lambda))
              }
          }
          else {
              psi_to_phi <- function(psi) (psi * const + 1)^(1/lambda)
          }
      }
      init_psi <- init
      if (trans == "none") {
          logf_rho <- function(._rho, ...) {
              theta <- rho_to_psi(._rho)
              val <- logf(theta, ...) - hscale
              structure(val, theta = theta)
          }
      }
      if (trans == "BC") {
          logf_rho <- function(._rho, ...) {
              psi <- rho_to_psi(._rho)
              test <- (psi * const + 1)[which_lam]
              if (any(test <= 0)) 
                  return(-Inf)
              phi <- psi_to_phi(psi)
              theta <- phi_to_theta(phi)
              log_bc_jac <- sum((lambda - 1)[which_lam] * log(phi[which_lam]))
              val <- logf(theta, ...) - log_bc_jac - log_j(theta) - 
                  hscale
              structure(val, theta = theta)
          }
      }
      if (trans == "user") {
          logf_rho <- function(._rho, ...) {
              phi <- rho_to_psi(._rho)
              theta <- do.call(phi_to_theta, c(list(phi), user_args))
              if (any(!is.finite(theta))) 
                  return(-Inf)
              logj <- do.call(log_j, c(list(theta), user_args))
              val <- logf(theta, ...) - logj - hscale
              structure(val, theta = theta)
          }
      }
      neg_logf_rho <- function(._rho, ...) -logf_rho(._rho, ...)
      f_rho <- function(._rho, ...) exp(logf_rho(._rho, ...))
      hscale <- logf_rho(init_psi, ...)
      if (is.infinite(hscale)) {
          stop("The target density is zero at initial parameter values")
      }
      for_find_a <- list(neg_logf_rho = neg_logf_rho, init_psi = init_psi, 
          d = d, r = r, lower = lower, upper = upper, algor = a_algor, 
          method = a_method, control = a_control, ...)
      temp <- do.call("find_a", for_find_a)
      check_finite <- logf_rho(temp$par, ...)
      if (!is.finite(check_finite)) {
          stop(paste("The target log-density is not finite at its mode: mode = ", 
              paste(temp$par, collapse = ","), ",\n               function value = ", 
              check_finite, ".", sep = ""))
      }
      hscale <- check_finite + hscale
      a_box <- 1
      f_mode <- temp$par
      vals[1, ] <- rep(0, d)
      conv[1] <- temp$convergence
      pos_def <- TRUE
      if (class(temp$hessian) == "try-error") {
          pos_def <- FALSE
      }
      else {
          hess_mat <- temp$hessian
          e_vals <- eigen(hess_mat, symmetric = TRUE, only.values = TRUE)$values
          if (any(e_vals < 1e-06)) {
              pos_def <- FALSE
          }
      }
      if (!pos_def) {
          warning("The Hessian of the target log-density at its mode is not positive\n            definite. This may not be a problem, but it may be that a mode\n            at/near a parameter boundary has been found and/or that the target\n            function is unbounded.", 
              immediate. = TRUE, noBreaks. = TRUE)
          if (trans != "BC") {
              cat("  It might be worth using the option trans = ``BC''.", 
                  "\n")
          }
          if (rotate) {
              rotate <- FALSE
              warning("rotate has been changed to FALSE.", immediate. = TRUE)
          }
      }
      if (rotate) {
          rot_mat <- solve(t(chol(hess_mat)))
          rot_mat <- rot_mat/exp(-mean(log(e_vals))/2)
      }
      psi_mode <- f_mode
      if (rotate) {
          lower <- rep(-Inf, d)
          upper <- rep(Inf, d)
      }
      for_find_bs <- list(f_rho = f_rho, d = d, r = r, lower = lower, 
          upper = upper, f_mode = f_mode, ep = ep, vals = vals, 
          conv = conv, algor = b_algor, method = b_method, control = b_control, 
          ...)
      temp <- do.call("find_bs", for_find_bs)
      vals <- temp$vals
      conv <- temp$conv
      l_box <- temp$l_box
      u_box <- temp$u_box
      n_try <- n_acc <- 0L
      res <- list()
      res$sim_vals <- matrix(NA, ncol = d, nrow = n)
      res$sim_vals_rho <- matrix(NA, ncol = d, nrow = n)
      colnames(res$sim_vals) <- var_names
      colnames(res$sim_vals_rho) <- paste("rho[", 1:d, "]", sep = "")
      d_box <- u_box - l_box
      d_r <- d * r + 1
      while (n_acc < n) {
          u <- runif(1, 0, a_box)
          vs <- d_box * runif(d) + l_box
          rho <- vs/u^r
          rhs <- logf_rho(rho, ...)
          n_try <- n_try + 1L
          if (d_r * log(u) < rhs) {
              n_acc <- n_acc + 1L
              res$sim_vals[n_acc, ] <- attr(rhs, "theta")
              res$sim_vals_rho[n_acc, ] <- rho
          }
      }
      box <- c(a_box, l_box, u_box)
      res$box <- cbind(box, vals, conv)
      bs <- paste(paste("b", 1:d, sep = ""), rep(c("minus", "plus"), 
          each = d), sep = "")
      rownames(res$box) <- c("a", bs)
      res$pa <- n_acc/n_try
      if (any(conv != 0)) {
          warning("One or more convergence indicators are non-zero.", 
              immediate. = TRUE)
          print(res$box)
      }
      res$d <- d
      logf_scaled <- function(theta, ...) {
          return(logf(theta, ...) - hscale)
      }
      res$logf <- logf_scaled
      res$logf_args <- list(...)
      res$logf_rho <- logf_rho
      res$f_mode <- f_mode
      class(res) <- "ru"
      return(res)
  }
  <bytecode: 0x5588c10235e0>
  <environment: namespace:rust>
   --- function search by body ---
  Function ru in namespace rust has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1