pROC: Display and Analyze ROC Curves

library(pROC)
data(aSAH)

context("print")

test_that("print.auc works", {
	expect_output(print(auc(r.wfns)), "^Area under the curve: 0.8237$")
	expect_output(print(auc(r.ndka.percent)), "^Area under the curve: 61.2%$")
	
	expect_output(print(r.ndka.partial1$auc), "^Partial area under the curve \\(specificity 0\\.99-0\\.9\\): 0\\.01046$")
	expect_output(print(r.s100b.percent.partial1$auc), "^Partial area under the curve \\(specificity 99%-90%\\): 2.983%$")
	expect_output(print(r.s100b.partial2$auc), "^Partial area under the curve \\(sensitivity 0.99-0.9\\): 0.01376$")
})

test_that("print.roc works", {
	expect_known_output(print(r.wfns), "print_output/r.wfns")
	expect_known_output(print(r.ndka), "print_output/r.ndka")
	expect_known_output(print(r.s100b), "print_output/r.s100b")
	expect_known_output(print(r.wfns.percent), "print_output/r.wfns.percent")
	expect_known_output(print(r.ndka.percent), "print_output/r.ndka.percent")
	expect_known_output(print(r.s100b.percent), "print_output/r.s100b.percent")
	expect_known_output(print(r.wfns.partial1), "print_output/r.wfns.partial1")
	expect_known_output(print(r.ndka.partial1), "print_output/r.ndka.partial1")
	expect_known_output(print(r.s100b.partial1), "print_output/r.s100b.partial1")
	expect_known_output(print(r.wfns.percent.partial1), "print_output/r.wfns.percent.partial1")
	expect_known_output(print(r.ndka.percent.partial1), "print_output/r.ndka.percent.partial1")
	expect_known_output(print(r.s100b.percent.partial1), "print_output/r.s100b.percent.partial1")
	expect_known_output(print(r.s100b.partial2), "print_output/r.s100b.partial2")
	expect_known_output(print(roc(outcome ~ ndka, aSAH)), "print_output/ndka_formula")
})

test_that("print.multiclass.roc works", {
	expect_warning(expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka)), "print_output/multiclass"), "2")
	expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka, levels=c(3, 4, 5))), "print_output/multiclass_levels")
	expect_warning(expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka, percent=TRUE)), "print_output/multiclass_percent"), "2")
})

test_that("print.multiclass.roc works", {
	expect_warning(expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka)), "print_output/multiclass"), "2")
	expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka, levels=c(3, 4, 5))), "print_output/multiclass_levels")
	expect_warning(expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka, percent=TRUE)), "print_output/multiclass_percent"), "2")
	expect_warning(expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka, partial.auc=c(1, .9))), "print_output/multiclass_partial"), "2")
	expect_warning(expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$ndka, partial.auc=c(1, .9), partial.auc.focus="se")), "print_output/multiclass_partial_se"), "2")
	expect_warning(expect_known_output(print(multiclass.roc(aSAH$gos6, aSAH$wfns, partial.auc=c(1, .9), partial.auc.correct=TRUE)), "print_output/multiclass_partial_correct"), "2")
})

test_that("print.multiclass_roc_multivariate works", {
	n <- c(100, 80, 150)
	responses <- factor(c(rep("X1", n[1]), rep("X2", n[2]), rep("X3", n[3])))
	set.seed(42)
	preds <- lapply(n, function(x) runif(x, 0.4, 0.6))
	predictor <- as.matrix(data.frame(
		"X1" = c(preds[[1]], runif(n[2] + n[3], 0, 0.7)),
		"X2" = c(runif(n[1], 0.1, 0.4), preds[[2]], runif(n[3], 0.2, 0.8)),
		"X3" = c(runif(n[1] + n[2], 0.3, 0.7), preds[[3]])
	))
	expect_known_output(print(multiclass.roc(responses, predictor)), "print_output/mv_multiclass")
	
	expect_warning(expect_known_output(print(multiclass.roc(responses, predictor, levels=c("X2", "X3"))), "print_output/mv_multiclass_levels"), "X1")
	expect_known_output(print(multiclass.roc(responses, predictor, percent=TRUE)), "print_output/mv_multiclass_percent")
	expect_known_output(print(multiclass.roc(responses, predictor, partial.auc=c(1, .9))), "print_output/mv_multiclass_partial")
	expect_known_output(print(multiclass.roc(responses, predictor, partial.auc=c(1, .9), partial.auc.focus="se")), "print_output/mv_multiclass_partial_se")
	expect_known_output(print(multiclass.roc(responses, predictor, partial.auc=c(1, .9), partial.auc.correct=TRUE)), "print_output/mv_multiclass_partial_correct")
})

