Running ‘testthat.R’ [11s/16s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
  > library(testthat)
  > library(aqp)
  This is aqp 1.18
  
  Attaching package: 'aqp'
  
  The following object is masked from 'package:base':
  
      union
  
  > 
  > test_check("aqp")
  ── 1. Failure: SPC spatial operations  (@test-SPC-objects.R#142)  ──────────────
  class(co) not equal to "matrix".
  Lengths differ: 2 is not 1
  
  ── 2. Failure: get.increase.matrix() (used for getArgillicBounds()) (@test-argil
  class\(m\) does not match "matrix".
  Actual values:
  * matrix
  * array
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  aqp
   --- call from context --- 
  slab(sp1, fm = ~prop, strict = TRUE)
   --- call from argument --- 
  if (class(d.slabbed$value) == "matrix") d.slabbed <- cbind(d.slabbed[, 
      1:3], d.slabbed$value)
   --- R stacktrace ---
  where 1: slab(sp1, fm = ~prop, strict = TRUE)
  where 2 at testthat/test-slab.R#12: slab(sp1, fm = ~prop, strict = TRUE)
  where 3: eval(code, test_env)
  where 4: eval(code, test_env)
  where 5: 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 6: doTryCatch(return(expr), name, parentenv, handler)
  where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 9: doTryCatch(return(expr), name, parentenv, handler)
  where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 11: tryCatchList(expr, classes, parentenv, handlers)
  where 12: 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 13: test_code(desc, code, env = parent.frame())
  where 14 at testthat/test-slab.R#5: test_that("basic slab functionality", {
      data(sp1, package = "aqp")
      depths(sp1) <- id ~ top + bottom
      a.1 <- slab(sp1, fm = ~prop, strict = TRUE)
      a.2 <- slab(sp1, fm = ~prop, strict = TRUE, slab.structure = 5)
      a.3 <- slab(sp1, fm = ~prop, strict = TRUE, slab.structure = c(0, 
          5, 10, 25, 50))
      expect_match(class(a.1), "data.frame")
      expect_match(class(a.2), "data.frame")
      expect_match(class(a.3), "data.frame")
      expect_equal(nrow(a.1), 240)
      expect_equal(nrow(a.2), 48)
      expect_equal(nrow(a.3), 4)
      nm <- names(a.1)
      expect_true(any(grepl("variable", nm)))
      expect_true(any(grepl("all.profiles", nm)))
      expect_true(any(grepl("top", nm)))
      expect_true(any(grepl("bottom", nm)))
      expect_true(any(grepl("contributing_fraction", nm)))
      expect_true(any(grepl("p.q", nm)))
  })
  where 15: eval(code, test_env)
  where 16: eval(code, test_env)
  where 17: 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 18: doTryCatch(return(expr), name, parentenv, handler)
  where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 21: doTryCatch(return(expr), name, parentenv, handler)
  where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 23: tryCatchList(expr, classes, parentenv, handlers)
  where 24: 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 25: test_code(NULL, exprs, env)
  where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 27: force(code)
  where 28: doWithOneRestart(return(expr), restart)
  where 29: withOneRestart(expr, restarts[[1L]])
  where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 31: 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 32: FUN(X[[i]], ...)
  where 33: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 34: force(code)
  where 35: doWithOneRestart(return(expr), restart)
  where 36: withOneRestart(expr, restarts[[1L]])
  where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 38: 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 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 40: 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 41: 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 42: test_check("aqp")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  Method Definition:
  
  function (object, fm, slab.structure = 1, strict = FALSE, slab.fun = .slab.fun.numeric.default, 
      cpm = 1, weights = NULL, ...) 
  {
      extra.args <- list(...)
      opt.original <- options(stringsAsFactors = FALSE)
      object.names <- unique(unlist(names(object)))
      n.profiles <- length(object)
      max.d <- max(object)
      object.ID <- idname(object)
      original.levels <- NULL
      g <- all.vars(update(fm, . ~ 0))
      vars <- all.vars(update(fm, 0 ~ .))
      if (!inherits(fm, "formula")) 
          stop("must provide a valid formula: groups ~ var1 + var2 + ...", 
              call. = FALSE)
      if (any(g %in% object.names) == FALSE & g != ".") 
          stop("group name either missing from formula, or does match any columns in dataframe", 
              call. = FALSE)
      if (any(vars %in% object.names) == FALSE) 
          stop("column names in formula do not match column names in dataframe", 
              call. = FALSE)
      fm.slice <- formula(paste("0:", max(object) - 1, " ~ ", paste(vars, 
          collapse = " + "), sep = ""))
      if (length(slab.structure) == 2) 
          fm.slice <- formula(paste(slab.structure[1], ":", slab.structure[2] - 
              1, " ~ ", paste(vars, collapse = " + "), sep = ""))
      data <- slice(object, fm.slice, strict = strict, just.the.data = TRUE)
      site.data <- site(object)
      if (g != ".") 
          if (any(is.na(site.data[, g]))) 
              stop("grouping variable must not contain NA", call. = FALSE)
      data <- join(data, site.data, by = object.ID)
      rm(object, site.data)
      gc()
      if (length(vars) > 1) 
          vars.numeric.test <- sapply(data[, vars], is.numeric)
      else vars.numeric.test <- is.numeric(data[[vars]])
      if (any(!vars.numeric.test) & length(vars) > 1) 
          stop("mixed variable types and multiple categorical variables are not currently supported in the same call to slab", 
              call. = FALSE)
      if (length(vars) == 1 & class(data[, vars]) %in% c("character", 
          "factor")) {
          if (class(data[[vars]]) == "character") {
              message("Note: converting categorical variable to factor.")
              data[[vars]] <- factor(data[[vars]])
          }
          if (!missing(weights)) 
              stop("weighted aggregation of categorical variables not yet implemented", 
                  call. = FALSE)
          slab.fun <- .slab.fun.factor.default
          extra.args <- list(cpm = cpm)
          original.levels <- levels(data[[vars]])
      }
      data$seg.label <- genSlabLabels(slab.structure = slab.structure, 
          max.d = max.d, n.profiles = n.profiles)
      if (g == ".") {
          g <- "all.profiles"
          data[, g] <- 1
      }
      if (!missing(weights)) 
          stop("weighted aggregation is not yet supported", call. = FALSE)
      seg.label.is.not.NA <- which(!is.na(data$seg.label))
      d.long <- melt(data[seg.label.is.not.NA, ], id.vars = c(object.ID, 
          "seg.label", g), measure.vars = vars)
      aggregate.fm <- as.formula(paste("value ~ seg.label + variable + ", 
          g, sep = ""))
      if (length(extra.args) == 0) 
          d.slabbed <- aggregate(aggregate.fm, data = d.long, na.action = na.pass, 
              FUN = slab.fun)
      else {
          the.args <- c(list(formula = aggregate.fm, data = d.long, 
              na.action = na.pass, FUN = slab.fun), extra.args)
          d.slabbed <- do.call(what = "aggregate", args = the.args)
      }
      if (class(d.slabbed$value) == "matrix") 
          d.slabbed <- cbind(d.slabbed[, 1:3], d.slabbed$value)
      names(d.slabbed) <- make.names(names(d.slabbed))
      slab.depths <- strsplit(as.character(d.slabbed$seg.label), 
          "-")
      d.slabbed$top <- as.integer(lapply(slab.depths, function(i) i[1]))
      d.slabbed$bottom <- as.integer(lapply(slab.depths, function(i) i[2]))
      d.slabbed$contributing_fraction <- aggregate(aggregate.fm, 
          data = d.long, na.action = na.pass, FUN = function(i) {
              length(na.omit(i))/length(i)
          })$value
      d.slabbed$seg.label <- NULL
      if (!is.null(original.levels)) 
          attr(d.slabbed, "original.levels") <- original.levels
      options(opt.original)
      return(d.slabbed)
  }
  <bytecode: 0x556e0e593df8>
  <environment: namespace:aqp>
  
  Signatures:
          object                 
  target  "SoilProfileCollection"
  defined "SoilProfileCollection"
   --- function search by body ---
  S4 Method slab:aqp defined in namespace aqp with signature SoilProfileCollection has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1