Running 'testthat.R' [26s/31s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
  > library(testthat)
  > library(cutpointr)
  > 
  > test_check("cutpointr")
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide)
  where 6 at testthat/test-cutpointr.R#7: cutpointr(suicide, dsi, suicide)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#5: test_that("Cutpointr returns a cutpointr without NAs and a certain Nr of rows", 
      {
          data(suicide)
          opt_cut <- cutpointr(suicide, dsi, suicide)
          expect_true("cutpointr" %in% class(opt_cut))
          expect_that(nrow(opt_cut), equals(1))
          expect_that(sum(is.na(opt_cut)), equals(1))
          expect_silent(plot(opt_cut))
          expect_silent(print(plot_metric(opt_cut)))
          expect_silent(print(plot_roc(opt_cut)))
          expect_silent(print(plot_x(opt_cut)))
          expect_silent(print(plot_precision_recall(opt_cut)))
          expect_silent(print(plot_sensitivity_specificity(opt_cut)))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 1. Error: Cutpointr returns a cutpointr without NAs and a certain Nr of rows 
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y)
  where 6 at testthat/test-cutpointr.R#23: cutpointr(tempdat, x, y)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#19: test_that("Cutpointr works with different data types", {
      set.seed(456)
      tempdat <- data.frame(x = rnorm(10), y = sample(0:1, size = 10, 
          replace = TRUE))
      opt_cut <- cutpointr(tempdat, x, y)
      expect_that(nrow(opt_cut), equals(1))
      expect_that(sum(is.na(opt_cut)), equals(1))
      expect_silent(plot(opt_cut))
      tempdat$y <- factor(tempdat$y)
      opt_cut <- cutpointr(tempdat, x, y)
      expect_that(nrow(opt_cut), equals(1))
      expect_that(sum(is.na(opt_cut)), equals(1))
      expect_silent(plot(opt_cut))
      tempdat$y <- as.character(tempdat$y)
      opt_cut <- cutpointr(tempdat, x, y)
      expect_that(nrow(opt_cut), equals(1))
      expect_that(sum(is.na(opt_cut)), equals(1))
      expect_silent(plot(opt_cut))
      set.seed(567)
      tempdat <- data.frame(x = rnorm(30), y = sample(0:1, size = 30, 
          replace = TRUE), g = sample(0:2, size = 30, replace = TRUE))
      opt_cut <- cutpointr(tempdat, x, y, g)
      expect_that(nrow(opt_cut), equals(3))
      expect_that(sum(is.na(opt_cut)), equals(3))
      expect_silent(plot(opt_cut))
      expect_silent(print(plot_metric(opt_cut)))
      expect_silent(print(plot_roc(opt_cut)))
      expect_silent(print(plot_x(opt_cut)))
      expect_silent(print(plot_precision_recall(opt_cut)))
      expect_silent(print(plot_sensitivity_specificity(opt_cut)))
      tempdat$g <- factor(tempdat$g)
      opt_cut <- cutpointr(tempdat, x, y, g)
      expect_that(nrow(opt_cut), equals(3))
      expect_that(sum(is.na(opt_cut)), equals(3))
      expect_silent(plot(opt_cut))
      expect_silent(print(plot_metric(opt_cut)))
      expect_silent(print(plot_roc(opt_cut)))
      expect_silent(print(plot_x(opt_cut)))
      expect_silent(print(plot_precision_recall(opt_cut)))
      expect_silent(print(plot_sensitivity_specificity(opt_cut)))
      tempdat$g <- as.character(tempdat$g)
      opt_cut <- cutpointr(tempdat, x, y, g)
      expect_that(nrow(opt_cut), equals(3))
      expect_that(sum(is.na(opt_cut)), equals(3))
      expect_silent(plot(opt_cut))
      expect_silent(print(plot_metric(opt_cut)))
      expect_silent(print(plot_roc(opt_cut)))
      expect_silent(print(plot_x(opt_cut)))
      expect_silent(print(plot_precision_recall(opt_cut)))
      expect_silent(print(plot_sensitivity_specificity(opt_cut)))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 2. Error: Cutpointr works with different data types (@test-cutpointr.R#23)  -
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y)
   2. cutpointr:::cutpointr.default(tempdat, x, y)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, boot_runs = 20)
  where 6 at testthat/test-cutpointr.R#82: cutpointr(tempdat, x, y, boot_runs = 20)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#78: test_that("Bootstrap does not return duplicate colnames", {
      set.seed(456)
      tempdat <- data.frame(x = rnorm(100), y = sample(0:1, size = 100, 
          replace = TRUE))
      opt_cut <- cutpointr(tempdat, x, y, boot_runs = 20)
      expect_true(all(table(colnames(opt_cut$boot[[1]])) == 1))
      set.seed(123)
      tempdat <- data.frame(x = rnorm(300), y = sample(0:1, size = 300, 
          replace = TRUE), g = sample(0:2, size = 300, replace = TRUE))
      opt_cut <- cutpointr(tempdat, x, y, g, boot_runs = 20)
      expect_true(all(table(colnames(opt_cut$boot[[1]])) == 1))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 3. Error: Bootstrap does not return duplicate colnames (@test-cutpointr.R#82)
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y, boot_runs = 20)
   2. cutpointr:::cutpointr.default(tempdat, x, y, boot_runs = 20)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, boot_runs = 20)
  where 6 at testthat/test-cutpointr.R#98: cutpointr(tempdat, x, y, boot_runs = 20)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#94: test_that("Plotting with bootstrapping is silent", {
      set.seed(456)
      tempdat <- data.frame(x = rnorm(100), y = sample(0:1, size = 100, 
          replace = TRUE))
      opt_cut <- cutpointr(tempdat, x, y, boot_runs = 20)
      expect_silent(plot(opt_cut))
      expect_silent(print(plot_metric(opt_cut)))
      expect_silent(print(plot_roc(opt_cut)))
      expect_silent(print(plot_cut_boot(opt_cut)))
      expect_silent(print(plot_metric_boot(opt_cut)))
      expect_silent(print(plot_x(opt_cut)))
      expect_silent(print(plot_precision_recall(opt_cut)))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 4. Error: Plotting with bootstrapping is silent (@test-cutpointr.R#98)  -----
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y, boot_runs = 20)
   2. cutpointr:::cutpointr.default(tempdat, x, y, boot_runs = 20)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y)
  where 6 at testthat/test-cutpointr.R#115: cutpointr(tempdat, x, y)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#109: test_that("AUC calculation is correct and works with Inf and -Inf", 
      {
          tempdat <- data.frame(x = c(-Inf, 0.3, Inf), y = factor(c(0, 
              1, 1)))
          roc_cutpointr <- cutpointr::roc(tempdat, x, y, pos_class = 1, 
              neg_class = 0)
          auc_cutpointr <- cutpointr::auc(roc_cutpointr)
          expect_equal(auc_cutpointr, 1)
          cp <- cutpointr(tempdat, x, y)
          expect_equal(cp$AUC, 1)
          set.seed(123)
          tempdat <- data.frame(x = rnorm(100), y = factor(c(rep(0, 
              50), rep(1, 50))))
          roc_cutpointr <- cutpointr::roc(tempdat, x, y, pos_class = 1, 
              neg_class = 0)
          auc_cutpointr <- cutpointr::auc(roc_cutpointr)
          expect_equal(round(auc_cutpointr, 3), 0.541)
          cp <- cutpointr(tempdat, x, y, pos_class = 1, direction = ">=")
          expect_equal(round(cp$AUC, 3), 0.541)
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 5. Error: AUC calculation is correct and works with Inf and -Inf (@test-cutpo
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y)
   2. cutpointr:::cutpointr.default(tempdat, x, y)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(temp, x, y, use_midpoints = TRUE, pos_class = 1)
  where 6 at testthat/test-cutpointr.R#139: cutpointr(temp, x, y, use_midpoints = TRUE, pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#137: test_that("Correct midpoints are found", {
      temp <- data.frame(x = c(-Inf, 1, 2, 3, 5, Inf), y = c(1, 
          1, 1, 0, 0, 0))
      optcut <- cutpointr(temp, x, y, use_midpoints = TRUE, pos_class = 1)
      expect_equal(optcut$optimal_cutpoint, 2.5)
      expect_warning(plot(optcut))
      optcut <- cutpointr(temp, x, y, use_midpoints = TRUE, pos_class = 0)
      expect_equal(optcut$optimal_cutpoint, 2.5)
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 6. Error: Correct midpoints are found (@test-cutpointr.R#139)  --------------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(temp, x, y, use_midpoints = TRUE, pos_class = 1)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = maximize_metric, metric = youden)
  where 6 at testthat/test-cutpointr.R#150: cutpointr(tempdat, x, y, method = maximize_metric, metric = youden)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#146: test_that("find_metric_name finds metric", {
      set.seed(123)
      tempdat <- data.frame(x = runif(100), y = factor(sample(0:1, 
          size = 100, replace = TRUE)))
      optcut <- cutpointr(tempdat, x, y, method = maximize_metric, 
          metric = youden)
      expect_equal(cutpointr:::find_metric_name(optcut), "youden")
      set.seed(1234)
      tempdat <- data.frame(x = runif(100), y = factor(sample(0:1, 
          size = 100, replace = TRUE)), g = factor(sample(0:1, 
          size = 100, replace = TRUE)))
      optcut <- cutpointr(tempdat, x, y, g, method = maximize_metric, 
          metric = youden)
      expect_equal(cutpointr:::find_metric_name(optcut), "youden")
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 7. Error: find_metric_name finds metric (@test-cutpointr.R#150)  ------------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y)
  where 6 at testthat/test-cutpointr.R#172: cutpointr(tempdat, x, y)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#160: test_that("no duplicate column names are returned", {
      set.seed(123)
      tempdat <- data.frame(x = runif(100), y = factor(sample(0:1, 
          size = 100, replace = TRUE)))
      optcut <- cutpointr(tempdat, x, y, method = oc_youden_normal)
      expect_true(all(table(colnames(optcut)) == 1))
      expect_silent(plot(optcut))
      if (require(fANCOVA)) {
          optcut <- cutpointr(tempdat, x, y, method = oc_youden_kernel)
          expect_true(all(table(colnames(optcut)) == 1))
          expect_silent(plot(optcut))
      }
      optcut <- cutpointr(tempdat, x, y)
      expect_true(all(table(colnames(optcut)) == 1))
      expect_silent(plot(optcut))
      optcut <- cutpointr(tempdat, x, y, method = oc_manual, cutpoint = 30)
      expect_true(all(table(colnames(optcut)) == 1))
      expect_silent(plot(optcut))
      set.seed(1234)
      tempdat <- data.frame(x = rnorm(100), y = factor(sample(0:1, 
          size = 100, replace = TRUE)), g = factor(sample(0:1, 
          size = 100, replace = TRUE)))
      optcut <- cutpointr(tempdat, x, y, g, method = oc_youden_normal)
      expect_true(all(table(colnames(optcut)) == 1))
      expect_silent(plot(optcut))
      if (require(fANCOVA)) {
          optcut <- cutpointr(tempdat, x, y, g, method = oc_youden_kernel)
          expect_true(all(table(colnames(optcut)) == 1))
          expect_silent(plot(optcut))
      }
      optcut <- cutpointr(tempdat, x, y, g)
      expect_true(all(table(colnames(optcut)) == 1))
      expect_silent(plot(optcut))
      optcut <- cutpointr(tempdat, x, y, g, method = oc_manual, 
          cutpoint = 30)
      expect_true(all(table(colnames(optcut)) == 1))
      expect_silent(plot(optcut))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 8. Error: no duplicate column names are returned (@test-cutpointr.R#172)  ---
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y)
   2. cutpointr:::cutpointr.default(tempdat, x, y)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "min", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(exdat, preds, obs, method = minimize_metric, 
      metric = abs_d_sens_spec)
  where 6 at testthat/test-cutpointr.R#202: cutpointr(exdat, preds, obs, method = minimize_metric, metric = abs_d_sens_spec)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#199: test_that("Correct cutpoints with example data", {
      exdat <- data.frame(obs = c(0, 0, 1, 1), preds = c(0, 0, 
          1, 1))
      optcut <- cutpointr(exdat, preds, obs, method = minimize_metric, 
          metric = abs_d_sens_spec)
      expect_equal(optcut$optimal_cutpoint, 1)
      optcut <- cutpointr(exdat, preds, obs, method = maximize_metric, 
          metric = accuracy)
      expect_equal(optcut$optimal_cutpoint, 1)
      optcut <- cutpointr(exdat, preds, obs, method = maximize_metric, 
          metric = youden)
      expect_equal(optcut$optimal_cutpoint, 1)
      exdat <- data.frame(obs = c(NA, 0, 0, 1, 1), preds = c(1, 
          0, 0, 1, 1))
      expect_error(cutpointr(exdat, preds, obs, method = minimize_metric, 
          metric = abs_d_sens_spec))
      optcut <- cutpointr(exdat, preds, obs, method = minimize_metric, 
          metric = abs_d_sens_spec, na.rm = T)
      expect_equal(optcut$optimal_cutpoint, 1)
      expect_silent(plot(optcut))
      optcut <- cutpointr(exdat, preds, obs, method = maximize_metric, 
          metric = accuracy, na.rm = T)
      expect_equal(optcut$optimal_cutpoint, 1)
      expect_silent(plot(optcut))
      optcut <- cutpointr(exdat, preds, obs, method = maximize_metric, 
          metric = youden, na.rm = T)
      expect_equal(optcut$optimal_cutpoint, 1)
      expect_silent(plot(optcut))
      exdat <- data.frame(obs = c(rep(0, 20), 1, 1, 1, 1, 0, 0, 
          0, 0), preds = c(rep(-Inf, 10), rep(Inf, 10), 0, 0, 0, 
          0, 1, 1, 1, 1))
      optcut <- cutpointr(exdat, preds, obs, method = maximize_metric, 
          metric = cutpointr::youden)
      expect_equal(optcut$optimal_cutpoint, 1)
      expect_equal(optcut$specificity, 1)
      expect_equal(round(optcut$sensitivity, 2), 0.58)
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 9. Error: Correct cutpoints with example data (@test-cutpointr.R#202)  ------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, metric = metricfunc, 
      boot_runs = 5)
  where 6 at testthat/test-cutpointr.R#250: cutpointr(suicide, dsi, suicide, metric = metricfunc, boot_runs = 5)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#244: test_that("Metric colnames that are already in cutpointr are modified", 
      {
          metricfunc <- function(tp, fp, tn, fn) {
              res <- matrix(1:length(tp), ncol = 1)
              colnames(res) <- "sensitivity"
              return(res)
          }
          opt_cut <- cutpointr(suicide, dsi, suicide, metric = metricfunc, 
              boot_runs = 5)
          expect_equal(colnames(opt_cut)[4], "metric_sensitivity")
          expect_silent(plot(opt_cut))
          expect_silent(summary(opt_cut))
          opt_cut <- cutpointr(suicide, dsi, suicide, gender, metric = metricfunc, 
              boot_runs = 5)
          expect_equal(colnames(opt_cut)[5], "metric_sensitivity")
          expect_silent(plot(opt_cut))
          expect_silent(summary(opt_cut))
          metricfunc <- function(tp, fp, tn, fn) {
              res <- matrix(1:length(tp), ncol = 1)
              colnames(res) <- "AUC"
              return(res)
          }
          opt_cut <- cutpointr(suicide, dsi, suicide, metric = metricfunc, 
              boot_runs = 5)
          expect_equal(colnames(opt_cut)[4], "metric_AUC")
          expect_silent(plot(opt_cut))
          expect_silent(summary(opt_cut))
          opt_cut <- cutpointr(suicide, dsi, suicide, gender, metric = metricfunc, 
              boot_runs = 5)
          expect_equal(colnames(opt_cut)[5], "metric_AUC")
          expect_silent(plot(opt_cut))
          expect_silent(summary(opt_cut))
          metricfunc <- function(tp, fp, tn, fn) {
              res <- matrix(1:length(tp), ncol = 1)
              colnames(res) <- "roc_curve"
              return(res)
          }
          expect_error(cutpointr(suicide, dsi, suicide, metric = metricfunc, 
              boot_runs = 5))
          expect_error(cutpointr(suicide, dsi, suicide, gender, 
              metric = metricfunc, boot_runs = 5))
          opt_cut <- cutpointr(suicide, dsi, suicide, method = oc_youden_normal, 
              metric = metricfunc, boot_runs = 5)
          expect_equal(colnames(opt_cut)[4], "metric_roc_curve")
          expect_silent(plot(opt_cut))
          expect_silent(summary(opt_cut))
          opt_cut <- cutpointr(suicide, dsi, suicide, gender, method = oc_youden_normal, 
              metric = metricfunc, boot_runs = 5)
          expect_equal(colnames(opt_cut)[5], "metric_roc_curve")
          expect_silent(plot(opt_cut))
          expect_silent(summary(opt_cut))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 10. Error: Metric colnames that are already in cutpointr are modified (@test-
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide)
  where 6 at testthat/test-cutpointr.R#301: cutpointr(suicide, dsi, suicide)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#300: test_that("SE and NSE interface give identical results", {
      opt_cut_nse <- cutpointr(suicide, dsi, suicide)
      opt_cut_se <- suppressWarnings(cutpointr_(suicide, "dsi", 
          "suicide"))
      expect_identical(opt_cut_se, opt_cut_nse)
      opt_cut_nse <- cutpointr(suicide, dsi, suicide)
      opt_cut_se <- suppressWarnings(cutpointr_(suicide, "dsi", 
          "suicide", method = maximize_metric))
      expect_identical(opt_cut_se, opt_cut_nse)
      opt_cut_nse <- cutpointr(suicide, dsi, suicide, gender)
      opt_cut_se <- suppressWarnings(cutpointr_(suicide, "dsi", 
          "suicide", "gender"))
      expect_identical(opt_cut_se, opt_cut_nse)
      opt_cut_nse <- cutpointr(suicide, dsi, suicide, gender)
      opt_cut_se <- suppressWarnings(cutpointr_(suicide, "dsi", 
          "suicide", "gender"))
      expect_identical(opt_cut_se, opt_cut_nse)
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 11. Error: SE and NSE interface give identical results (@test-cutpointr.R#301
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, boot_runs = 50, break_ties = mean)
  where 6: cutpointr(suicide, dsi, suicide, boot_runs = 50, break_ties = mean)
  where 7: withCallingHandlers(expr, warning = function(w) invokeRestart("muffleWarning"))
  where 8 at testthat/test-cutpointr.R#333: suppressWarnings(cutpointr(suicide, dsi, suicide, boot_runs = 50, 
      break_ties = mean))
  where 9: eval(code, test_env)
  where 10: eval(code, test_env)
  where 11: 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 12: doTryCatch(return(expr), name, parentenv, handler)
  where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 17: tryCatchList(expr, classes, parentenv, handlers)
  where 18: 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 19: test_code(desc, code, env = parent.frame())
  where 20 at testthat/test-cutpointr.R#331: test_that("Bootstrap returns plausible results", {
      set.seed(123)
      opt_cut <- suppressWarnings(cutpointr(suicide, dsi, suicide, 
          boot_runs = 50, break_ties = mean))
      expect_true(mean(opt_cut$boot[[1]]$sum_sens_spec_b) > 1.3 & 
          mean(opt_cut$boot[[1]]$sum_sens_spec_b) < 3)
      expect_true(sd(opt_cut$boot[[1]]$sum_sens_spec_b) > 0.02 & 
          sd(opt_cut$boot[[1]]$sum_sens_spec_b) < 1)
      expect_true(mean(opt_cut$boot[[1]]$sum_sens_spec_oob) > 1.3 & 
          mean(opt_cut$boot[[1]]$sum_sens_spec_oob) < 3)
      expect_true(sd(opt_cut$boot[[1]]$sum_sens_spec_oob) > 0.02 & 
          sd(opt_cut$boot[[1]]$sum_sens_spec_oob) < 1)
      set.seed(123)
      opt_cut <- suppressWarnings(cutpointr(suicide, dsi, suicide, 
          boot_runs = 30, direction = "<="))
      expect_true(mean(opt_cut$boot[[1]]$sum_sens_spec_b) > 1.3 & 
          mean(opt_cut$boot[[1]]$sum_sens_spec_b) < 3)
      expect_true(sd(opt_cut$boot[[1]]$sum_sens_spec_b) > 0.02 & 
          sd(opt_cut$boot[[1]]$sum_sens_spec_b) < 1)
      expect_true(mean(opt_cut$boot[[1]]$sum_sens_spec_oob) > 1.3 & 
          mean(opt_cut$boot[[1]]$sum_sens_spec_oob) < 3)
      expect_true(sd(opt_cut$boot[[1]]$sum_sens_spec_oob) > 0.02 & 
          sd(opt_cut$boot[[1]]$sum_sens_spec_oob) < 1)
      set.seed(123)
      opt_cut <- suppressWarnings(cutpointr(suicide, dsi, suicide, 
          boot_runs = 30, pos_class = "no"))
      expect_true(mean(opt_cut$boot[[1]]$sum_sens_spec_b) > 1.3 & 
          mean(opt_cut$boot[[1]]$sum_sens_spec_b) < 3)
      expect_true(sd(opt_cut$boot[[1]]$sum_sens_spec_b) > 0.02 & 
          sd(opt_cut$boot[[1]]$sum_sens_spec_b) < 1)
      expect_true(mean(opt_cut$boot[[1]]$sum_sens_spec_oob) > 1.3 & 
          mean(opt_cut$boot[[1]]$sum_sens_spec_oob) < 3)
      expect_true(sd(opt_cut$boot[[1]]$sum_sens_spec_oob) > 0.02 & 
          sd(opt_cut$boot[[1]]$sum_sens_spec_oob) < 1)
  })
  where 21: eval(code, test_env)
  where 22: eval(code, test_env)
  where 23: 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 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 29: tryCatchList(expr, classes, parentenv, handlers)
  where 30: 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 31: test_code(NULL, exprs, env)
  where 32: source_file(path, new.env(parent = env), chdir = TRUE, 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 = 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 38: FUN(X[[i]], ...)
  where 39: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 40: force(code)
  where 41: doWithOneRestart(return(expr), restart)
  where 42: withOneRestart(expr, restarts[[1L]])
  where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 44: 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 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 46: 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 47: 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 48: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 12. Error: Bootstrap returns plausible results (@test-cutpointr.R#333)  -----
  the condition has length > 1
  Backtrace:
   1. base::suppressWarnings(...)
   4. cutpointr:::cutpointr.default(...)
   5. cutpointr:::cutpointr_internal(...)
   6. cutpointr:::method(...)
   7. cutpointr:::optimize_metric(...)
   8. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide)
  where 6 at testthat/test-cutpointr.R#372: cutpointr(suicide, dsi, suicide)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#369: test_that("Summary by class returns correct stats", {
      digits <- 3
      oc <- cutpointr(suicide, dsi, suicide)
      s <- summary(oc)
      my <- round(mean(suicide[suicide$suicide == "yes", "dsi"]), 
          digits)
      expect_equal(s$desc_by_class[[1]]["yes", "Mean"], my, tolerance = 0.001)
      mn <- round(mean(suicide[suicide$suicide == "no", "dsi"]), 
          digits)
      expect_equal(s$desc_by_class[[1]]["no", "Mean"], mn)
      tempdat <- suicide
      tempdat[10, 1] <- NA
      tempdat[20, 2] <- NA
      tempdat[30, 3] <- NA
      tempdat[40, 4] <- NA
      oc <- cutpointr(tempdat, dsi, suicide, na.rm = TRUE)
      s <- summary(oc)
      my <- round(mean(tempdat[tempdat$suicide == "yes", "dsi"], 
          na.rm = TRUE), digits)
      expect_equal(s$desc_by_class[[1]]["yes", "Mean"], my, tolerance = 0.001)
      mn <- round(mean(tempdat[tempdat$suicide == "no", "dsi"], 
          na.rm = TRUE), digits)
      expect_equal(s$desc_by_class[[1]]["no", "Mean"], mn)
      oc <- cutpointr(suicide, dsi, suicide, gender)
      s <- summary(oc)
      myf <- round(mean(suicide[suicide$suicide == "yes" & suicide$gender == 
          "female", "dsi"]), digits)
      expect_equal(s$desc_by_class[[1]]["yes", "Mean"], myf, tolerance = 0.001)
      mnf <- round(mean(suicide[suicide$suicide == "no" & suicide$gender == 
          "female", "dsi"]), digits)
      expect_equal(s$desc_by_class[[1]]["no", "Mean"], mnf)
      mym <- round(mean(suicide[suicide$suicide == "yes" & suicide$gender == 
          "male", "dsi"]), digits)
      expect_equal(s$desc_by_class[[2]]["yes", "Mean"], mym, tolerance = 0.001)
      mnm <- round(mean(suicide[suicide$suicide == "no" & suicide$gender == 
          "male", "dsi"]), digits)
      expect_equal(s$desc_by_class[[2]]["no", "Mean"], mnm)
      tempdat <- suicide
      tempdat[10, 1] <- NA
      tempdat[20, 2] <- NA
      tempdat[30, 3] <- NA
      tempdat[40, 4] <- NA
      oc <- cutpointr(tempdat, dsi, suicide, gender, na.rm = TRUE)
      s <- summary(oc)
      myf <- round(mean(tempdat[tempdat$suicide == "yes" & tempdat$gender == 
          "female", "dsi"], na.rm = TRUE), digits)
      expect_equal(s$desc_by_class[[1]]["yes", "Mean"], myf, tolerance = 0.001)
      mnf <- round(mean(tempdat[tempdat$suicide == "no" & tempdat$gender == 
          "female", "dsi"], na.rm = TRUE), digits)
      expect_equal(s$desc_by_class[[1]]["no", "Mean"], mnf)
      mym <- round(mean(tempdat[tempdat$suicide == "yes" & tempdat$gender == 
          "male", "dsi"], na.rm = TRUE), digits)
      expect_equal(s$desc_by_class[[2]]["yes", "Mean"], mym, tolerance = 0.001)
      mnm <- round(mean(tempdat[tempdat$suicide == "no" & tempdat$gender == 
          "male", "dsi"], na.rm = TRUE), digits)
      expect_equal(s$desc_by_class[[2]]["no", "Mean"], mnm)
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 13. Error: Summary by class returns correct stats (@test-cutpointr.R#372)  --
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, metric = youden)
  where 6 at testthat/test-cutpointr.R#423: cutpointr(suicide, dsi, suicide, metric = youden)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#422: test_that("Results for youden are correct", {
      opt_cut_cp <- cutpointr(suicide, dsi, suicide, metric = youden)
      expect_equal(opt_cut_cp$optimal_cutpoint, 2)
      opt_cut_cp <- cutpointr(suicide, dsi, suicide, gender, metric = youden)
      expect_equal(opt_cut_cp$optimal_cutpoint, c(2, 3))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 14. Error: Results for youden are correct (@test-cutpointr.R#423)  ----------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide, metric = youden)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide, metric = youden)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "min", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = minimize_metric, metric = p_chisquared, 
      direction = ">=", pos_class = 1, tol_metric = 0)
  where 6: cutpointr(tempdat, x, y, method = minimize_metric, metric = p_chisquared, 
      direction = ">=", pos_class = 1, tol_metric = 0)
  where 7: withCallingHandlers(expr, warning = function(w) invokeRestart("muffleWarning"))
  where 8 at testthat/test-cutpointr.R#436: suppressWarnings(opt_cut_cp <- cutpointr(tempdat, x, y, method = minimize_metric, 
      metric = p_chisquared, direction = ">=", pos_class = 1, tol_metric = 0))
  where 9: eval(code, test_env)
  where 10: eval(code, test_env)
  where 11: 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 12: doTryCatch(return(expr), name, parentenv, handler)
  where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 17: tryCatchList(expr, classes, parentenv, handlers)
  where 18: 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 19: test_code(desc, code, env = parent.frame())
  where 20 at testthat/test-cutpointr.R#430: test_that("Results for p_chisquared are equal to results by OptimalCutpoints", 
      {
          suppressWarnings(RNGversion("3.5.0"))
          set.seed(2839)
          tempdat <- data.frame(x = c(rnorm(50), rnorm(50, mean = 1)), 
              y = c(rep(0, 50), rep(1, 50)), group = sample(c("a", 
                  "b"), size = 100, replace = TRUE))
          suppressWarnings(opt_cut_cp <- cutpointr(tempdat, x, 
              y, method = minimize_metric, metric = p_chisquared, 
              direction = ">=", pos_class = 1, tol_metric = 0))
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 0.9335)
          suppressWarnings(opt_cut_cp <- cutpointr(tempdat, x, 
              y, group, method = minimize_metric, metric = p_chisquared, 
              direction = ">=", pos_class = 1, tol_metric = 0))
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(0.9335, 
              0.5676))
      })
  where 21: eval(code, test_env)
  where 22: eval(code, test_env)
  where 23: 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 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 29: tryCatchList(expr, classes, parentenv, handlers)
  where 30: 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 31: test_code(NULL, exprs, env)
  where 32: source_file(path, new.env(parent = env), chdir = TRUE, 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 = 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 38: FUN(X[[i]], ...)
  where 39: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 40: force(code)
  where 41: doWithOneRestart(return(expr), restart)
  where 42: withOneRestart(expr, restarts[[1L]])
  where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 44: 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 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 46: 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 47: 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 48: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 15. Error: Results for p_chisquared are equal to results by OptimalCutpoints 
  the condition has length > 1
  Backtrace:
   1. base::suppressWarnings(...)
   4. cutpointr:::cutpointr.default(...)
   5. cutpointr:::cutpointr_internal(...)
   6. cutpointr:::method(...)
   7. cutpointr:::optimize_metric(...)
   8. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = maximize_metric, metric = prod_sens_spec, 
      direction = ">=", pos_class = 1)
  where 6 at testthat/test-cutpointr.R#457: cutpointr(tempdat, x, y, method = maximize_metric, metric = prod_sens_spec, 
      direction = ">=", pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#451: test_that("Results for prod_sens_spec are equal to results by OptimalCutpoints", 
      {
          set.seed(839)
          tempdat <- data.frame(x = c(rnorm(50), rnorm(50, mean = 1)), 
              y = c(rep(0, 50), rep(1, 50)), group = sample(c("a", 
                  "b"), size = 100, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, method = maximize_metric, 
              metric = prod_sens_spec, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 0.7783)
          opt_cut_cp <- cutpointr(tempdat, x, y, group, method = maximize_metric, 
              metric = prod_sens_spec, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(0.7998, 
              0.6371))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 16. Error: Results for prod_sens_spec are equal to results by OptimalCutpoint
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "min", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = minimize_metric, metric = abs_d_ppv_npv, 
      direction = ">=", pos_class = 1)
  where 6 at testthat/test-cutpointr.R#474: cutpointr(tempdat, x, y, method = minimize_metric, metric = abs_d_ppv_npv, 
      direction = ">=", pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#468: test_that("Results for abs_d_ppv_npv are equal to results by OptimalCutpoints", 
      {
          set.seed(389)
          tempdat <- data.frame(x = c(rnorm(50), rnorm(50, mean = 1)), 
              y = c(rep(0, 50), rep(1, 50)), group = sample(c("a", 
                  "b"), size = 100, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, method = minimize_metric, 
              metric = abs_d_ppv_npv, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 0.5677)
          opt_cut_cp <- cutpointr(tempdat, x, y, group, method = minimize_metric, 
              metric = abs_d_ppv_npv, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(0.2501, 
              0.6781))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 17. Error: Results for abs_d_ppv_npv are equal to results by OptimalCutpoints
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = maximize_metric, metric = sum_ppv_npv, 
      direction = ">=", pos_class = 1)
  where 6 at testthat/test-cutpointr.R#491: cutpointr(tempdat, x, y, method = maximize_metric, metric = sum_ppv_npv, 
      direction = ">=", pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#485: test_that("Results for sum_ppv_npv are equal to results by OptimalCutpoints", 
      {
          set.seed(389)
          tempdat <- data.frame(x = c(rnorm(50), rnorm(50, mean = 1)), 
              y = c(rep(0, 50), rep(1, 50)), group = sample(c("a", 
                  "b"), size = 100, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, method = maximize_metric, 
              metric = sum_ppv_npv, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 1.7835)
          opt_cut_cp <- cutpointr(tempdat, x, y, group, method = maximize_metric, 
              metric = sum_ppv_npv, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(-0.7339, 
              1.7835))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 18. Error: Results for sum_ppv_npv are equal to results by OptimalCutpoints (
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = maximize_metric, metric = prod_ppv_npv, 
      direction = ">=", pos_class = 1)
  where 6 at testthat/test-cutpointr.R#508: cutpointr(tempdat, x, y, method = maximize_metric, metric = prod_ppv_npv, 
      direction = ">=", pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#502: test_that("Results for prod_ppv_npv are equal to results by OptimalCutpoints", 
      {
          set.seed(389)
          tempdat <- data.frame(x = c(rnorm(50), rnorm(50, mean = 1)), 
              y = c(rep(0, 50), rep(1, 50)), group = sample(c("a", 
                  "b"), size = 100, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, method = maximize_metric, 
              metric = prod_ppv_npv, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 1.7835)
          opt_cut_cp <- cutpointr(tempdat, x, y, group, method = maximize_metric, 
              metric = prod_ppv_npv, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(-0.7339, 
              1.7835))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 19. Error: Results for prod_ppv_npv are equal to results by OptimalCutpoints 
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = maximize_metric, metric = accuracy, 
      direction = ">=", pos_class = 1)
  where 6 at testthat/test-cutpointr.R#525: cutpointr(tempdat, x, y, method = maximize_metric, metric = accuracy, 
      direction = ">=", pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#519: test_that("Results for accuracy are equal to results by OptimalCutpoints", 
      {
          set.seed(38429)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 1)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, method = maximize_metric, 
              metric = accuracy, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 0.4312)
          opt_cut_cp <- cutpointr(tempdat, x, y, group, method = maximize_metric, 
              metric = accuracy, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(0.9771, 
              0.0744))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 20. Error: Results for accuracy are equal to results by OptimalCutpoints (@te
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "min", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = minimize_metric, metric = roc01, 
      direction = ">=", pos_class = 1)
  where 6 at testthat/test-cutpointr.R#542: cutpointr(tempdat, x, y, method = minimize_metric, metric = roc01, 
      direction = ">=", pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#536: test_that("Results for roc01 are equal to results by OptimalCutpoints", 
      {
          set.seed(1957)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 1)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, method = minimize_metric, 
              metric = roc01, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 0.3255)
          opt_cut_cp <- cutpointr(tempdat, x, y, group, method = minimize_metric, 
              metric = roc01, direction = ">=", pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(0.5312, 
              0.3307))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 21. Error: Results for roc01 are equal to results by OptimalCutpoints (@test-
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, metric = sens_constrain, min_constrain = 0.85, 
      constrain_metric = specificity)
  where 6 at testthat/test-cutpointr.R#559: cutpointr(tempdat, x, y, metric = sens_constrain, min_constrain = 0.85, 
      constrain_metric = specificity)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#553: test_that("Results for constrained metrics are equal to results by OptimalCutpoints", 
      {
          set.seed(38129)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 1)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, metric = sens_constrain, 
              min_constrain = 0.85, constrain_metric = specificity)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 1.3018)
          expect_equal(round(opt_cut_cp$sens_constrain, 4), 0.44)
          expect_equal(round(opt_cut_cp$specificity, 4), 0.85)
          expect_equal(opt_cut_cp$sensitivity, opt_cut_cp$sens_constrain)
          opt_cut_cp <- cutpointr(tempdat, x, y, metric = spec_constrain, 
              min_constrain = 0.85, constrain_metric = sensitivity)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 0.2775)
          expect_equal(round(opt_cut_cp$spec_constrain, 4), 0.54)
          expect_equal(round(opt_cut_cp$sensitivity, 4), 0.85)
          expect_equal(opt_cut_cp$specificity, opt_cut_cp$spec_constrain)
          opt_cut_cp <- cutpointr(tempdat, x, y, metric = metric_constrain, 
              min_constrain = 0.85, constrain_metric = npv, main_metric = ppv) %>% 
              add_metric(list(npv, ppv))
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), 0.1435)
          expect_equal(round(opt_cut_cp$ppv_constrain, 4), 0.65)
          expect_equal(round(opt_cut_cp$npv, 4), 0.85)
          expect_equal(opt_cut_cp$ppv_constrain, opt_cut_cp$ppv)
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 22. Error: Results for constrained metrics are equal to results by OptimalCut
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = maximize_metric, metric = F1_score, 
      direction = ">=", pos_class = 1)
  where 6 at testthat/test-cutpointr.R#589: cutpointr(tempdat, x, y, method = maximize_metric, metric = F1_score, 
      direction = ">=", pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#583: test_that("Results for F1_score are equal to results by ROCR", 
      {
          set.seed(38429)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 1)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          f1_cp <- cutpointr(tempdat, x, y, method = maximize_metric, 
              metric = F1_score, direction = ">=", pos_class = 1)
          f1_rocr_yvals <- c(NaN, 0.0198, 0.0392, 0.0583, 0.0769, 
              0.0952, 0.1132, 0.1308, 0.1481, 0.1651, 0.1818, 0.1802, 
              0.1964, 0.2124, 0.2281, 0.2435, 0.2586, 0.2735, 0.2881, 
              0.3025, 0.3167, 0.314, 0.3279, 0.3252, 0.3387, 0.352, 
              0.3651, 0.378, 0.3906, 0.3876, 0.4, 0.4122, 0.4242, 
              0.4211, 0.4328, 0.4444, 0.4412, 0.4526, 0.4493, 0.4604, 
              0.4714, 0.4823, 0.4789, 0.4895, 0.5, 0.5103, 0.5205, 
              0.5306, 0.5405, 0.5503, 0.56, 0.5563, 0.5658, 0.5621, 
              0.5714, 0.5806, 0.5897, 0.586, 0.5949, 0.6038, 0.6, 
              0.5963, 0.6049, 0.6135, 0.6098, 0.6182, 0.6145, 0.6228, 
              0.631, 0.6391, 0.6353, 0.6433, 0.6395, 0.6474, 0.6437, 
              0.64, 0.6364, 0.6441, 0.6404, 0.648, 0.6444, 0.6409, 
              0.6374, 0.6448, 0.6522, 0.6486, 0.6559, 0.6524, 0.6489, 
              0.6561, 0.6526, 0.6597, 0.6667, 0.6736, 0.6804, 0.6872, 
              0.6837, 0.6802, 0.6869, 0.6935, 0.7, 0.6965, 0.703, 
              0.7094, 0.7059, 0.7024, 0.699, 0.7053, 0.7019, 0.6986, 
              0.6952, 0.7014, 0.7075, 0.7136, 0.7103, 0.7163, 0.713, 
              0.7097, 0.7156, 0.7123, 0.7091, 0.7149, 0.7207, 0.7175, 
              0.7232, 0.7289, 0.7257, 0.7225, 0.7193, 0.7162, 0.713, 
              0.71, 0.7069, 0.7124, 0.7179, 0.7234, 0.7288, 0.7257, 
              0.7227, 0.7197, 0.725, 0.722, 0.719, 0.716, 0.7131, 
              0.7184, 0.7154, 0.7126, 0.7097, 0.7149, 0.712, 0.7092, 
              0.7063, 0.7115, 0.7087, 0.7059, 0.7109, 0.7082, 0.7132, 
              0.7104, 0.7077, 0.705, 0.7023, 0.6996, 0.697, 0.7019, 
              0.6992, 0.7041, 0.7015, 0.7063, 0.7037, 0.7011, 0.7059, 
              0.7033, 0.7007, 0.6982, 0.6957, 0.6931, 0.6978, 0.6953, 
              0.6929, 0.6904, 0.6879, 0.6855, 0.6901, 0.6877, 0.6853, 
              0.6829, 0.6875, 0.6851, 0.6828, 0.6804, 0.6781, 0.6758, 
              0.6735, 0.678, 0.6757, 0.6734, 0.6711, 0.6689, 0.6667)
          expect_identical(f1_rocr_yvals[-1], round(f1_cp$roc_curve[[1]]$m, 
              4)[-1])
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 23. Error: Results for F1_score are equal to results by ROCR (@test-cutpointr
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "min", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = minimize_metric, metric = misclassification_cost, 
      direction = ">=", cost_fp = 1, cost_fn = 3, pos_class = 1)
  where 6 at testthat/test-cutpointr.R#629: cutpointr(tempdat, x, y, method = minimize_metric, metric = misclassification_cost, 
      direction = ">=", cost_fp = 1, cost_fn = 3, pos_class = 1)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#623: test_that("Results for misclassification_cost are equal to results by OptimalCutpoints", 
      {
          set.seed(429)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 1)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          opt_cut_cp <- cutpointr(tempdat, x, y, method = minimize_metric, 
              metric = misclassification_cost, direction = ">=", 
              cost_fp = 1, cost_fn = 3, pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), -0.2973)
          opt_cut_cp <- cutpointr(tempdat, x, y, group, method = minimize_metric, 
              metric = misclassification_cost, direction = ">=", 
              cost_fp = 1, cost_fn = 3, pos_class = 1)
          expect_equal(round(opt_cut_cp$optimal_cutpoint, 4), c(-0.7498, 
              -0.0824))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 24. Error: Results for misclassification_cost are equal to results by Optimal
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, criterion = criterion, 
      degree = degree, family = family, user.span = us, loess = TRUE, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, method = maximize_loess_metric, 
      user.span = 1, metric = accuracy, direction = ">=", pos_class = 1, 
      boot_runs = 10)
  where 6: cutpointr(tempdat, x, y, method = maximize_loess_metric, user.span = 1, 
      metric = accuracy, direction = ">=", pos_class = 1, boot_runs = 10)
  where 7: withCallingHandlers(expr, message = function(c) invokeRestart("muffleMessage"))
  where 8: suppressMessages(cp <- cutpointr(tempdat, x, y, method = maximize_loess_metric, 
      user.span = 1, metric = accuracy, direction = ">=", pos_class = 1, 
      boot_runs = 10))
  where 9: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 10: withVisible(code)
  where 11: withCallingHandlers(withVisible(code), warning = handle_warning, 
      message = handle_message)
  where 12: force(code)
  where 13: withr::with_output_sink(temp, withCallingHandlers(withVisible(code), 
      warning = handle_warning, message = handle_message))
  where 14: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 15: quasi_capture(enquo(object), NULL, evaluate_promise)
  where 16 at testthat/test-cutpointr.R#666: expect_silent(suppressMessages(cp <- cutpointr(tempdat, x, y, 
      method = maximize_loess_metric, user.span = 1, metric = accuracy, 
      direction = ">=", pos_class = 1, boot_runs = 10)))
  where 17: eval(code, test_env)
  where 18: eval(code, test_env)
  where 19: 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 20: doTryCatch(return(expr), name, parentenv, handler)
  where 21: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 22: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 23: doTryCatch(return(expr), name, parentenv, handler)
  where 24: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 25: tryCatchList(expr, classes, parentenv, handlers)
  where 26: 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 27: test_code(desc, code, env = parent.frame())
  where 28 at testthat/test-cutpointr.R#660: test_that("LOESS smoothing does not return warnings or errors", 
      {
          set.seed(38429)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 1)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          expect_silent(suppressMessages(cp <- cutpointr(tempdat, 
              x, y, method = maximize_loess_metric, user.span = 1, 
              metric = accuracy, direction = ">=", pos_class = 1, 
              boot_runs = 10)))
          expect_equal(round(cp$optimal_cutpoint, 3), 0.507)
          expect_equal(round(cp$loess_accuracy, 3), 0.69)
          set.seed(208)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 2)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          expect_silent(suppressMessages(cp <- cutpointr(tempdat, 
              x, y, method = maximize_loess_metric, metric = accuracy, 
              direction = ">=", pos_class = 1, boot_runs = 10)))
          expect_silent(suppressMessages(cutpointr(tempdat, x, 
              y, group, method = maximize_loess_metric, user.span = 1, 
              metric = accuracy, direction = ">=", pos_class = 1, 
              boot_runs = 10)))
          set.seed(3429)
          tempdat <- data.frame(x = c(rnorm(100), rnorm(100, mean = 1)), 
              y = c(rep(0, 100), rep(1, 100)), group = sample(c("a", 
                  "b"), size = 200, replace = TRUE))
          expect_silent(suppressMessages(cp <- cutpointr(tempdat, 
              x, y, method = minimize_loess_metric, user.span = 1, 
              break_ties = mean, metric = abs_d_ppv_npv, direction = ">=", 
              pos_class = 1, boot_runs = 10)))
          expect_equal(round(cp$optimal_cutpoint, 3), -0.083)
          expect_equal(round(cp$loess_abs_d_ppv_npv, 3), 0.156)
          expect_silent(cp <- cutpointr(tempdat, x, y, group, method = minimize_loess_metric, 
              user.span = 1, break_ties = mean, silent = TRUE, 
              metric = abs_d_ppv_npv, direction = ">=", pos_class = 1, 
              boot_runs = 100))
          expect_equal(round(cp$optimal_cutpoint, 2), c(-1.29, 
              1.01))
      })
  where 29: eval(code, test_env)
  where 30: eval(code, test_env)
  where 31: 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 32: doTryCatch(return(expr), name, parentenv, handler)
  where 33: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 34: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 35: doTryCatch(return(expr), name, parentenv, handler)
  where 36: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 37: tryCatchList(expr, classes, parentenv, handlers)
  where 38: 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 39: test_code(NULL, exprs, env)
  where 40: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 41: force(code)
  where 42: doWithOneRestart(return(expr), restart)
  where 43: withOneRestart(expr, restarts[[1L]])
  where 44: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 45: 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 46: FUN(X[[i]], ...)
  where 47: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 48: force(code)
  where 49: doWithOneRestart(return(expr), restart)
  where 50: withOneRestart(expr, restarts[[1L]])
  where 51: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 52: 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 53: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 54: 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 55: 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 56: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 25. Error: LOESS smoothing does not return warnings or errors (@test-cutpoint
  the condition has length > 1
  Backtrace:
    1. testthat::expect_silent(...)
   12. cutpointr:::cutpointr.default(...)
   13. cutpointr:::cutpointr_internal(...)
   14. cutpointr:::method(...)
   15. cutpointr:::optimize_metric(...)
   16. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, metric = prod_sens_spec)
  where 6 at testthat/test-cutpointr.R#724: cutpointr(suicide, dsi, suicide, metric = prod_sens_spec)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#723: test_that("cutpointr returns same result with NSE interface and raw data", 
      {
          oc1 <- cutpointr(suicide, dsi, suicide, metric = prod_sens_spec)
          oc2 <- cutpointr(x = suicide$dsi, class = suicide$suicide, 
              metric = prod_sens_spec)
          expect_true(oc1$optimal_cutpoint == 2)
          expect_true(oc2$optimal_cutpoint == 2)
          expect_true(oc1$prod_sens_spec == oc2$prod_sens_spec)
          oc1 <- cutpointr(suicide, dsi, suicide, gender, metric = prod_sens_spec)
          oc2 <- cutpointr(x = suicide$dsi, class = suicide$suicide, 
              subgroup = suicide$gender, metric = prod_sens_spec)
          expect_true(all(oc1$prod_sens_spec == oc2$prod_sens_spec))
          expect_true(all(oc1$optimal_cutpoint == oc2$optimal_cutpoint))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 26. Error: cutpointr returns same result with NSE interface and raw data (@te
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide, metric = prod_sens_spec)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide, metric = prod_sens_spec)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, pos_class = 1, direction = ">=")
  where 6 at testthat/test-cutpointr.R#741: cutpointr(tempdat, x, y, pos_class = 1, direction = ">=")
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#738: test_that("Prevalence is correctly calculated", {
      tempdat <- data.frame(x = 1:100, y = c(rep(0, 10), rep(1, 
          90)))
      oc <- cutpointr(tempdat, x, y, pos_class = 1, direction = ">=")
      expect_equal(oc$prevalence, 0.9)
      tempdat <- data.frame(x = 100:1, y = c(rep(0, 10), rep(1, 
          90)))
      oc <- cutpointr(tempdat, x, y, pos_class = 1, direction = ">=")
      expect_equal(oc$prevalence, 0.9)
      tempdat <- data.frame(x = 1:100, y = c(rep(0, 10), rep(1, 
          90)))
      oc <- cutpointr(tempdat, x, y, pos_class = 1, direction = "<=")
      expect_equal(oc$prevalence, 0.9)
      tempdat <- data.frame(x = 100:1, y = c(rep(0, 10), rep(1, 
          90)))
      oc <- cutpointr(tempdat, x, y, pos_class = 1, direction = "<=")
      expect_equal(oc$prevalence, 0.9)
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 27. Error: Prevalence is correctly calculated (@test-cutpointr.R#741)  ------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y, pos_class = 1, direction = ">=")
   2. cutpointr:::cutpointr.default(tempdat, x, y, pos_class = 1, direction = ">=")
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(data, !!coln, !!class_lab, silent = silent, 
      ...)
  where 6: cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  where 7: .f(.x[[i]], ...)
  where 8: purrr::map(x, function(coln) {
      if (!silent) 
          message(paste0(coln, ":"))
      cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  })
  where 9 at testthat/test-cutpointr.R#761: multi_cutpointr(suicide, x = c("age", "dsi"), class = "suicide", 
      pos_class = "yes")
  where 10: eval(code, test_env)
  where 11: eval(code, test_env)
  where 12: 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 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 15: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 16: doTryCatch(return(expr), name, parentenv, handler)
  where 17: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 18: tryCatchList(expr, classes, parentenv, handlers)
  where 19: 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 20: test_code(desc, code, env = parent.frame())
  where 21 at testthat/test-cutpointr.R#760: test_that("multi_cutpointr runs without errors", {
      mc <- multi_cutpointr(suicide, x = c("age", "dsi"), class = "suicide", 
          pos_class = "yes")
      expect_equal(mc$optimal_cutpoint, c(55, 2))
      mc2 <- multi_cutpointr(suicide, class = "suicide", pos_class = "yes")
      expect_identical(mc, mc2)
      mc3 <- multi_cutpointr(suicide, x = c("age", "dsi"), class = suicide, 
          pos_class = "yes", metric = sum_sens_spec)
      expect_identical(mc, mc3)
      mcg <- multi_cutpointr(suicide, x = c("age", "dsi"), class = "suicide", 
          subgroup = "gender", pos_class = "yes")
      expect_equal(mcg$optimal_cutpoint, c(55, 21, 2, 3))
      mcg2 <- multi_cutpointr(suicide, class = "suicide", subgroup = "gender", 
          pos_class = "yes")
      expect_identical(mcg, mcg2)
      mcg3 <- multi_cutpointr(suicide, x = c("age", "dsi"), class = suicide, 
          subgroup = gender, pos_class = "yes")
      expect_identical(mcg, mcg3)
      mcg4 <- multi_cutpointr(suicide, x = c("age", "dsi"), class = suicide, 
          subgroup = "gender", pos_class = "yes")
      expect_identical(mcg, mcg4)
  })
  where 22: eval(code, test_env)
  where 23: eval(code, test_env)
  where 24: 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 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 27: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 28: doTryCatch(return(expr), name, parentenv, handler)
  where 29: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 30: tryCatchList(expr, classes, parentenv, handlers)
  where 31: 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 32: test_code(NULL, exprs, env)
  where 33: source_file(path, new.env(parent = env), chdir = TRUE, 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 = 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 39: FUN(X[[i]], ...)
  where 40: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 41: force(code)
  where 42: doWithOneRestart(return(expr), restart)
  where 43: withOneRestart(expr, restarts[[1L]])
  where 44: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 45: 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 46: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 47: 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 48: 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 49: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 28. Error: multi_cutpointr runs without errors (@test-cutpointr.R#761)  -----
  the condition has length > 1
  Backtrace:
   1. cutpointr::multi_cutpointr(...)
   2. purrr::map(...)
   3. cutpointr:::.f(.x[[i]], ...)
   5. cutpointr:::cutpointr.default(...)
   6. cutpointr:::cutpointr_internal(...)
   7. cutpointr:::method(...)
   8. cutpointr:::optimize_metric(...)
   9. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y)
  where 6 at testthat/test-cutpointr.R#792: cutpointr(tempdat, x, y)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#790: test_that("AUC is always >= 0.5 with automatic assumptions", 
      {
          tempdat <- data.frame(x = c(5:1, 100), y = c(2, 2, 2, 
              1, 1, 1))
          oc <- cutpointr(tempdat, x, y)
          expect_true(oc$AUC >= 0.5)
          oc <- cutpointr(tempdat, x, y, pos_class = 2)
          expect_true(oc$AUC >= 0.5)
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 29. Error: AUC is always >= 0.5 with automatic assumptions (@test-cutpointr.R
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y)
   2. cutpointr:::cutpointr.default(tempdat, x, y)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "min", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.numeric(x = suicide$dsi, class = suicide$suicide, metric = abs_d_sens_spec, 
      method = minimize_metric, boot_runs = 10)
  where 6 at testthat/test-cutpointr.R#800: cutpointr(x = suicide$dsi, class = suicide$suicide, metric = abs_d_sens_spec, 
      method = minimize_metric, boot_runs = 10)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#799: test_that("find_metric_name_boot finds correct metric", {
      oc <- cutpointr(x = suicide$dsi, class = suicide$suicide, 
          metric = abs_d_sens_spec, method = minimize_metric, boot_runs = 10)
      expect_true(cutpointr:::find_metric_name_boot(oc$boot[[1]]) == 
          "abs_d_sens_spec_oob")
      oc <- cutpointr(x = suicide$dsi, class = suicide$suicide, 
          subgroup = suicide$gender, metric = abs_d_sens_spec, 
          method = minimize_metric, boot_runs = 10)
      expect_true(cutpointr:::find_metric_name_boot(oc$boot[[1]]) == 
          "abs_d_sens_spec_oob")
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 30. Error: find_metric_name_boot finds correct metric (@test-cutpointr.R#800)
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.numeric(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = d, x = predictor, class = outcome, metric_func = metric, 
      direction = direction, pos_class = pos_class, neg_class = neg_class, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 4: .f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
  where 5: purrr::pmap(list(dat$subgroup, dat$data), function(g, d) {
      if (nrow(d) <= 1) 
          stop(paste("Subgroup", g, "has <= 1 observations"))
      optcut <- tibble::tibble(subgroup = g)
      method_result <- method(data = d, x = predictor, class = outcome, 
          metric_func = metric, direction = direction, pos_class = pos_class, 
          neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
          ...)
      method_result <- check_method_cols(method_result)
      optcut <- dplyr::bind_cols(optcut, method_result)
      if (length(optcut[["optimal_cutpoint"]][[1]]) > 1) {
          message("Multiple optimal cutpoints found, applying break_ties.")
      }
      optcut <- apply_break_ties(optcut, break_ties)
      if (!(has_column(optcut, "roc_curve"))) {
          roc_curve <- roc(data = d, x = !!predictor, class = !!outcome, 
              pos_class = pos_class, neg_class = neg_class, direction = direction)
          roc_curve <- tidyr::nest(.data = roc_curve, roc_curve = dplyr::everything()) %>% 
              tibble::as_tibble()
          optcut <- dplyr::bind_cols(roc_curve, tibble::as_tibble(optcut))
      }
      else {
          check_roc_curve(optcut)
      }
      if (ncol(optcut) <= 3) {
          opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
              direction = direction)
          m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
              tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
              ...)
          m <- check_metric_name(m)
          colnames(m) <- make.names(colnames(m))
          optcut <- dplyr::bind_cols(optcut, tibble::as_tibble(m))
      }
      optcut <- check_colnames(optcut)
      opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
          direction = direction)
      m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
          tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
          ...)
      optcut <- add_list(optcut, as.numeric(m), optcut$metric_name)
      sesp <- sesp_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint, 
          direction = direction)
      optcut <- add_list(optcut, sesp[, "sensitivity"], "sensitivity")
      optcut <- add_list(optcut, sesp[, "specificity"], "specificity")
      acc <- accuracy_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint[[1]], 
          direction = direction)[, "accuracy"]
      optcut <- add_list(optcut, acc, "acc")
      return(optcut)
  })
  where 6: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 7: cutpointr.default(suicide, dsi, suicide, gender)
  where 8: cutpointr(suicide, dsi, suicide, gender)
  where 9: eval_bare(expr, quo_get_env(quo))
  where 10: quasi_label(enquo(object), label, arg = "object")
  where 11 at testthat/test-cutpointr.R#825: expect_identical(cutpointr(suicide, dsi, suicide, gender), cutpointr(suicide, 
      dsi, suicide, gender, silent = TRUE))
  where 12: eval(code, test_env)
  where 13: eval(code, test_env)
  where 14: 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 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 17: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 18: doTryCatch(return(expr), name, parentenv, handler)
  where 19: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 20: tryCatchList(expr, classes, parentenv, handlers)
  where 21: 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 22: test_code(desc, code, env = parent.frame())
  where 23 at testthat/test-cutpointr.R#824: test_that("same results with or without silent", {
      expect_identical(cutpointr(suicide, dsi, suicide, gender), 
          cutpointr(suicide, dsi, suicide, gender, silent = TRUE))
  })
  where 24: eval(code, test_env)
  where 25: eval(code, test_env)
  where 26: 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 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 29: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 30: doTryCatch(return(expr), name, parentenv, handler)
  where 31: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 32: tryCatchList(expr, classes, parentenv, handlers)
  where 33: 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 34: test_code(NULL, exprs, env)
  where 35: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 36: force(code)
  where 37: doWithOneRestart(return(expr), restart)
  where 38: withOneRestart(expr, restarts[[1L]])
  where 39: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 40: 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 41: FUN(X[[i]], ...)
  where 42: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 43: force(code)
  where 44: doWithOneRestart(return(expr), restart)
  where 45: withOneRestart(expr, restarts[[1L]])
  where 46: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 47: 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 48: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 49: 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 50: 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 51: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 31. Error: same results with or without silent (@test-cutpointr.R#825)  -----
  the condition has length > 1
  Backtrace:
    1. testthat::expect_identical(...)
    5. cutpointr:::cutpointr.default(suicide, dsi, suicide, gender)
    6. cutpointr:::cutpointr_internal(...)
    7. purrr::pmap(...)
    8. cutpointr:::.f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
    9. cutpointr:::method(...)
   10. cutpointr:::optimize_metric(...)
   11. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide)
  where 6 at testthat/test-cutpointr.R#832: cutpointr(suicide, dsi, suicide)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#831: test_that("plot_cutpointr runs", {
      oc <- cutpointr(suicide, dsi, suicide)
      expect_is(plot_cutpointr(oc), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, fpr), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, function(tp, fp, 
          ...) tp + fp), "ggplot")
      oc <- cutpointr(suicide, dsi, suicide, gender)
      expect_is(plot_cutpointr(oc), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, fpr), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, function(tp, fp, 
          ...) tp + fp), "ggplot")
      set.seed(100)
      oc <- cutpointr(suicide, dsi, suicide, boot_runs = 5)
      expect_is(plot_cutpointr(oc), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, fpr), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, function(tp, fp, 
          ...) tp + fp), "ggplot")
      set.seed(100)
      oc <- cutpointr(suicide, dsi, suicide, gender, boot_runs = 5)
      expect_is(plot_cutpointr(oc), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, fpr), "ggplot")
      expect_is(plot_cutpointr(oc, cutpoints, function(tp, fp, 
          ...) tp + fp), "ggplot")
      set.seed(100)
      expect_warning(plot_cutpointr(cutpointr(suicide, dsi, suicide, 
          boot_runs = 5), fpr, tpr))
      set.seed(200)
      expect_warning(plot_cutpointr(cutpointr(suicide, dsi, suicide, 
          gender, boot_runs = 5), fpr, tpr))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 32. Error: plot_cutpointr runs (@test-cutpointr.R#832)  ---------------------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, w = w, 
      df = df, spar = spar, nknots = nknots, df_offset = df_offset, 
      penalty = penalty, control_spar = control_spar, spline = TRUE, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, method = maximize_spline_metric, 
      nknots = 5, spar = 0.3)
  where 6 at testthat/test-cutpointr.R#865: cutpointr(suicide, dsi, suicide, method = maximize_spline_metric, 
      nknots = 5, spar = 0.3)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#864: test_that("smoothing splines lead to plausible results", {
      cp <- cutpointr(suicide, dsi, suicide, method = maximize_spline_metric, 
          nknots = 5, spar = 0.3)
      expect_equal(cp$optimal_cutpoint, 3)
      expect_silent(plot(cp))
      expect_silent(print(plot_metric(cp)))
      expect_silent(print(plot_roc(cp)))
      expect_silent(summary(cp))
      cp <- cutpointr(suicide, dsi, suicide, gender, method = maximize_spline_metric, 
          nknots = 5, spar = 0.3)
      expect_equal(cp$optimal_cutpoint, c(3, 3))
      expect_silent(plot(cp))
      expect_silent(print(plot_metric(cp)))
      expect_silent(print(plot_roc(cp)))
      expect_silent(summary(cp))
      cp <- cutpointr(suicide, dsi, suicide, method = minimize_spline_metric, 
          nknots = 5, spar = 0.3, df = 5, metric = abs_d_sens_spec)
      expect_equal(cp$optimal_cutpoint, 3)
      expect_silent(plot(cp))
      expect_silent(print(plot_metric(cp)))
      expect_silent(print(plot_roc(cp)))
      expect_silent(summary(cp))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 33. Error: smoothing splines lead to plausible results (@test-cutpointr.R#865
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, formula = formula, 
      optimizer = optimizer, gam = TRUE, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, method = maximize_gam_metric, 
      metric = youden)
  where 6 at testthat/test-cutpointr.R#891: cutpointr(suicide, dsi, suicide, method = maximize_gam_metric, 
      metric = youden)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#890: test_that("gam smoothing leads to plausible results", {
      cp <- cutpointr(suicide, dsi, suicide, method = maximize_gam_metric, 
          metric = youden)
      expect_equal(cp$optimal_cutpoint, 2)
      expect_silent(plot(cp))
      expect_silent(print(plot_metric(cp)))
      expect_silent(print(plot_roc(cp)))
      expect_silent(summary(cp))
      cp <- cutpointr(suicide, dsi, suicide, gender, method = maximize_gam_metric, 
          metric = youden)
      expect_equal(cp$optimal_cutpoint, c(2, 2))
      expect_silent(plot(cp))
      expect_silent(print(plot_metric(cp)))
      expect_silent(print(plot_roc(cp)))
      expect_silent(summary(cp))
      cp <- cutpointr(suicide, dsi, suicide, gender, method = minimize_gam_metric, 
          metric = abs_d_sens_spec)
      expect_equal(cp$optimal_cutpoint, c(2, 2))
      expect_silent(plot(cp))
      expect_silent(print(plot_metric(cp)))
      expect_silent(print(plot_roc(cp)))
      expect_silent(summary(cp))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 34. Error: gam smoothing leads to plausible results (@test-cutpointr.R#891)  
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data[b_ind, ], x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, return_roc = FALSE, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 3: .f(.x[[i]], ...)
  where 4: purrr::map(1:boot_cut, function(i) {
      b_ind <- simple_boot(data = data, dep_var = class)
      opt_cut <- optimize_metric(data = data[b_ind, ], x = x, class = class, 
          metric_func = metric_func, pos_class = pos_class, neg_class = neg_class, 
          minmax = "max", direction = direction, metric_name = metric_name, 
          return_roc = FALSE, tol_metric = tol_metric, use_midpoints = use_midpoints, 
          ...)
      return(unlist(opt_cut$optimal_cutpoint))
  })
  where 5: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 6: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 7: cutpointr.default(suicide, dsi, suicide, method = maximize_boot_metric, 
      metric = youden, boot_cut = 10)
  where 8 at testthat/test-cutpointr.R#918: cutpointr(suicide, dsi, suicide, method = maximize_boot_metric, 
      metric = youden, boot_cut = 10)
  where 9: eval(code, test_env)
  where 10: eval(code, test_env)
  where 11: 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 12: doTryCatch(return(expr), name, parentenv, handler)
  where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 17: tryCatchList(expr, classes, parentenv, handlers)
  where 18: 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 19: test_code(desc, code, env = parent.frame())
  where 20 at testthat/test-cutpointr.R#916: test_that("bootstrapped cutpoints lead to plausible results", 
      {
          set.seed(914)
          cp <- cutpointr(suicide, dsi, suicide, method = maximize_boot_metric, 
              metric = youden, boot_cut = 10)
          expect_equal(cp$optimal_cutpoint, 1.9)
          expect_silent(plot(cp))
          expect_silent(print(plot_roc(cp)))
          expect_silent(summary(cp))
          set.seed(14)
          cp <- cutpointr(suicide, dsi, suicide, gender, method = maximize_boot_metric, 
              metric = youden, boot_cut = 10)
          expect_equal(cp$optimal_cutpoint, c(2.2, 3.2))
          expect_silent(plot(cp))
          expect_silent(print(plot_roc(cp)))
          expect_silent(summary(cp))
          set.seed(15)
          cp <- cutpointr(suicide, dsi, suicide, gender, method = minimize_boot_metric, 
              metric = abs_d_sens_spec, boot_cut = 10)
          expect_equal(cp$optimal_cutpoint, c(2.1, 2.2))
          expect_silent(plot(cp))
          expect_error(plot_metric(cp))
          expect_silent(print(plot_roc(cp)))
          expect_silent(summary(cp))
      })
  where 21: eval(code, test_env)
  where 22: eval(code, test_env)
  where 23: 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 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 29: tryCatchList(expr, classes, parentenv, handlers)
  where 30: 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 31: test_code(NULL, exprs, env)
  where 32: source_file(path, new.env(parent = env), chdir = TRUE, 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 = 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 38: FUN(X[[i]], ...)
  where 39: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 40: force(code)
  where 41: doWithOneRestart(return(expr), restart)
  where 42: withOneRestart(expr, restarts[[1L]])
  where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 44: 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 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 46: 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 47: 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 48: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 35. Error: bootstrapped cutpoints lead to plausible results (@test-cutpointr.
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. purrr::map(...)
   6. cutpointr:::.f(.x[[i]], ...)
   7. cutpointr:::optimize_metric(...)
   8. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, w = w, 
      df = df, spar = spar, nknots = nknots, df_offset = df_offset, 
      penalty = penalty, control_spar = control_spar, spline = TRUE, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: withCallingHandlers(expr, message = function(c) invokeRestart("muffleMessage"))
  where 6: suppressMessages(cutpointr_internal(x, class, subgroup, method, 
      metric, pos_class, neg_class, direction, boot_runs, boot_stratify, 
      use_midpoints, break_ties, na.rm, allowParallel, predictor, 
      outcome, mod_name, subgroup_var, tol_metric, ...))
  where 7: cutpointr.default(dat, x, y, method = maximize_spline_metric, 
      nknots = 50, silent = TRUE)
  where 8: cutpointr(dat, x, y, method = maximize_spline_metric, nknots = 50, 
      silent = TRUE)
  where 9: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 10: withVisible(code)
  where 11: withCallingHandlers(withVisible(code), warning = handle_warning, 
      message = handle_message)
  where 12: force(code)
  where 13: withr::with_output_sink(temp, withCallingHandlers(withVisible(code), 
      warning = handle_warning, message = handle_message))
  where 14: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 15: quasi_capture(enquo(object), NULL, evaluate_promise)
  where 16 at testthat/test-cutpointr.R#946: expect_silent(cutpointr(dat, x, y, method = maximize_spline_metric, 
      nknots = 50, silent = TRUE))
  where 17: eval(code, test_env)
  where 18: eval(code, test_env)
  where 19: 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 20: doTryCatch(return(expr), name, parentenv, handler)
  where 21: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 22: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 23: doTryCatch(return(expr), name, parentenv, handler)
  where 24: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 25: tryCatchList(expr, classes, parentenv, handlers)
  where 26: 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 27: test_code(desc, code, env = parent.frame())
  where 28 at testthat/test-cutpointr.R#943: test_that("this led to an error with get_rev_dups Rcpp function", 
      {
          dat <- rbind(data.frame(x = round(rnorm(5000), 1), y = 0), 
              data.frame(x = round(rnorm(5000, mean = 0.05), 1), 
                  y = 1))
          expect_silent(cutpointr(dat, x, y, method = maximize_spline_metric, 
              nknots = 50, silent = TRUE))
      })
  where 29: eval(code, test_env)
  where 30: eval(code, test_env)
  where 31: 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 32: doTryCatch(return(expr), name, parentenv, handler)
  where 33: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 34: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 35: doTryCatch(return(expr), name, parentenv, handler)
  where 36: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 37: tryCatchList(expr, classes, parentenv, handlers)
  where 38: 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 39: test_code(NULL, exprs, env)
  where 40: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 41: force(code)
  where 42: doWithOneRestart(return(expr), restart)
  where 43: withOneRestart(expr, restarts[[1L]])
  where 44: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 45: 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 46: FUN(X[[i]], ...)
  where 47: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 48: force(code)
  where 49: doWithOneRestart(return(expr), restart)
  where 50: withOneRestart(expr, restarts[[1L]])
  where 51: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 52: 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 53: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 54: 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 55: 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 56: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 36. Error: this led to an error with get_rev_dups Rcpp function (@test-cutpoi
  the condition has length > 1
  Backtrace:
    1. testthat::expect_silent(...)
   10. cutpointr:::cutpointr.default(...)
   13. cutpointr:::cutpointr_internal(...)
   14. cutpointr:::method(...)
   15. cutpointr:::optimize_metric(...)
   16. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x = x, class = y, break_ties = c, 
      pos_class = 1, direction = ">=")
  where 6: cutpointr(tempdat, x = x, class = y, break_ties = c, pos_class = 1, 
      direction = ">=")
  where 7: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 8: withCallingHandlers(code, message = function(condition) {
      out$push(condition)
      maybe_restart("muffleMessage")
  })
  where 9: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 10: quasi_capture(enquo(object), label, capture_messages)
  where 11 at testthat/test-cutpointr.R#958: expect_message(cp <- cutpointr(tempdat, x = x, class = y, break_ties = c, 
      pos_class = 1, direction = ">="))
  where 12: eval(code, test_env)
  where 13: eval(code, test_env)
  where 14: 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 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 17: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 18: doTryCatch(return(expr), name, parentenv, handler)
  where 19: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 20: tryCatchList(expr, classes, parentenv, handlers)
  where 21: 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 22: test_code(desc, code, env = parent.frame())
  where 23 at testthat/test-cutpointr.R#955: test_that("cutpointr handles multiple optimal cutpoints correctly", 
      {
          tempdat <- data.frame(y = c(0, 0, 0, 1, 0, 1, 1, 1), 
              x = 1:8)
          expect_message(cp <- cutpointr(tempdat, x = x, class = y, 
              break_ties = c, pos_class = 1, direction = ">="))
          expect_equal(cp$optimal_cutpoint[[1]], c(6, 4))
          expect_message(cp <- cutpointr(tempdat, x = x, class = y, 
              break_ties = c, use_midpoints = TRUE, pos_class = 1, 
              direction = ">="))
          expect_equal(cp$optimal_cutpoint[[1]], c(5.5, 3.5))
          tempdat_g <- data.frame(g = c(rep(1, 8), rep(2, 8)), 
              y = c(tempdat$y, tempdat$y), x = c(tempdat$x, tempdat$x + 
                  2))
          expect_message(cp <- cutpointr(tempdat_g, x = x, class = y, 
              pos_class = 1, direction = ">=", subgroup = g, break_ties = c))
          preds <- predict(object = cp, newdata = data.frame(x = c(3, 
              6, 7, 1), g = c(1, 2, 2, 1)), cutpoint_nr = 2)
          expect_equal(preds, c(0, 1, 1, 0))
          preds <- predict(object = cp, newdata = data.frame(x = c(3, 
              4, 5, 8), g = c(1, 1, 2, 2)), cutpoint_nr = c(2, 
              1))
          expect_equal(preds, c(0, 1, 0, 1))
          dat <- structure(list(x = c(107.163316194991, 105.577309820546, 
              114.819340158769, 93.8701224510515, 111.161366154904, 
              110.365480099412, 98.3751686809715, 90.2407330717812, 
              89.1085480911548, 104.57786957945, 99.2887326627911, 
              117.791026668514, 105.351379604962, 96.280551248365, 
              89.7445775150289, 100.175983253947, 109.428883928973, 
              101.490653529433, 111.142301202307, 102.656619478302, 
              104.944400912055, 98.6949032719217, 125.050435849087, 
              109.326217314704, 108.306336404995, 89.0813758511593, 
              112.597918995493, 95.7637641112029, 97.084784256457, 
              115.183411710216), group = structure(c(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), .Label = c("h", "d"), class = "factor")), .Names = c("x", 
              "group"), row.names = c(NA, -30L), class = "data.frame")
          cp <- cutpointr(dat, x, group, break_ties = c, tol_metric = 1e-06)
          expect_equal(length(unlist(cp$optimal_cutpoint)), 5)
      })
  where 24: eval(code, test_env)
  where 25: eval(code, test_env)
  where 26: 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 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 29: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 30: doTryCatch(return(expr), name, parentenv, handler)
  where 31: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 32: tryCatchList(expr, classes, parentenv, handlers)
  where 33: 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 34: test_code(NULL, exprs, env)
  where 35: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 36: force(code)
  where 37: doWithOneRestart(return(expr), restart)
  where 38: withOneRestart(expr, restarts[[1L]])
  where 39: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 40: 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 41: FUN(X[[i]], ...)
  where 42: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 43: force(code)
  where 44: doWithOneRestart(return(expr), restart)
  where 45: withOneRestart(expr, restarts[[1L]])
  where 46: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 47: 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 48: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 49: 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 50: 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 51: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 37. Error: cutpointr handles multiple optimal cutpoints correctly (@test-cutp
  the condition has length > 1
  Backtrace:
    1. testthat::expect_message(...)
    7. cutpointr:::cutpointr.default(...)
    8. cutpointr:::cutpointr_internal(...)
    9. cutpointr:::method(...)
   10. cutpointr:::optimize_metric(...)
   11. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(dat, x, group, break_ties = c)
  where 6 at testthat/test-cutpointr.R#1010: cutpointr(dat, x, group, break_ties = c)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#1000: test_that("Main metric gets replaced correctly when ties are broken", 
      {
          dat <- structure(list(x = c(101.805229018197, 107.847340401023, 
              86.4683542621282, 119.832982062599, 112.384717044928, 
              112.006173961394, 108.961498842131, 102.536897550745, 
              105.496003408587, 119.033710510161, 124.445336141903, 
              111.152957581359, 103.727459196182, 97.3051126961894, 
              107.721798530394, 107.3951172956, 94.2585671912768, 
              127.544243110669, 93.2168880188317, 115.311444925151), 
              group = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
                  1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), 
                  .Label = c("h", "d"), class = "factor")), .Names = c("x", 
              "group"), row.names = c(NA, -20L), class = "data.frame")
          cp <- cutpointr(dat, x, group, break_ties = c)
          cp2 <- cutpointr(dat, x, group, break_ties = mean)
          expect_equal(unlist(cp$sum_sens_spec), c(1.2, 1.2))
          expect_equal(cp2$sum_sens_spec, 1.1)
          cp <- cutpointr(dat, x, group, metric = accuracy, method = maximize_metric, 
              break_ties = c)
          cp2 <- cutpointr(dat, x, group, metric = accuracy, method = maximize_metric, 
              break_ties = mean)
          expect_equal(unlist(cp$accuracy), c(0.6, 0.6))
          expect_equal(unlist(cp$accuracy), unlist(cp$acc))
          expect_equal(cp2$accuracy, 0.55)
          expect_equal(cp2$accuracy, cp2$acc)
          dat <- structure(list(x = c(112.154869479653, 85.0195562661719, 
              93.9648809281475, 111.629388719907, 93.6448243724487, 
              117.357328029692, 98.3663682555138, 105.201729160301, 
              98.7939462917362, 103.013183787135, 106.178862160569, 
              108.635928791856, 93.964291812696, 99.9357423611922, 
              106.763495052307, 114.17384726262, 127.593415952213, 
              95.1459299909085, 124.619049508866, 103.578770674126, 
              118.606425125718, 117.882345070528, 113.320440921296, 
              115.780191821353, 99.4794449460106, 115.080791705234, 
              104.429126735958, 119.686460888845, 106.942508474107, 
              119.110377570583, 121.929559539621, 121.503911629438, 
              116.669635368185, 106.99542786452, 106.089271831433, 
              119.975572786775, 120.126938685093, 98.1659607850261, 
              110.128131439393, 108.365631379854), group = structure(c(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), 
              .Label = c("h", "d"), class = "factor"), subgroup = c(0L, 
              1L, 0L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 
              0L, 0L, 0L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, 0L, 
              0L, 0L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 0L)), 
              .Names = c("x", "group", "subgroup"), row.names = c(NA, 
                  -40L), class = "data.frame")
          cp <- cutpointr(dat, x, group, subgroup, break_ties = c)
          cp2 <- cutpointr(dat, x, group, subgroup, break_ties = function(x) mean(x) - 
              10)
          expect_equal(round(cp$optimal_cutpoint[[2]], 4), c(113.3204, 
              110.1281))
          expect_equal(round(cp$sum_sens_spec[[2]], 3), rep(1.667, 
              2))
          expect_equal(round(cp2$optimal_cutpoint[[2]], 2), 101.72)
          expect_equal(round(cp2$sum_sens_spec[[2]], 3), 1.222)
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 38. Error: Main metric gets replaced correctly when ties are broken (@test-cu
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(dat, x, group, break_ties = c)
   2. cutpointr:::cutpointr.default(dat, x, group, break_ties = c)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, metric = youden, boot_runs = 30, 
      boot_stratify = TRUE)
  where 6 at testthat/test-cutpointr.R#1054: cutpointr(suicide, dsi, suicide, metric = youden, boot_runs = 30, 
      boot_stratify = TRUE)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#1052: test_that("stratification works", {
      set.seed(9174)
      cps <- cutpointr(suicide, dsi, suicide, metric = youden, 
          boot_runs = 30, boot_stratify = TRUE)
      expect_true(all(cps$boot[[1]]$TP_b + cps$boot[[1]]$FN_b == 
          36))
      set.seed(174)
      cps <- cutpointr(suicide, dsi, suicide, metric = youden, 
          boot_runs = 30, boot_stratify = FALSE)
      expect_true(any(cps$boot[[1]]$TP_b + cps$boot[[1]]$FN_b != 
          36))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 39. Error: stratification works (@test-cutpointr.R#1054)  -------------------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = d, x = predictor, class = outcome, metric_func = metric, 
      direction = direction, pos_class = pos_class, neg_class = neg_class, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 4: .f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
  where 5: purrr::pmap(list(dat$subgroup, dat$data), function(g, d) {
      if (nrow(d) <= 1) 
          stop(paste("Subgroup", g, "has <= 1 observations"))
      optcut <- tibble::tibble(subgroup = g)
      method_result <- method(data = d, x = predictor, class = outcome, 
          metric_func = metric, direction = direction, pos_class = pos_class, 
          neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
          ...)
      method_result <- check_method_cols(method_result)
      optcut <- dplyr::bind_cols(optcut, method_result)
      if (length(optcut[["optimal_cutpoint"]][[1]]) > 1) {
          message("Multiple optimal cutpoints found, applying break_ties.")
      }
      optcut <- apply_break_ties(optcut, break_ties)
      if (!(has_column(optcut, "roc_curve"))) {
          roc_curve <- roc(data = d, x = !!predictor, class = !!outcome, 
              pos_class = pos_class, neg_class = neg_class, direction = direction)
          roc_curve <- tidyr::nest(.data = roc_curve, roc_curve = dplyr::everything()) %>% 
              tibble::as_tibble()
          optcut <- dplyr::bind_cols(roc_curve, tibble::as_tibble(optcut))
      }
      else {
          check_roc_curve(optcut)
      }
      if (ncol(optcut) <= 3) {
          opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
              direction = direction)
          m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
              tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
              ...)
          m <- check_metric_name(m)
          colnames(m) <- make.names(colnames(m))
          optcut <- dplyr::bind_cols(optcut, tibble::as_tibble(m))
      }
      optcut <- check_colnames(optcut)
      opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
          direction = direction)
      m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
          tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
          ...)
      optcut <- add_list(optcut, as.numeric(m), optcut$metric_name)
      sesp <- sesp_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint, 
          direction = direction)
      optcut <- add_list(optcut, sesp[, "sensitivity"], "sensitivity")
      optcut <- add_list(optcut, sesp[, "specificity"], "specificity")
      acc <- accuracy_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint[[1]], 
          direction = direction)[, "accuracy"]
      optcut <- add_list(optcut, acc, "acc")
      return(optcut)
  })
  where 6: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 7: cutpointr.default(suicide, dsi, suicide, gender)
  where 8 at testthat/test-cutpointr.R#1137: cutpointr(suicide, dsi, suicide, gender)
  where 9: eval(code, test_env)
  where 10: eval(code, test_env)
  where 11: 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 12: doTryCatch(return(expr), name, parentenv, handler)
  where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 17: tryCatchList(expr, classes, parentenv, handlers)
  where 18: 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 19: test_code(desc, code, env = parent.frame())
  where 20 at testthat/test-cutpointr.R#1136: test_that("predict behaves as expected", {
      cp <- cutpointr(suicide, dsi, suicide, gender)
      expect_error(predict(cp, newdata = data.frame(dsi = c(2, 
          3, 4, 5), gender = c("female", "female", "female", "male")), 
          cutpoint_nr = c(1, 2)))
      cp <- cutpointr(suicide, dsi, suicide, method = maximize_spline_metric, 
          spar = 0.6)
      expect_error(predict(cp, newdata = data.frame(dsi = c(2, 
          3, 4, 5), gender = c("female", "female", "female", "male")), 
          cutpoint_nr = c(2)))
      expect_error(predict(cp, newdata = data.frame(dsi = c(2, 
          3, 4, 5), gender = c("female", "female", "female", "male")), 
          cutpoint_nr = c(1, 1)))
      expect_equal(predict(cp, newdata = data.frame(dsi = 1:5)), 
          factor(c("no", "no", "yes", "yes", "yes")))
      cp <- cutpointr(suicide, dsi, suicide, use_midpoints = TRUE, 
          method = maximize_spline_metric, spar = 0.6)
      expect_equal(predict(cp, newdata = data.frame(dsi = 1:5)), 
          factor(c("no", "no", "yes", "yes", "yes")))
  })
  where 21: eval(code, test_env)
  where 22: eval(code, test_env)
  where 23: 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 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 29: tryCatchList(expr, classes, parentenv, handlers)
  where 30: 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 31: test_code(NULL, exprs, env)
  where 32: source_file(path, new.env(parent = env), chdir = TRUE, 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 = 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 38: FUN(X[[i]], ...)
  where 39: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 40: force(code)
  where 41: doWithOneRestart(return(expr), restart)
  where 42: withOneRestart(expr, restarts[[1L]])
  where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 44: 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 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 46: 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 47: 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 48: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 40. Error: predict behaves as expected (@test-cutpointr.R#1137)  ------------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide, gender)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide, gender)
   3. cutpointr:::cutpointr_internal(...)
   4. purrr::pmap(...)
   5. cutpointr:::.f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
   6. cutpointr:::method(...)
   7. cutpointr:::optimize_metric(...)
   8. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = d, x = predictor, class = outcome, metric_func = metric, 
      direction = direction, pos_class = pos_class, neg_class = neg_class, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 4: .f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
  where 5: purrr::pmap(list(dat$subgroup, dat$data), function(g, d) {
      if (nrow(d) <= 1) 
          stop(paste("Subgroup", g, "has <= 1 observations"))
      optcut <- tibble::tibble(subgroup = g)
      method_result <- method(data = d, x = predictor, class = outcome, 
          metric_func = metric, direction = direction, pos_class = pos_class, 
          neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
          ...)
      method_result <- check_method_cols(method_result)
      optcut <- dplyr::bind_cols(optcut, method_result)
      if (length(optcut[["optimal_cutpoint"]][[1]]) > 1) {
          message("Multiple optimal cutpoints found, applying break_ties.")
      }
      optcut <- apply_break_ties(optcut, break_ties)
      if (!(has_column(optcut, "roc_curve"))) {
          roc_curve <- roc(data = d, x = !!predictor, class = !!outcome, 
              pos_class = pos_class, neg_class = neg_class, direction = direction)
          roc_curve <- tidyr::nest(.data = roc_curve, roc_curve = dplyr::everything()) %>% 
              tibble::as_tibble()
          optcut <- dplyr::bind_cols(roc_curve, tibble::as_tibble(optcut))
      }
      else {
          check_roc_curve(optcut)
      }
      if (ncol(optcut) <= 3) {
          opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
              direction = direction)
          m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
              tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
              ...)
          m <- check_metric_name(m)
          colnames(m) <- make.names(colnames(m))
          optcut <- dplyr::bind_cols(optcut, tibble::as_tibble(m))
      }
      optcut <- check_colnames(optcut)
      opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
          direction = direction)
      m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
          tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
          ...)
      optcut <- add_list(optcut, as.numeric(m), optcut$metric_name)
      sesp <- sesp_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint, 
          direction = direction)
      optcut <- add_list(optcut, sesp[, "sensitivity"], "sensitivity")
      optcut <- add_list(optcut, sesp[, "specificity"], "specificity")
      acc <- accuracy_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint[[1]], 
          direction = direction)[, "accuracy"]
      optcut <- add_list(optcut, acc, "acc")
      return(optcut)
  })
  where 6: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 7: cutpointr.default(suicide, dsi, suicide, gender)
  where 8 at testthat/test-cutpointr.R#1226: cutpointr(suicide, dsi, suicide, gender)
  where 9: eval(code, test_env)
  where 10: eval(code, test_env)
  where 11: 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 12: doTryCatch(return(expr), name, parentenv, handler)
  where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 17: tryCatchList(expr, classes, parentenv, handlers)
  where 18: 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 19: test_code(desc, code, env = parent.frame())
  where 20 at testthat/test-cutpointr.R#1225: test_that("add_metric adds metrics correctly", {
      oc <- cutpointr(suicide, dsi, suicide, gender)
      oc <- add_metric(oc, list(ppv, npv))
      expect_equal(oc$ppv, c(0.3676471, 0.2592593), tolerance = 1e-05)
      expect_equal(oc$npv, c(0.9938272, 0.9823009), tolerance = 1e-05)
      oc <- add_metric(oc, list(ppv))
      expect_equal(round(oc$ppv1, 7), c(0.3676471, 0.2592593))
      oc <- cutpointr(suicide, dsi, suicide)
      oc <- add_metric(oc, list(F1_score, precision))
      expect_equal(oc$F1_score, 0.470588, tolerance = 1e-05)
      expect_equal(oc$precision, 0.32, tolerance = 1e-05)
      oc <- cutpointr(suicide, dsi, suicide, use_midpoints = T)
      oc <- add_metric(oc, list(abs_d_ppv_npv, abs_d_sens_spec))
      expect_equal(oc$abs_d_ppv_npv, 0.670741, tolerance = 1e-05)
      expect_equal(oc$abs_d_sens_spec, 0.0259857, tolerance = 1e-05)
      rcp <- roc(data = suicide, x = dsi, class = suicide, pos_class = "yes", 
          neg_class = "no", direction = ">=") %>% add_metric(list(cohens_kappa, 
          F1_score))
      expect_equal(rcp$cohens_kappa, c(0, 0.05058128, 0.09312293, 
          0.13833841, 0.18161477, 0.30098108, 0.52746652, 0.52329749, 
          0.47076829, 0.42463778, 0.41208251, 0.27878034, 0), tolerance = 1e-05)
      tempdat <- data.frame(y = c(0, 0, 0, 1, 0, 1, 1, 1), x = 1:8)
      oc <- cutpointr(tempdat, x, y, break_ties = c)
      oc <- add_metric(oc, list(recall, youden))
      expect_equal(oc$recall[[1]], c(0.75, 1))
      expect_equal(oc$youden[[1]], c(0.75, 0.75))
      tempdat_g <- data.frame(g = c(rep(1, 8), rep(2, 8)), y = c(tempdat$y, 
          tempdat$y), x = c(tempdat$x, tempdat$x + 2))
      oc <- cutpointr(tempdat_g, x = x, class = y, pos_class = 1, 
          direction = ">=", subgroup = g, break_ties = c)
      oc <- add_metric(oc, list(false_omission_rate, prod_sens_spec))
      expect_equal(oc$false_omission_rate[[1]], c(0.2, 0))
      expect_equal(oc$prod_sens_spec[[1]], c(0.75, 0.75))
      mymetric <- function(...) return(42)
      oc <- cutpointr(suicide, dsi, suicide)
      oc <- add_metric(oc, list(mymetric))
      expect_equal(oc$added_metric, 42)
      mymetric <- function(...) return(data.frame(mymet = 42))
      oc <- cutpointr(suicide, dsi, suicide)
      oc <- add_metric(oc, list(mymetric))
      expect_equal(oc$mymet, 42)
  })
  where 21: eval(code, test_env)
  where 22: eval(code, test_env)
  where 23: 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 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 29: tryCatchList(expr, classes, parentenv, handlers)
  where 30: 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 31: test_code(NULL, exprs, env)
  where 32: source_file(path, new.env(parent = env), chdir = TRUE, 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 = 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 38: FUN(X[[i]], ...)
  where 39: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 40: force(code)
  where 41: doWithOneRestart(return(expr), restart)
  where 42: withOneRestart(expr, restarts[[1L]])
  where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 44: 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 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 46: 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 47: 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 48: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 41. Error: add_metric adds metrics correctly (@test-cutpointr.R#1226)  ------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide, gender)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide, gender)
   3. cutpointr:::cutpointr_internal(...)
   4. purrr::pmap(...)
   5. cutpointr:::.f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
   6. cutpointr:::method(...)
   7. cutpointr:::optimize_metric(...)
   8. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data[b_ind, ], x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, return_roc = FALSE, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 3: .f(.x[[i]], ...)
  where 4: purrr::map(1:boot_cut, function(i) {
      b_ind <- simple_boot(data = data, dep_var = class)
      opt_cut <- optimize_metric(data = data[b_ind, ], x = x, class = class, 
          metric_func = metric_func, pos_class = pos_class, neg_class = neg_class, 
          minmax = "max", direction = direction, metric_name = metric_name, 
          return_roc = FALSE, tol_metric = tol_metric, use_midpoints = use_midpoints, 
          ...)
      return(unlist(opt_cut$optimal_cutpoint))
  })
  where 5: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 6: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 7: withCallingHandlers(expr, message = function(c) invokeRestart("muffleMessage"))
  where 8: suppressMessages(cutpointr_internal(x, class, subgroup, method, 
      metric, pos_class, neg_class, direction, boot_runs, boot_stratify, 
      use_midpoints, break_ties, na.rm, allowParallel, predictor, 
      outcome, mod_name, subgroup_var, tol_metric, ...))
  where 9: cutpointr.default(suicide, dsi, suicide, method = cutpointr::maximize_boot_metric, 
      metric = cutpointr::accuracy, silent = TRUE)
  where 10: cutpointr(suicide, dsi, suicide, method = cutpointr::maximize_boot_metric, 
      metric = cutpointr::accuracy, silent = TRUE)
  where 11: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 12: withVisible(code)
  where 13: withCallingHandlers(withVisible(code), warning = handle_warning, 
      message = handle_message)
  where 14: force(code)
  where 15: withr::with_output_sink(temp, withCallingHandlers(withVisible(code), 
      warning = handle_warning, message = handle_message))
  where 16: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 17: quasi_capture(enquo(object), NULL, evaluate_promise)
  where 18 at testthat/test-cutpointr.R#1280: expect_silent(cutpointr(suicide, dsi, suicide, method = cutpointr::maximize_boot_metric, 
      metric = cutpointr::accuracy, silent = TRUE))
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(desc, code, env = parent.frame())
  where 30 at testthat/test-cutpointr.R#1279: test_that("cutpointr works if method / metric are called with ::", 
      {
          expect_silent(cutpointr(suicide, dsi, suicide, method = cutpointr::maximize_boot_metric, 
              metric = cutpointr::accuracy, silent = TRUE))
          expect_silent(cutpointr(suicide$dsi, suicide$suicide, 
              method = cutpointr::maximize_boot_metric, metric = cutpointr::cohens_kappa, 
              silent = TRUE))
      })
  where 31: eval(code, test_env)
  where 32: eval(code, test_env)
  where 33: 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 34: doTryCatch(return(expr), name, parentenv, handler)
  where 35: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 36: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 37: doTryCatch(return(expr), name, parentenv, handler)
  where 38: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 39: tryCatchList(expr, classes, parentenv, handlers)
  where 40: 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 41: test_code(NULL, exprs, env)
  where 42: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 43: force(code)
  where 44: doWithOneRestart(return(expr), restart)
  where 45: withOneRestart(expr, restarts[[1L]])
  where 46: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 47: 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 48: FUN(X[[i]], ...)
  where 49: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 50: force(code)
  where 51: doWithOneRestart(return(expr), restart)
  where 52: withOneRestart(expr, restarts[[1L]])
  where 53: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 54: 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 55: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 56: 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 57: 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 58: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 42. Error: cutpointr works if method / metric are called with :: (@test-cutpo
  the condition has length > 1
  Backtrace:
    1. testthat::expect_silent(...)
   10. cutpointr:::cutpointr.default(...)
   13. cutpointr:::cutpointr_internal(...)
   14. cutpointr:::method(...)
   15. purrr::map(...)
   16. cutpointr:::.f(.x[[i]], ...)
   17. cutpointr:::optimize_metric(...)
   18. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(data, !!coln, !!class_lab, silent = silent, 
      ...)
  where 6: cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  where 7: .f(.x[[i]], ...)
  where 8: purrr::map(x, function(coln) {
      if (!silent) 
          message(paste0(coln, ":"))
      cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  })
  where 9: multi_cutpointr(suicide, x = c("age", "dsi"), class = "suicide", 
      pos_class = "yes")
  where 10: plot(multi_cutpointr(suicide, x = c("age", "dsi"), class = "suicide", 
      pos_class = "yes"))
  where 11: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 12: withCallingHandlers({
      code
      NULL
  }, error = function(cnd) {
      if (can_entrace(cnd)) {
          cnd <- cnd_entrace(cnd)
      }
      return_from(env, cnd)
  })
  where 13: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 14: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
  where 15 at testthat/test-cutpointr.R#1289: expect_error(plot(multi_cutpointr(suicide, x = c("age", "dsi"), 
      class = "suicide", pos_class = "yes")))
  where 16: eval(code, test_env)
  where 17: eval(code, test_env)
  where 18: 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 19: doTryCatch(return(expr), name, parentenv, handler)
  where 20: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 21: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 24: tryCatchList(expr, classes, parentenv, handlers)
  where 25: 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 26: test_code(desc, code, env = parent.frame())
  where 27 at testthat/test-cutpointr.R#1288: test_that("Plotting with multi_cutpointr throws error", {
      expect_error(plot(multi_cutpointr(suicide, x = c("age", "dsi"), 
          class = "suicide", pos_class = "yes")))
      expect_error(plot(multi_cutpointr(suicide, x = c("age", "dsi"), 
          subgroup = "gender", class = "suicide", pos_class = "yes")))
  })
  where 28: eval(code, test_env)
  where 29: eval(code, test_env)
  where 30: 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 31: doTryCatch(return(expr), name, parentenv, handler)
  where 32: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 33: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 34: doTryCatch(return(expr), name, parentenv, handler)
  where 35: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 36: tryCatchList(expr, classes, parentenv, handlers)
  where 37: 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 38: test_code(NULL, exprs, env)
  where 39: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 40: force(code)
  where 41: doWithOneRestart(return(expr), restart)
  where 42: withOneRestart(expr, restarts[[1L]])
  where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 44: 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 45: FUN(X[[i]], ...)
  where 46: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 47: force(code)
  where 48: doWithOneRestart(return(expr), restart)
  where 49: withOneRestart(expr, restarts[[1L]])
  where 50: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 51: 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 52: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 53: 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 54: 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 55: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = d, x = predictor, class = outcome, metric_func = metric, 
      direction = direction, pos_class = pos_class, neg_class = neg_class, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 4: .f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
  where 5: purrr::pmap(list(dat$subgroup, dat$data), function(g, d) {
      if (nrow(d) <= 1) 
          stop(paste("Subgroup", g, "has <= 1 observations"))
      optcut <- tibble::tibble(subgroup = g)
      method_result <- method(data = d, x = predictor, class = outcome, 
          metric_func = metric, direction = direction, pos_class = pos_class, 
          neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
          ...)
      method_result <- check_method_cols(method_result)
      optcut <- dplyr::bind_cols(optcut, method_result)
      if (length(optcut[["optimal_cutpoint"]][[1]]) > 1) {
          message("Multiple optimal cutpoints found, applying break_ties.")
      }
      optcut <- apply_break_ties(optcut, break_ties)
      if (!(has_column(optcut, "roc_curve"))) {
          roc_curve <- roc(data = d, x = !!predictor, class = !!outcome, 
              pos_class = pos_class, neg_class = neg_class, direction = direction)
          roc_curve <- tidyr::nest(.data = roc_curve, roc_curve = dplyr::everything()) %>% 
              tibble::as_tibble()
          optcut <- dplyr::bind_cols(roc_curve, tibble::as_tibble(optcut))
      }
      else {
          check_roc_curve(optcut)
      }
      if (ncol(optcut) <= 3) {
          opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
              direction = direction)
          m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
              tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
              ...)
          m <- check_metric_name(m)
          colnames(m) <- make.names(colnames(m))
          optcut <- dplyr::bind_cols(optcut, tibble::as_tibble(m))
      }
      optcut <- check_colnames(optcut)
      opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
          direction = direction)
      m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
          tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
          ...)
      optcut <- add_list(optcut, as.numeric(m), optcut$metric_name)
      sesp <- sesp_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint, 
          direction = direction)
      optcut <- add_list(optcut, sesp[, "sensitivity"], "sensitivity")
      optcut <- add_list(optcut, sesp[, "specificity"], "specificity")
      acc <- accuracy_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint[[1]], 
          direction = direction)[, "accuracy"]
      optcut <- add_list(optcut, acc, "acc")
      return(optcut)
  })
  where 6: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 7: cutpointr.default(data, !!coln, !!class_lab, subgroup = !!subgroup_lab, 
      silent = silent, ...)
  where 8: cutpointr(data, !!coln, !!class_lab, subgroup = !!subgroup_lab, 
      silent = silent, ...)
  where 9: .f(.x[[i]], ...)
  where 10: purrr::map(x, function(coln) {
      if (!silent) 
          message(paste0(coln, ":"))
      cutpointr(data, !!coln, !!class_lab, subgroup = !!subgroup_lab, 
          silent = silent, ...)
  })
  where 11: multi_cutpointr(suicide, x = c("age", "dsi"), subgroup = "gender", 
      class = "suicide", pos_class = "yes")
  where 12: plot(multi_cutpointr(suicide, x = c("age", "dsi"), subgroup = "gender", 
      class = "suicide", pos_class = "yes"))
  where 13: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 14: withCallingHandlers({
      code
      NULL
  }, error = function(cnd) {
      if (can_entrace(cnd)) {
          cnd <- cnd_entrace(cnd)
      }
      return_from(env, cnd)
  })
  where 15: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 16: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
  where 17 at testthat/test-cutpointr.R#1293: expect_error(plot(multi_cutpointr(suicide, x = c("age", "dsi"), 
      subgroup = "gender", class = "suicide", pos_class = "yes")))
  where 18: eval(code, test_env)
  where 19: eval(code, test_env)
  where 20: 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 21: doTryCatch(return(expr), name, parentenv, handler)
  where 22: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 23: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 26: tryCatchList(expr, classes, parentenv, handlers)
  where 27: 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 28: test_code(desc, code, env = parent.frame())
  where 29 at testthat/test-cutpointr.R#1288: test_that("Plotting with multi_cutpointr throws error", {
      expect_error(plot(multi_cutpointr(suicide, x = c("age", "dsi"), 
          class = "suicide", pos_class = "yes")))
      expect_error(plot(multi_cutpointr(suicide, x = c("age", "dsi"), 
          subgroup = "gender", class = "suicide", pos_class = "yes")))
  })
  where 30: eval(code, test_env)
  where 31: eval(code, test_env)
  where 32: 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 33: doTryCatch(return(expr), name, parentenv, handler)
  where 34: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 35: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 36: doTryCatch(return(expr), name, parentenv, handler)
  where 37: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 38: tryCatchList(expr, classes, parentenv, handlers)
  where 39: 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 40: test_code(NULL, exprs, env)
  where 41: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 42: force(code)
  where 43: doWithOneRestart(return(expr), restart)
  where 44: withOneRestart(expr, restarts[[1L]])
  where 45: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 46: 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 47: FUN(X[[i]], ...)
  where 48: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 49: force(code)
  where 50: doWithOneRestart(return(expr), restart)
  where 51: withOneRestart(expr, restarts[[1L]])
  where 52: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 53: 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 54: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 55: 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 56: 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 57: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: withCallingHandlers(expr, message = function(c) invokeRestart("muffleMessage"))
  where 6: suppressMessages(cutpointr_internal(x, class, subgroup, method, 
      metric, pos_class, neg_class, direction, boot_runs, boot_stratify, 
      use_midpoints, break_ties, na.rm, allowParallel, predictor, 
      outcome, mod_name, subgroup_var, tol_metric, ...))
  where 7: cutpointr.default(data, !!coln, !!class_lab, silent = silent, 
      ...)
  where 8: cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  where 9: .f(.x[[i]], ...)
  where 10: purrr::map(x, function(coln) {
      if (!silent) 
          message(paste0(coln, ":"))
      cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  })
  where 11: multi_cutpointr(suicide, x = c("age", "dsi"), class = "suicide", 
      pos_class = "yes", silent = TRUE)
  where 12: summary(multi_cutpointr(suicide, x = c("age", "dsi"), class = "suicide", 
      pos_class = "yes", silent = TRUE))
  where 13: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 14: withVisible(code)
  where 15: withCallingHandlers(withVisible(code), warning = handle_warning, 
      message = handle_message)
  where 16: force(code)
  where 17: withr::with_output_sink(temp, withCallingHandlers(withVisible(code), 
      warning = handle_warning, message = handle_message))
  where 18: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 19: quasi_capture(enquo(object), NULL, evaluate_promise)
  where 20 at testthat/test-cutpointr.R#1300: expect_silent(smcp <- summary(multi_cutpointr(suicide, x = c("age", 
      "dsi"), class = "suicide", pos_class = "yes", silent = TRUE)))
  where 21: eval(code, test_env)
  where 22: eval(code, test_env)
  where 23: 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 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 29: tryCatchList(expr, classes, parentenv, handlers)
  where 30: 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 31: test_code(desc, code, env = parent.frame())
  where 32 at testthat/test-cutpointr.R#1299: test_that("Summary(multi_cutpointr) is silent", {
      expect_silent(smcp <- summary(multi_cutpointr(suicide, x = c("age", 
          "dsi"), class = "suicide", pos_class = "yes", silent = TRUE)))
      expect_silent(smcp <- summary(multi_cutpointr(suicide, x = c("age", 
          "dsi"), class = "suicide", subgroup = "gender", pos_class = "yes", 
          silent = TRUE)))
      expect_silent(smcp <- summary(multi_cutpointr(suicide, x = c("age", 
          "dsi"), class = "suicide", boot_runs = 5, pos_class = "yes", 
          silent = TRUE)))
      expect_silent(smcp <- summary(multi_cutpointr(suicide, x = c("age", 
          "dsi"), class = "suicide", subgroup = "gender", boot_runs = 5, 
          pos_class = "yes", silent = TRUE)))
  })
  where 33: eval(code, test_env)
  where 34: eval(code, test_env)
  where 35: 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 36: doTryCatch(return(expr), name, parentenv, handler)
  where 37: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 38: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 39: doTryCatch(return(expr), name, parentenv, handler)
  where 40: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 41: tryCatchList(expr, classes, parentenv, handlers)
  where 42: 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 43: test_code(NULL, exprs, env)
  where 44: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 45: force(code)
  where 46: doWithOneRestart(return(expr), restart)
  where 47: withOneRestart(expr, restarts[[1L]])
  where 48: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 49: 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 50: FUN(X[[i]], ...)
  where 51: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 52: force(code)
  where 53: doWithOneRestart(return(expr), restart)
  where 54: withOneRestart(expr, restarts[[1L]])
  where 55: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 56: 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 57: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 58: 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 59: 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 60: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 43. Error: Summary(multi_cutpointr) is silent (@test-cutpointr.R#1300)  -----
  the condition has length > 1
  Backtrace:
    1. testthat::expect_silent(...)
   10. cutpointr::multi_cutpointr(...)
   11. purrr::map(...)
   12. cutpointr:::.f(.x[[i]], ...)
   14. cutpointr:::cutpointr.default(...)
   17. cutpointr:::cutpointr_internal(...)
   18. cutpointr:::method(...)
   19. cutpointr:::optimize_metric(...)
   20. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: withCallingHandlers(expr, message = function(c) invokeRestart("muffleMessage"))
  where 6: suppressMessages(cutpointr_internal(x, class, subgroup, method, 
      metric, pos_class, neg_class, direction, boot_runs, boot_stratify, 
      use_midpoints, break_ties, na.rm, allowParallel, predictor, 
      outcome, mod_name, subgroup_var, tol_metric, ...))
  where 7: cutpointr.default(data, !!coln, !!class_lab, silent = silent, 
      ...)
  where 8: cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  where 9: .f(.x[[i]], ...)
  where 10: purrr::map(x, function(coln) {
      if (!silent) 
          message(paste0(coln, ":"))
      cutpointr(data, !!coln, !!class_lab, silent = silent, ...)
  })
  where 11: multi_cutpointr(tempdat, class = "Species", silent = TRUE)
  where 12: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
  where 13: withVisible(code)
  where 14: withCallingHandlers(withVisible(code), warning = handle_warning, 
      message = handle_message)
  where 15: force(code)
  where 16: withr::with_output_sink(temp, withCallingHandlers(withVisible(code), 
      warning = handle_warning, message = handle_message))
  where 17: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)), 
      ...)
  where 18: quasi_capture(enquo(object), NULL, evaluate_promise)
  where 19 at testthat/test-cutpointr.R#1335: expect_silent(mcp <- multi_cutpointr(tempdat, class = "Species", 
      silent = TRUE))
  where 20: eval(code, test_env)
  where 21: eval(code, test_env)
  where 22: 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 23: doTryCatch(return(expr), name, parentenv, handler)
  where 24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 25: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 26: doTryCatch(return(expr), name, parentenv, handler)
  where 27: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 28: tryCatchList(expr, classes, parentenv, handlers)
  where 29: 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 30: test_code(desc, code, env = parent.frame())
  where 31 at testthat/test-cutpointr.R#1329: test_that("multi_cutpointr fetches numeric columns correctly", 
      {
          tempdat <- iris[1:99, ]
          tempdat$char <- "XYZ"
          set.seed(734)
          tempdat$g <- sample(0:1, size = 99, replace = TRUE)
          expect_silent(mcp <- multi_cutpointr(tempdat, class = "Species", 
              silent = TRUE))
          expect_equal(nrow(mcp), 5)
          expect_silent(mcp <- multi_cutpointr(tempdat, class = "Species", 
              subgroup = "g", silent = TRUE))
          expect_equal(nrow(mcp), 8)
          expect_silent(mcp <- multi_cutpointr(tempdat, class = "Species", 
              subgroup = "g", silent = TRUE, boot_runs = 10))
          expect_equal(nrow(mcp), 8)
      })
  where 32: eval(code, test_env)
  where 33: eval(code, test_env)
  where 34: 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 35: doTryCatch(return(expr), name, parentenv, handler)
  where 36: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 37: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 38: doTryCatch(return(expr), name, parentenv, handler)
  where 39: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 40: tryCatchList(expr, classes, parentenv, handlers)
  where 41: 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 42: test_code(NULL, exprs, env)
  where 43: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 44: force(code)
  where 45: doWithOneRestart(return(expr), restart)
  where 46: withOneRestart(expr, restarts[[1L]])
  where 47: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 48: 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 49: FUN(X[[i]], ...)
  where 50: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 51: force(code)
  where 52: doWithOneRestart(return(expr), restart)
  where 53: withOneRestart(expr, restarts[[1L]])
  where 54: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 55: 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 56: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 57: 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 58: 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 59: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 44. Error: multi_cutpointr fetches numeric columns correctly (@test-cutpointr
  the condition has length > 1
  Backtrace:
    1. testthat::expect_silent(...)
    9. cutpointr::multi_cutpointr(tempdat, class = "Species", silent = TRUE)
   10. purrr::map(...)
   11. cutpointr:::.f(.x[[i]], ...)
   13. cutpointr:::cutpointr.default(...)
   16. cutpointr:::cutpointr_internal(...)
   17. cutpointr:::method(...)
   18. cutpointr:::optimize_metric(...)
   19. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = d, x = predictor, class = outcome, metric_func = metric, 
      direction = direction, pos_class = pos_class, neg_class = neg_class, 
      tol_metric = tol_metric, use_midpoints = use_midpoints, ...)
  where 4: .f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
  where 5: purrr::pmap(list(dat$subgroup, dat$data), function(g, d) {
      if (nrow(d) <= 1) 
          stop(paste("Subgroup", g, "has <= 1 observations"))
      optcut <- tibble::tibble(subgroup = g)
      method_result <- method(data = d, x = predictor, class = outcome, 
          metric_func = metric, direction = direction, pos_class = pos_class, 
          neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
          ...)
      method_result <- check_method_cols(method_result)
      optcut <- dplyr::bind_cols(optcut, method_result)
      if (length(optcut[["optimal_cutpoint"]][[1]]) > 1) {
          message("Multiple optimal cutpoints found, applying break_ties.")
      }
      optcut <- apply_break_ties(optcut, break_ties)
      if (!(has_column(optcut, "roc_curve"))) {
          roc_curve <- roc(data = d, x = !!predictor, class = !!outcome, 
              pos_class = pos_class, neg_class = neg_class, direction = direction)
          roc_curve <- tidyr::nest(.data = roc_curve, roc_curve = dplyr::everything()) %>% 
              tibble::as_tibble()
          optcut <- dplyr::bind_cols(roc_curve, tibble::as_tibble(optcut))
      }
      else {
          check_roc_curve(optcut)
      }
      if (ncol(optcut) <= 3) {
          opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
              direction = direction)
          m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
              tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
              ...)
          m <- check_metric_name(m)
          colnames(m) <- make.names(colnames(m))
          optcut <- dplyr::bind_cols(optcut, tibble::as_tibble(m))
      }
      optcut <- check_colnames(optcut)
      opt_ind <- get_opt_ind(optcut$roc_curve[[1]], oc = unlist(optcut$optimal_cutpoint), 
          direction = direction)
      m <- metric(tp = optcut$roc_curve[[1]]$tp[opt_ind], fp = optcut$roc_curve[[1]]$fp[opt_ind], 
          tn = optcut$roc_curve[[1]]$tn[opt_ind], fn = optcut$roc_curve[[1]]$fn[opt_ind], 
          ...)
      optcut <- add_list(optcut, as.numeric(m), optcut$metric_name)
      sesp <- sesp_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint, 
          direction = direction)
      optcut <- add_list(optcut, sesp[, "sensitivity"], "sensitivity")
      optcut <- add_list(optcut, sesp[, "specificity"], "specificity")
      acc <- accuracy_from_oc(optcut$roc_curve[[1]], oc = optcut$optimal_cutpoint[[1]], 
          direction = direction)[, "accuracy"]
      optcut <- add_list(optcut, acc, "acc")
      return(optcut)
  })
  where 6: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 7: cutpointr.default(suicide, !!myvar, !!myclass, !!mygroup)
  where 8 at testthat/test-cutpointr.R#1356: cutpointr(suicide, !!myvar, !!myclass, !!mygroup)
  where 9: eval(code, test_env)
  where 10: eval(code, test_env)
  where 11: 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 12: doTryCatch(return(expr), name, parentenv, handler)
  where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 15: doTryCatch(return(expr), name, parentenv, handler)
  where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 17: tryCatchList(expr, classes, parentenv, handlers)
  where 18: 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 19: test_code(desc, code, env = parent.frame())
  where 20 at testthat/test-cutpointr.R#1352: test_that("tidyeval works with cutpointr", {
      myvar <- "dsi"
      myclass <- "suicide"
      mygroup <- "gender"
      cp <- cutpointr(suicide, !!myvar, !!myclass, !!mygroup)
      cp2 <- cutpointr(suicide, dsi, suicide, gender)
      expect_identical(cp %>% dplyr::select(-data, -roc_curve), 
          cp2 %>% dplyr::select(-data, -roc_curve))
      expect_silent(summary(cp))
  })
  where 21: eval(code, test_env)
  where 22: eval(code, test_env)
  where 23: 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 24: doTryCatch(return(expr), name, parentenv, handler)
  where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 27: doTryCatch(return(expr), name, parentenv, handler)
  where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 29: tryCatchList(expr, classes, parentenv, handlers)
  where 30: 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 31: test_code(NULL, exprs, env)
  where 32: source_file(path, new.env(parent = env), chdir = TRUE, 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 = 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 38: FUN(X[[i]], ...)
  where 39: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 40: force(code)
  where 41: doWithOneRestart(return(expr), restart)
  where 42: withOneRestart(expr, restarts[[1L]])
  where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 44: 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 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 46: 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 47: 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 48: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 45. Error: tidyeval works with cutpointr (@test-cutpointr.R#1356)  ----------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, !!myvar, !!myclass, !!mygroup)
   2. cutpointr:::cutpointr.default(suicide, !!myvar, !!myclass, !!mygroup)
   3. cutpointr:::cutpointr_internal(...)
   4. purrr::pmap(...)
   5. cutpointr:::.f(.l[[1L]][[i]], .l[[2L]][[i]], ...)
   6. cutpointr:::method(...)
   7. cutpointr:::optimize_metric(...)
   8. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide, dsi, suicide, boot_runs = 30)
  where 6 at testthat/test-cutpointr.R#1376: cutpointr(suicide, dsi, suicide, boot_runs = 30)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#1374: test_that("boot_ci works correctly", {
      set.seed(1349)
      cp <- cutpointr(suicide, dsi, suicide, boot_runs = 30)
      bci <- boot_ci(x = cp, variable = optimal_cutpoint, alpha = 0.05)
      expect_equal(round(bci$values, 2), c(1, 3.27))
      set.seed(1349)
      cp <- cutpointr(suicide, dsi, suicide, gender, boot_runs = 30)
      bci <- boot_ci(x = cp, variable = optimal_cutpoint, alpha = 0.05)
      expect_equal(round(bci$values, 2), c(2, 2, 1, 4.55))
      expect_equal(bci$subgroup, c("female", "female", "male", 
          "male"))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 46. Error: boot_ci works correctly (@test-cutpointr.R#1376)  ----------------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(suicide, dsi, suicide, boot_runs = 30)
   2. cutpointr:::cutpointr.default(suicide, dsi, suicide, boot_runs = 30)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(suicide %>% dplyr::filter(gender == "female"), 
      dsi, suicide, boot_runs = 100)
  where 6 at testthat/test-cutpointr.R#1390: cutpointr(suicide %>% dplyr::filter(gender == "female"), dsi, 
      suicide, boot_runs = 100)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#1388: test_that("boot_test works correctly", {
      set.seed(123)
      cp_f <- cutpointr(suicide %>% dplyr::filter(gender == "female"), 
          dsi, suicide, boot_runs = 100)
      set.seed(924)
      cp_m <- cutpointr(suicide %>% dplyr::filter(gender == "male"), 
          dsi, suicide, boot_runs = 100)
      bt <- boot_test(cp_f, cp_m, AUC, in_bag = TRUE)
      expect_equal(round(bt$p, 3), 0.249)
      expect_equal(round(bt$z, 2), 1.15)
      set.seed(9184)
      cp <- cutpointr(suicide, dsi, suicide, gender, boot_runs = 100)
      btg <- boot_test(cp, variable = AUC, in_bag = TRUE)
      expect_equal(round(btg$p, 3), 0.306)
      expect_equal(btg$subgroup1, "female")
      expect_equal(btg$d, bt$d)
      dat <- suicide
      set.seed(765)
      dat$g <- sample(c("a", "b", "c"), size = nrow(suicide), replace = TRUE)
      set.seed(745)
      cp <- cutpointr(dat, dsi, suicide, g, boot_runs = 100, boot_stratify = TRUE, 
          metric = youden)
      bt <- boot_test(cp, variable = youden)
      expect_equal(nrow(bt), 3)
      expect_equal(round(bt$p, 3), c(0.753, 0.216, 0.244))
      expect_equal(round(bt$p_adj, 3), c(0.753, 0.647, 0.647))
      bt <- boot_test(cp, variable = youden, correction = "bonferroni")
      expect_equal(round(bt$p_adj, 3), c(1, 0.647, 0.731))
  })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 47. Error: boot_test works correctly (@test-cutpointr.R#1390)  --------------
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(...)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  cutpointr
   --- call from context --- 
  sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
   --- call from argument --- 
  if (dim(m)[2] == 1 & class(m) == "matrix") {
      res <- m
      if (is.null(colnames(res))) 
          colnames(res) <- m_name
  } else {
      stop(paste("The metric function should return a numeric vector", 
          "or a one-column matrix or data.frame."))
  }
   --- R stacktrace ---
  where 1: sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  where 2: optimize_metric(data = data, x = x, class = class, metric_func = metric_func, 
      pos_class = pos_class, neg_class = neg_class, minmax = "max", 
      direction = direction, metric_name = metric_name, tol_metric = tol_metric, 
      use_midpoints = use_midpoints, ...)
  where 3: method(data = dat$data[[1]], x = predictor, class = outcome, 
      metric_func = metric, direction = direction, pos_class = pos_class, 
      neg_class = neg_class, tol_metric = tol_metric, use_midpoints = use_midpoints, 
      ...)
  where 4: cutpointr_internal(x, class, subgroup, method, metric, pos_class, 
      neg_class, direction, boot_runs, boot_stratify, use_midpoints, 
      break_ties, na.rm, allowParallel, predictor, outcome, mod_name, 
      subgroup_var, tol_metric, ...)
  where 5: cutpointr.default(tempdat, x, y, break_ties = c, boot_runs = 200)
  where 6 at testthat/test-cutpointr.R#1426: cutpointr(tempdat, x, y, break_ties = c, boot_runs = 200)
  where 7: eval(code, test_env)
  where 8: eval(code, test_env)
  where 9: 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 10: doTryCatch(return(expr), name, parentenv, handler)
  where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 15: tryCatchList(expr, classes, parentenv, handlers)
  where 16: 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 17: test_code(desc, code, env = parent.frame())
  where 18 at testthat/test-cutpointr.R#1420: test_that("Bootstrap works with multiple cutpoints when not breaking ties", 
      {
          set.seed(827)
          tempdat <- data.frame(x = rnorm(1000), y = sample(0:1, 
              size = 1000, replace = TRUE), g = sample(0:1, size = 1000, 
              replace = TRUE))
          set.seed(73)
          cp <- cutpointr(tempdat, x, y, break_ties = c, boot_runs = 200)
          expect_silent(summary(cp))
          set.seed(73)
          cp <- cutpointr(tempdat, x, y, g, break_ties = c, boot_runs = 100)
          expect_silent(summary(cp))
      })
  where 19: eval(code, test_env)
  where 20: eval(code, test_env)
  where 21: 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 22: doTryCatch(return(expr), name, parentenv, handler)
  where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 27: tryCatchList(expr, classes, parentenv, handlers)
  where 28: 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 29: test_code(NULL, exprs, env)
  where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 31: force(code)
  where 32: doWithOneRestart(return(expr), restart)
  where 33: withOneRestart(expr, restarts[[1L]])
  where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 35: 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 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: doWithOneRestart(return(expr), restart)
  where 40: withOneRestart(expr, restarts[[1L]])
  where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
  where 42: 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 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 44: 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 45: 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 46: test_check("cutpointr")
  
   --- value of length: 2 type: logical ---
  [1]  TRUE FALSE
   --- function from context --- 
  function (m, m_name, n, silent = TRUE) 
  {
      if ("data.frame" %in% class(m)) {
          m <- as.matrix(m)
      }
      if (!is.null(dim(m))) {
          if (dim(m)[2] == 1 & class(m) == "matrix") {
              res <- m
              if (is.null(colnames(res))) 
                  colnames(res) <- m_name
          }
          else {
              stop(paste("The metric function should return a numeric vector", 
                  "or a one-column matrix or data.frame."))
          }
      }
      else if (is.numeric(m)) {
          res <- matrix(m, ncol = 1, dimnames = list(NULL, m_name))
      }
      else {
          stop(paste("Can't process metric of type", class(m)))
      }
      finite_res <- is.finite(res)
      if (any(!finite_res)) {
          if (!silent) 
              message("Converting non-finite metric values to NA")
          res[!finite_res] <- NA
      }
      if (nrow(res) != n) {
          stop("Number of returned metric values not equal to n")
      }
      colnames(res) <- make.names(colnames(res))
      return(res)
  }
  <bytecode: 0x1455ad8>
  <environment: namespace:cutpointr>
   --- function search by body ---
  Function sanitize_metric in namespace cutpointr has this body.
   ----------- END OF FAILURE REPORT -------------- 
  -- 48. Error: Bootstrap works with multiple cutpoints when not breaking ties (@t
  the condition has length > 1
  Backtrace:
   1. cutpointr::cutpointr(tempdat, x, y, break_ties = c, boot_runs = 200)
   2. cutpointr:::cutpointr.default(...)
   3. cutpointr:::cutpointr_internal(...)
   4. cutpointr:::method(...)
   5. cutpointr:::optimize_metric(...)
   6. cutpointr:::sanitize_metric(m, m_name = metric_name, n = nrow(roccurve))
  
  == testthat results  ===========================================================
  [ OK: 71 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 48 ]
  1. Error: Cutpointr returns a cutpointr without NAs and a certain Nr of rows (@test-cutpointr.R#7) 
  2. Error: Cutpointr works with different data types (@test-cutpointr.R#23) 
  3. Error: Bootstrap does not return duplicate colnames (@test-cutpointr.R#82) 
  4. Error: Plotting with bootstrapping is silent (@test-cutpointr.R#98) 
  5. Error: AUC calculation is correct and works with Inf and -Inf (@test-cutpointr.R#115) 
  6. Error: Correct midpoints are found (@test-cutpointr.R#139) 
  7. Error: find_metric_name finds metric (@test-cutpointr.R#150) 
  8. Error: no duplicate column names are returned (@test-cutpointr.R#172) 
  9. Error: Correct cutpoints with example data (@test-cutpointr.R#202) 
  1. ...
  
  Error: testthat unit tests failed
  Execution halted