tests/testthat/test-plot.R

In pROC: Display and Analyze ROC Curves

context("plot")

# Tests powered by vdiffr.
# To update the reference with vdiffr:
# > library(vdiffr)
# > source("tests/testthat.R")
# > manage_cases()

test_that("plot draws correctly", {
  skip_if(getRversion() < "4.1")
  test_basic_plot <- function() plot(r)
  # S100b
  r <- r.s100b
  expect_doppelganger("basic-s100b", test_basic_plot)

  r <- r.ndka
  expect_doppelganger("basic-ndka", test_basic_plot)

  r <- r.wfns
  expect_doppelganger("basic-wfns", test_basic_plot)
})

test_that("legacy.axis works correctly", {
  skip_if(getRversion() < "4.1")
  r <- r.s100b
  test_legacy.axis_plot <- function() plot(r, legacy.axes = TRUE)
  expect_doppelganger("legacy.axes", test_legacy.axis_plot)
})

test_that("Advanced screenshot 1 works correctly", {
  skip_if(getRversion() < "4.1")
  test_advanced_screenshot_1 <- function() {
    plot(r.s100b.percent,
      reuse.auc = FALSE, partial.auc = c(100, 90), partial.auc.correct = TRUE, # define a partial AUC (pAUC)
      print.auc = TRUE, # display pAUC value on the plot with following options:
      print.auc.pattern = "Corrected pAUC (100-90%% SP):\n%.1f%%", print.auc.col = "#1c61b6",
      auc.polygon = TRUE, auc.polygon.col = "#1c61b6", # show pAUC as a polygon
      max.auc.polygon = TRUE, max.auc.polygon.col = "#1c61b622", # also show the 100% polygon
      main = "Partial AUC (pAUC)"
    )

    plot(r.s100b.percent,
      reuse.auc = FALSE, partial.auc = c(100, 90), partial.auc.correct = TRUE,
      partial.auc.focus = "se", # focus pAUC on the sensitivity
      add = TRUE, type = "n", # add to plot, but don't re-add the ROC itself (useless)
      print.auc = TRUE, print.auc.pattern = "Corrected pAUC (100-90%% SE):\n%.1f%%", print.auc.col = "#008600",
      print.auc.y = 40, # do not print auc over the previous one
      auc.polygon = TRUE, auc.polygon.col = "#008600",
      max.auc.polygon = TRUE, max.auc.polygon.col = "#00860022"
    )
  }
  expect_doppelganger("advanced.screenshot.1", test_advanced_screenshot_1)
})


test_that("Advanced screenshot 2 works correctly", {
  skip_slow()
  skip_if(getRversion() < "4.1")
  test_advanced_screenshot_2 <- function() {
    RNGkind(sample.kind = "Rejection")
    set.seed(42) # For reproducible CI
    suppressMessages(rocobj <- plot.roc(aSAH$outcome, aSAH$s100b,
      main = "Confidence intervals", percent = TRUE,
      ci = TRUE, # compute AUC (of AUC by default)
      print.auc = TRUE
    )) # print the AUC (will contain the CI)

    ciobj <- ci.se(rocobj, # CI of sensitivity
      specificities = seq(0, 100, 5)
    ) # over a select set of specificities

    plot(ciobj, type = "shape", col = "#1c61b6AA") # plot as a blue shape
    plot(ci(rocobj, of = "thresholds", thresholds = "best")) # add one threshold
  }
  expect_doppelganger("advanced.screenshot.2", test_advanced_screenshot_2)
})


test_that("Advanced screenshot 3 works correctly", {
  skip_if(getRversion() < "4.4.0")
  test_advanced_screenshot_3 <- function() {
    plot(r.s100b.percent, main = "Smoothing")

    lines(smooth(r.s100b.percent), # smoothing (default: binormal)
      col = "#1c61b6"
    )

    lines(smooth(r.s100b.percent, method = "density"), # density smoothing
      col = "#008600"
    )

    lines(
      smooth(r.s100b.percent,
        method = "fitdistr", # fit a distribution
        density = "lognormal"
      ), # let the distribution be log-normal
      col = "#840000"
    )

    legend("bottomright", legend = c("Empirical", "Binormal", "Density", "Fitdistr\n(Log-normal)"), col = c("black", "#1c61b6", "#008600", "#840000"), lwd = 2)
  }
  expect_doppelganger("advanced.screenshot.3", test_advanced_screenshot_3)
})