test_that("print works with a formula", {
	expect_known_output(print(roc(outcome ~ ndka, aSAH)), "print_output/r.ndka.formula")
	expect_warning(expect_known_output(print(multiclass.roc(gos6 ~ ndka, aSAH)), "print_output/mv_multiclass.ndka.formula"), "2")
})

test_that("print works without the auc", {
	expect_known_output(print(roc(outcome ~ ndka, aSAH, auc=FALSE)), "print_output/r.ndka.formula.no_auc")
})

test_that("print works with the CI", {
	skip_slow()
	if (getRversion() > "3.6.0") {
		suppressWarnings(RNGkind(sample.kind="Rounding"))
	}
	set.seed(42) # For reproducible CI
	expect_known_output(print(roc(outcome ~ ndka, aSAH, ci=TRUE)), "print_output/r.ndka.formula.ci")
})

test_that("print.smooth.roc works", {
	expect_known_output(print(smooth(roc(aSAH$outcome, aSAH$ndka))), "print_output/smooth.ndka")
	expect_known_output(print(smooth(roc(outcome ~ s100b, aSAH))), "print_output/smooth.s100b.formula")
	expect_known_output(print(smooth(roc(aSAH$outcome, aSAH$ndka))), "print_output/smooth.wfns")
	expect_known_output(print(smooth(roc(aSAH$outcome, aSAH$ndka), method="binormal")), "print_output/smooth.s100b.binormal")
	expect_known_output(print(smooth(roc(outcome ~ s100b, aSAH), method="fitdistr")), "print_output/smooth.s100b.fitdistr")
	expect_known_output(print(smooth(roc(outcome ~ s100b, aSAH), method="density")), "print_output/smooth.s100b.density")
	
	testthat::skip_if_not_installed("logcondens")
	expect_known_output(print(smooth(roc(outcome ~ s100b, aSAH), method="logcondens")), "print_output/smooth.s100b.logcondens")
	expect_known_output(print(smooth(roc(outcome ~ s100b, aSAH), method="logcondens.smooth")), "print_output/smooth.s100b.logcondens.smooth")
})

test_that("print works with ci.auc", {
	skip_slow()
	skip_if(getRversion() < "3.6.0")  # added sample.kind
	RNGkind(sample.kind="Rejection")

	set.seed(42) # For reproducible CI
	expect_known_output(print(ci.auc(r.ndka, method = "bootstrap", boot.n = 3, progress = "none")), "print_output/r.ndka.ci.auc")
})

test_that("print works with ci.coords", {
	skip_slow()
	skip_if(getRversion() < "3.6.0")  # added sample.kind
	RNGkind(sample.kind="Rejection")
	
	set.seed(42) # For reproducible CI
	expect_known_output(print(ci.coords(r.ndka, x = c(0.5, 0.2), boot.n = 3, progress = "none")), "print_output/r.ndka.ci.coords")
})

test_that("print works with ci.thresholds", {
	skip_slow()
	skip_if(getRversion() < "3.6.0")  # added sample.kind
	RNGkind(sample.kind="Rejection")
	
	set.seed(42) # For reproducible CI
	expect_known_output(print(ci.thresholds(r.ndka, thresholds = c(0.5, 0.2), boot.n = 3, progress = "none")), "print_output/r.ndka.ci.thresholds")
})

test_that("print works with ci.se", {
	skip_slow()
	skip_if(getRversion() < "3.6.0")  # added sample.kind
	RNGkind(sample.kind="Rejection")
	
	set.seed(42) # For reproducible CI
	expect_known_output(print(ci.se(r.ndka, boot.n = 3, progress = "none")), "print_output/r.ndka.ci.se")
})

test_that("print works with ci.sp", {
	skip_slow()
	skip_if(getRversion() < "3.6.0")  # added sample.kind
	RNGkind(sample.kind="Rejection")
	
	set.seed(42) # For reproducible CI
	expect_known_output(print(ci.sp(r.ndka, boot.n = 3, progress = "none")), "print_output/r.ndka.ci.sp")
})

test_that("print works with a formula passed as variable", {
	x <- outcome ~ ndka
	expect_known_output(print(roc(x, aSAH)), "print_output/ndka_formula_var")
})

test_that("print works with a formula with data attached", {
	attach(aSAH)
	x <- outcome ~ ndka
	expect_known_output(print(roc(x)), "print_output/ndka_formula_var_attached")
	expect_known_output(print(roc(outcome ~ ndka)), "print_output/ndka_formula_attached")
	detach(aSAH)
})

test_that("print works with a formula with data attached with 'with'", {
	x <- outcome ~ ndka
	expect_known_output(with(aSAH, print(roc(x))), "print_output/ndka_formula_var_attached")
	expect_known_output(with(aSAH, print(roc(outcome ~ ndka))), "print_output/ndka_formula_attached")
})