- using R Under development (unstable) (2019-12-11 r77556)
- using platform: x86_64-pc-linux-gnu (64-bit)
- using session charset: ISO8859-15
- checking for file 'cutpointr/DESCRIPTION' ... OK
- checking extension type ... Package
- this is package 'cutpointr' version '1.0.0'
- package encoding: UTF-8
- checking package namespace information ... OK
- checking package dependencies ... OK
- checking if this is a source package ... OK
- checking if there is a namespace ... OK
- checking for executable files ... OK
- checking for hidden files and directories ... OK
- checking for portable file names ... OK
- checking for sufficient/correct file permissions ... OK
- checking whether package 'cutpointr' can be installed ... OK
- checking package directory ... OK
- checking for future file timestamps ... OK
- checking 'build' directory ... OK
- checking DESCRIPTION meta-information ... OK
- checking top-level files ... OK
- checking for left-over files ... OK
- checking index information ... OK
- checking package subdirectories ... OK
- checking R files for non-ASCII characters ... OK
- checking R files for syntax errors ... OK
- checking whether the package can be loaded ... OK
- checking whether the package can be loaded with stated dependencies ... OK
- checking whether the package can be unloaded cleanly ... OK
- checking whether the namespace can be loaded with stated dependencies ... OK
- checking whether the namespace can be unloaded cleanly ... OK
- checking loading without being on the library search path ... OK
- checking use of S3 registration ... OK
- checking dependencies in R code ... OK
- checking S3 generic/method consistency ... OK
- checking replacement functions ... OK
- checking foreign function calls ... OK
- checking R code for possible problems ... [17s/20s] OK
- checking Rd files ... OK
- checking Rd metadata ... OK
- checking Rd line widths ... OK
- checking Rd cross-references ... OK
- checking for missing documentation entries ... OK
- checking for code/documentation mismatches ... OK
- checking Rd \usage sections ... OK
- checking Rd contents ... OK
- checking for unstated dependencies in examples ... OK
- checking contents of 'data' directory ... OK
- checking data for non-ASCII characters ... OK
- checking data for ASCII and uncompressed saves ... OK
- checking line endings in C/C++/Fortran sources/headers ... OK
- checking pragmas in C/C++ headers and code ... OK
- checking compilation flags used ... OK
- checking compiled code ... OK
- checking installed files from 'inst/doc' ... OK
- checking files in 'vignettes' ... OK
- checking examples ... ERROR
Running examples in 'cutpointr-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: add_metric
> ### Title: Add metrics to a cutpointr or roc_cutpointr object
> ### Aliases: add_metric
>
> ### ** Examples
>
> library(dplyr)
Attaching package: 'dplyr'
The following objects are masked from 'package:stats':
filter, lag
The following objects are masked from 'package:base':
intersect, setdiff, setequal, union
> library(cutpointr)
> cutpointr(suicide, dsi, suicide, gender) %>%
+ add_metric(list(ppv, npv)) %>%
+ select(optimal_cutpoint, subgroup, AUC, sum_sens_spec, ppv, npv)
Assuming the positive class is yes
Assuming the positive class has higher x values
----------- 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(lhs, parent, parent)
where 10: eval(lhs, parent, parent)
where 11: cutpointr(suicide, dsi, suicide, gender) %>% add_metric(list(ppv,
npv)) %>% select(optimal_cutpoint, subgroup, AUC, sum_sens_spec,
ppv, npv)
--- 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: 0x209c698>
<environment: namespace:cutpointr>
--- function search by body ---
Function sanitize_metric in namespace cutpointr has this body.
----------- END OF FAILURE REPORT --------------
Error in if (dim(m)[2] == 1 & class(m) == "matrix") { :
the condition has length > 1
Calls: %>% ... <Anonymous> -> .f -> method -> optimize_metric -> sanitize_metric
Execution halted
- checking for unstated dependencies in 'tests' ... OK
- checking tests ... [27s/29s] ERROR
Running 'testthat.R' [26s/29s]
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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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: 0x20dfd70>
<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
- checking for unstated dependencies in vignettes ... OK
- checking package vignettes in 'inst/doc' ... OK
- checking re-building of vignette outputs ... [4s/4s] WARNING
Error(s) in re-building vignettes:
...
--- re-building 'cutpointr.Rmd' using rmarkdown
----------- 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, method = maximize_metric,
metric = sum_sens_spec)
where 6: cutpointr(suicide, dsi, suicide, method = maximize_metric, metric = sum_sens_spec)
where 7: eval(expr, envir, enclos)
where 8: eval(expr, envir, enclos)
where 9: withVisible(eval(expr, envir, enclos))
where 10: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 11: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 12: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 13: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 14: evaluate::evaluate(...)
where 15: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 16: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 17: block_exec(params)
where 18: call_block(x)
where 19: process_group.block(group)
where 20: process_group(group)
where 21: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 22: process_file(text, output)
where 23: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet,
encoding = encoding)
where 24: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
...)
where 25: vweave_rmarkdown(...)
where 26: engine$weave(file, quiet = quiet, encoding = enc)
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
outputs <- c(outputs, output)
}, error = function(e) {
thisOK <<- FALSE
fails <<- c(fails, file)
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 31: tools:::buildVignettes(dir = "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/cutpointr.Rcheck/vign_test/cutpointr",
ser_elibs = "/tmp/Rtmpzyyhfw/file1a2b5fb34732.rds")
--- 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: 0x1644320>
<environment: namespace:cutpointr>
--- function search by body ---
Function sanitize_metric in namespace cutpointr has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 37-43 (cutpointr.Rmd)
Error: processing vignette 'cutpointr.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building 'cutpointr.Rmd'
SUMMARY: processing the following file failed:
'cutpointr.Rmd'
Error: Vignette re-building failed.
Execution halted
- checking PDF version of manual ... OK
- checking for non-standard things in the check directory ... OK
- DONE
Status: 2 ERRORs, 1 WARNING