test_that("Advanced screenshot 4 works correctly", {
  skip_slow()
  skip_if(getRversion() < "4.1")
  test_advanced_screenshot_4 <- function() {
    RNGkind(sample.kind = "Rejection")
    set.seed(42) # For reproducible CI
    suppressMessages(rocobj <- plot.roc(aSAH$outcome, aSAH$s100b,
      main = "Confidence intervals of specificity/sensitivity", percent = TRUE,
      ci = TRUE, of = "se", # ci of sensitivity
      specificities = seq(0, 100, 5), # on a select set of specificities
      ci.type = "shape", ci.col = "#1c61b6AA" # plot the CI as a blue shape
    ))

    plot(ci.sp(rocobj, sensitivities = seq(0, 100, 5)), # ci of specificity
      type = "bars"
    ) # print this one as bars
  }
  expect_doppelganger("advanced.screenshot.4", test_advanced_screenshot_4)
})



test_that("Advanced screenshot 5 works correctly", {
  skip_slow()
  skip_if(getRversion() < "4.1")
  test_advanced_screenshot_5 <- function() {
    RNGkind(sample.kind = "Rejection")
    set.seed(42) # For reproducible CI
    suppressMessages(plot.roc(aSAH$outcome, aSAH$s100b,
      main = "Confidence interval of a threshold", percent = TRUE,
      ci = TRUE, of = "thresholds", # compute AUC (of threshold)
      thresholds = "best", # select the (best) threshold
      print.thres = "best" # also highlight this threshold on the plot
    ))
  }
  expect_doppelganger("advanced.screenshot.5", test_advanced_screenshot_5)
})


test_that("Advanced screenshot 6 works correctly", {
  skip_if(getRversion() < "4.1")
  test_advanced_screenshot_6 <- function() {
    plot(r.s100b.percent, main = "Statistical comparison", col = "#1c61b6")
    lines(r.ndka.percent, col = "#008600")
    testobj <- roc.test(r.s100b.percent, r.ndka.percent)
    text(50, 50, labels = paste("p-value =", format.pval(testobj$p.value)), adj = c(0, .5))
    legend("bottomright", legend = c("S100B", "NDKA"), col = c("#1c61b6", "#008600"), lwd = 2)
  }
  expect_doppelganger("advanced.screenshot.6", test_advanced_screenshot_6)
})


test_that("plot and lines work with formula and subset", {
  skip_if(getRversion() < "4.1")
  test_plot_formula <- function() {
    suppressMessages(plot.roc(outcome ~ ndka, data = aSAH, subset = gender == "Female", col = "red"))
    suppressMessages(lines.roc(outcome ~ ndka, data = aSAH))
    suppressMessages(lines.roc(outcome ~ ndka, data = aSAH, subset = gender == "Male", col = "blue"))
  }
  expect_doppelganger("plot_formula", test_plot_formula)
})


test_that("PR curve with CI works", {
  skip_slow()
  skip_if(getRversion() < "4.1")
  test_plot_pr <- function() {
    RNGkind(sample.kind = "Rejection")
    set.seed(42) # For reproducible CI

    co <- coords(r.s100b, x = "all", input = "recall", ret = c("recall", "precision"))
    ci <- ci.coords(r.s100b, x = seq(0, 1, .1), input = "recall", ret = "precision")
    plot(co, type = "l", ylim = c(0, 1))
    testthat::expect_warning(plot(ci, type = "shape"), "Low definition shape")
    plot(ci, type = "bars")
    lines(co)
  }
  expect_doppelganger("plot_pr", test_plot_pr)
})