Running ‘testthat.R’ [5s/6s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
  > if (require("testthat", character.only = TRUE)) {
  +   test_check("trinROC")
  + }
  Loading required package: testthat
  Loading required package: trinROC
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  trinROC
   --- call from context --- 
  trinROC.test(dat = dat[, c(1, 5)])
   --- call from argument --- 
  if (class(try(solve(covariance), silent = T)) != "matrix") {
      chi2 <- 0
      print("matrix is not invertible. Conclude complete alikeness.")
  } else {
      test <- t(c(A1 - A2, B1 - B2, C1 - C2, D1 - D2)) %*% solve(covariance) %*% 
          c(A1 - A2, B1 - B2, C1 - C2, D1 - D2)
      chi2 <- as.numeric(test)
  }
   --- R stacktrace ---
  where 1 at testthat/test_trinROC.R#87: trinROC.test(dat = dat[, c(1, 5)])
  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(desc, code, env = parent.frame())
  where 13 at testthat/test_trinROC.R#84: test_that("trinROC.test() function", {
      temp <- trinROC.test(dat = dat[, c(1, 5)])
      expect_equal(round(temp$p.value, 3), 0)
      expect_equal(unname(round(temp$statistic, 3)), 20.426)
      temp <- trinROC.test(dat = dat[, c(1, 4)])
      expect_equal(temp$p.value, 1)
      expect_equal(unname(round(temp$statistic, 3)), 0)
      temp <- trinROC.test(dat = dat[, 1:2])
      expect_equal(round(temp$p.value, 2), 0.08)
      expect_equal(as.numeric(round(temp$estimate[2], 3)), 0.696)
      temp <- trinROC.test(dat = dat[, 1:3])
      expect_equal(round(temp$p.value, 2), 0.45)
      expect_equal(round(temp$estimate[2, 5], 3), 0.103)
  })
  where 14: eval(code, test_env)
  where 15: eval(code, test_env)
  where 16: 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 17: doTryCatch(return(expr), name, parentenv, handler)
  where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 20: doTryCatch(return(expr), name, parentenv, handler)
  where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 22: tryCatchList(expr, classes, parentenv, handlers)
  where 23: 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 24: test_code(NULL, exprs, env)
  where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 26: force(code)
  where 27: doWithOneRestart(return(expr), restart)
  where 28: withOneRestart(expr, restarts[[1L]])
  where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 30: 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 31: FUN(X[[i]], ...)
  where 32: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 33: force(code)
  where 34: doWithOneRestart(return(expr), restart)
  where 35: withOneRestart(expr, restarts[[1L]])
  where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 37: 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 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 39: 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 40: 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 41: test_check("trinROC")
  
   --- value of length: 2 type: logical ---
  [1] FALSE  TRUE
   --- function from context --- 
  function (x1, y1, z1, x2 = 0, y2 = 0, z2 = 0, dat = NULL, paired = FALSE, 
      conf.level = 0.95) 
  {
      alternative <- "two.sided"
      if (!missing(conf.level) & (length(conf.level) != 1 | !is.finite(conf.level) | 
          conf.level < 0 | conf.level > 1)) 
          stop("'conf.level' must be a single number between 0 and 1")
      if (!is.null(dat)) {
          if (class(dat) != "data.frame" || class(dat[, 1]) != 
              "factor" | ncol(dat) <= 1) 
              stop("Data should be organized as a data frame with the group index factor at\n           the first column and marker measurements at the second and third column.")
          if (any(sapply(1:(ncol(dat) - 1), function(i) class(dat[, 
              i + 1]) != "numeric"))) {
              for (i in 1:(ncol(dat) - 1)) {
                  if (class(dat[, i + 1]) != "numeric") 
                    dat[, (i + 1)] <- as.numeric(dat[, (i + 1)])
              }
              warning("Some measurements were not numeric. Forced to numeric.")
          }
          data.temp <- split(dat[, 2], dat[, 1], drop = FALSE)
          x1 <- data.temp[[1]]
          y1 <- data.temp[[2]]
          z1 <- data.temp[[3]]
          if (ncol(dat) > 2) {
              data.temp <- split(dat[, 3], dat[, 1], drop = FALSE)
              x2 <- data.temp[[1]]
              y2 <- data.temp[[2]]
              z2 <- data.temp[[3]]
          }
      }
      if (any(is.na(c(x1, x2)))) {
          warning("there are NA's in the healthy classes which are omitted.")
          if (paired) {
              delx <- complete.cases(cbind(x1, x2))
              x.1 <- x1[delx]
              x.2 <- x2[delx]
          }
          else {
              x.1 <- as.numeric(na.omit(x1))
              x.2 <- as.numeric(na.omit(x2))
          }
      }
      else {
          x.1 <- x1
          x.2 <- x2
      }
      if (any(is.na(c(y1, y2)))) {
          warning("there are NA's in the intermediate classes which are omitted.")
          if (paired) {
              dely <- complete.cases(cbind(y1, y2))
              y.1 <- y1[dely]
              y.2 <- y2[dely]
          }
          else {
              y.1 <- as.numeric(na.omit(y1))
              y.2 <- as.numeric(na.omit(y2))
          }
      }
      else {
          y.1 <- y1
          y.2 <- y2
      }
      if (any(is.na(c(z1, z2)))) {
          warning("there are NA's in the diseased classes which are omitted.")
          if (paired) {
              delz <- complete.cases(cbind(z1, z2))
              z.1 <- z1[delz]
              z.2 <- z2[delz]
          }
          else {
              z.1 <- as.numeric(na.omit(z1))
              z.2 <- as.numeric(na.omit(z2))
          }
      }
      else {
          z.1 <- z1
          z.2 <- z2
      }
      if (length(x.2) == 1 && length(y.2) == 1 && length(z.2) == 
          1) {
          twocurves <- FALSE
          method <- "Trinormal based ROC test for single classifier assessment"
          dname <- if (!is.null(dat)) {
              paste(c(levels(dat[, 1]), "of", names(dat)[2]), collapse = "  ")
          }
          else {
              paste(deparse(substitute(x1)), deparse(substitute(y1)), 
                  "and", deparse(substitute(z1)))
          }
      }
      else {
          if ((paired) && (length(x.1) != length(x.2) || length(y.1) != 
              length(y.2) || length(z.1) != length(z.2))) 
              stop("The two test sets do not have equal size.")
          twocurves <- TRUE
          method <- "Trinormal based ROC test for comparison of two independent classifiers"
          dname <- if (!is.null(dat)) {
              paste(c(levels(dat[, 1]), "of", names(dat)[2], " and ", 
                  levels(dat[, 1]), "of", names(dat)[3]), collapse = " ")
          }
          else {
              paste(deparse(substitute(x1)), deparse(substitute(y1)), 
                  deparse(substitute(z1)), "and", deparse(substitute(x2)), 
                  deparse(substitute(y2)), deparse(substitute(z2)))
          }
      }
      mux1 <- mean(x.1)
      sdx1 <- SD(x.1)
      muy1 <- mean(y.1)
      sdy1 <- SD(y.1)
      muz1 <- mean(z.1)
      sdz1 <- SD(z.1)
      nh1 <- length(x.1)
      nh2 <- length(x.2)
      n01 <- length(y.1)
      n02 <- length(y.2)
      nd1 <- length(z.1)
      nd2 <- length(z.2)
      if (nh1 < 2 || n01 < 2 || nd1 < 2) 
          stop("not enough observations (you need at least two observations in each class).")
      summary.dat <- data.frame(n = c(nh1, n01, nd1), mu = c(mux1, 
          muy1, muz1), sd = c(sdx1, sdy1, sdz1), row.names = c("healthy", 
          "intermediate", "diseased"))
      if (any(c(sdx1, sdy1, sdz1) < 10 * .Machine$double.eps * 
          abs(c(mux1, muy1, muz1)))) 
          stop("data of Classifier 1 is essentially constant")
      mux2 <- 0
      sdx2 <- 0
      muy2 <- 0
      sdy2 <- 0
      muz2 <- 0
      sdz2 <- 0
      if (twocurves) {
          mux2 <- mean(x.2)
          sdx2 <- SD(x.2)
          muy2 <- mean(y.2)
          sdy2 <- SD(y.2)
          muz2 <- mean(z.2)
          sdz2 <- SD(z.2)
          if (any(c(sdx2, sdy2, sdz2) < 10 * .Machine$double.eps * 
              abs(c(mux2, muy2, muz2)))) 
              stop("data of Classifier 2 is essentially constant")
          summary.dat2 <- data.frame(n = c(nh2, n02, nd2), mu = c(mux2, 
              muy2, muz2), sd = c(sdx2, sdy2, sdz2), row.names = c("healthy", 
              "intermediate", "diseased"))
          summary.dat <- list(Classifier1 = summary.dat, Classifier2 = summary.dat2)
      }
      rho.h <- 0
      rho.0 <- 0
      rho.d <- 0
      if (paired) {
          rho.h <- COV(x.1, x.2)/(sdx1 * sdx2)
          rho.0 <- COV(y.1, y.2)/(sdy1 * sdy2)
          rho.d <- COV(z.1, z.2)/(sdz1 * sdz2)
          method <- "Trinormal based ROC test for comparison of paired ROC surfaces"
      }
      A1 <- sdy1/sdx1
      B1 <- (mux1 - muy1)/sdx1
      C1 <- sdy1/sdz1
      D1 <- (muz1 - muy1)/sdz1
      A2 <- 1
      B2 <- 0
      C2 <- 1
      D2 <- 0
      if (twocurves) {
          A2 <- sdy2/sdx2
          B2 <- (mux2 - muy2)/sdx2
          C2 <- sdy2/sdz2
          D2 <- (muz2 - muy2)/sdz2
      }
      varA <- (A1^2/2) * (1/n01 + 1/nh1) + twocurves * ((A2^2/2) * 
          (1/n02 + 1/nh2)) - paired * (A1 * A2 * rho.0^2/n01 + 
          A1 * A2 * rho.h^2/nh1)
      varB <- A1^2/n01 + 1/nh1 + B1^2/(2 * nh1) + twocurves * (A2^2/n02 + 
          1/nh2 + B2^2/(2 * nh2)) - paired * 2 * (A1 * A2 * rho.0/n01 + 
          rho.h/nh1 + B1 * B2 * rho.h^2/(2 * nh1))
      varC <- (C1^2/2) * (1/nd1 + 1/n01) + twocurves * ((C2^2/2) * 
          (1/nd2 + 1/n02)) - paired * (C1 * C2 * rho.0^2/n01 + 
          C1 * C2 * rho.d^2/nd1)
      varD <- C1^2/n01 + 1/nd1 + D1^2/(2 * nd1) + twocurves * (C2^2/n02 + 
          1/nd2 + D2^2/(2 * nd2)) - paired * 2 * (C1 * C2 * rho.0/n01 + 
          rho.d/nd1 + D1 * D2 * rho.d^2/(2 * nd1))
      covAB <- A1 * B1/(2 * nh1) + twocurves * (A2 * B2/(2 * nh2)) - 
          paired * (A1 * B2 * rho.h^2/(2 * nh1) + A2 * B1 * rho.h^2/(2 * 
              nh1))
      covAC <- A1 * C1/(2 * n01) + twocurves * (A2 * C2/(2 * n02)) - 
          paired * (A1 * C2 * rho.0^2/(2 * n01) + A2 * C1 * rho.0^2/(2 * 
              n01))
      covAD <- 0
      covBC <- 0
      covBD <- A1 * C1/n01 + twocurves * (A2 * C2/n02) - paired * 
          (A1 * C2 * rho.0/n01 + A2 * C1 * rho.0/n01)
      covCD <- C1 * D1/(2 * nd1) + twocurves * (C2 * D2/(2 * nd2)) - 
          paired * (C2 * D1 * rho.d^2/(2 * nd1) + C1 * D2 * rho.d^2/(2 * 
              nd1))
      covariance <- matrix(c(varA, covAB, covAC, covAD, covAB, 
          varB, covBC, covBD, covAC, covBC, varC, covCD, covAD, 
          covBD, covCD, varD), 4, 4)
      if (class(try(solve(covariance), silent = T)) != "matrix") {
          chi2 <- 0
          print("matrix is not invertible. Conclude complete alikeness.")
      }
      else {
          test <- t(c(A1 - A2, B1 - B2, C1 - C2, D1 - D2)) %*% 
              solve(covariance) %*% c(A1 - A2, B1 - B2, C1 - C2, 
              D1 - D2)
          chi2 <- as.numeric(test)
      }
      vus.1 <- 0
      vus.2 <- 1/6
      dvus1 <- function(x) {
          pnorm(A1 * x - B1) * pnorm(-C1 * x + D1) * dnorm(x)
      }
      vus.1 <- integrate(dvus1, -Inf, Inf)$value
      if (twocurves) {
          dvus2 <- function(x) {
              pnorm(A2 * x - B2) * pnorm(-C2 * x + D2) * dnorm(x)
          }
          vus.2 <- integrate(dvus2, -Inf, Inf)$value
      }
      df <- 4
      names(df) <- "df"
      names(chi2) <- "Chi-Squared test"
      mekro.p <- pchisq(chi2, df, lower.tail = FALSE)
      cint <- c(0, qchisq(conf.level, df))
      attr(cint, "conf.level") <- conf.level
      param <- as.data.frame(matrix(c(vus.1, A1, B1, C1, D1), nrow = 1))
      colnames(param) <- c("VUS", "a", "b", "c", "d")
      rownames(param) <- "Classifier1:"
      if (twocurves) {
          param[2, ] <- c(vus.2, A2, B2, C2, D2)
          rownames(param)[2] <- "Classifier2:"
      }
      if (!is.null(dat)) {
          rownames(param)[1] <- names(dat)[2]
          if (class(summary.dat) == "list") 
              names(summary.dat)[1] <- names(dat)[2]
          if (ncol(dat) > 2) {
              rownames(param)[2] <- names(dat)[3]
              names(summary.dat)[2] <- names(dat)[3]
          }
      }
      null.value <- 0
      names(null.value) <- "a1-a2, b1-b1, c1-c2 and d1-d2"
      rval <- list(statistic = chi2, parameter = df, p.value = unname(mekro.p), 
          conf.int = NULL, estimate = param, null.value = null.value, 
          alternative = alternative, method = method, data.name = dname, 
          CovMat = covariance, Summary = summary.dat)
      class(rval) <- "htest"
      return(rval)
  }
  <bytecode: 0x561cb7db9338>
  <environment: namespace:trinROC>
   --- function search by body ---
  Function trinROC.test in namespace trinROC has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1