From bd984d5a01fa76a17bd54e4efb6e6abd0396ad29 Mon Sep 17 00:00:00 2001 From: Xavier Robin Date: Sun, 11 Aug 2024 16:02:16 +0200 Subject: [PATCH] Add geom_polygon_auc function (issue #129) --- NAMESPACE | 5 ++ R/geom_polygon_auc.R | 48 ++++++++++++ R/ggroc.R | 8 +- man/geom_polygon_auc.roc.Rd | 56 ++++++++++++++ .../geom-polygon-auc-partial-screenshot.svg | 76 +++++++++++++++++++ ...-polygon-auc-percent-legacy-screenshot.svg | 75 ++++++++++++++++++ .../geom-polygon-auc-screenshot.svg | 75 ++++++++++++++++++ tests/testthat/helper-rocs.R | 1 + tests/testthat/test-geom_polygon_auc.R | 27 +++++++ 9 files changed, 367 insertions(+), 4 deletions(-) create mode 100644 R/geom_polygon_auc.R create mode 100644 man/geom_polygon_auc.roc.Rd create mode 100644 tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-partial-screenshot.svg create mode 100644 tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-percent-legacy-screenshot.svg create mode 100644 tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-screenshot.svg create mode 100644 tests/testthat/test-geom_polygon_auc.R diff --git a/NAMESPACE b/NAMESPACE index 0fa2efb..8e78021 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -153,6 +153,11 @@ S3method("ggroc", "roc") S3method("ggroc", "smooth.roc") S3method("ggroc", "list") +export(geom_polygon_auc) +S3method("geom_polygon_auc", "auc") +S3method("geom_polygon_auc", "roc") +S3method("geom_polygon_auc", "smooth.roc") + #export(select) #export(select_) #importFrom("dplyr", "select") diff --git a/R/geom_polygon_auc.R b/R/geom_polygon_auc.R new file mode 100644 index 0000000..453a0db --- /dev/null +++ b/R/geom_polygon_auc.R @@ -0,0 +1,48 @@ +geom_polygon_auc <- function(data, ...) { + UseMethod("geom_polygon_auc") +} + +geom_polygon_auc.auc <- function(data, legacy.axes = FALSE, ...) { + # Get the roc data with coords + roc <- attr(data, "roc") + roc$auc <- data + df <- get.coords.for.ggplot(roc, ignore.partial.auc = FALSE) + + # Add bottom-right point + partial.auc <- attr(data, "partial.auc") + one.or.hundred <- ifelse(attr(data, "percent"), 100, 1) + if (legacy.axes) { + if (identical(partial.auc, FALSE)) { + df[nrow(df) + 1, ] <- c(NA, one.or.hundred, 0, one.or.hundred) + } + else if (attr(data, "partial.auc.focus") == "sensitivity") { + df[nrow(df) + c(1, 2), ] <- c(NA, NA, one.or.hundred, one.or.hundred, partial.auc, one.or.hundred, one.or.hundred) + } + else { # partial.auc.focus == "specificity" + df[nrow(df) + c(1, 2), ] <- c(NA, NA, rev(partial.auc), 0, 0, one.or.hundred - rev(partial.auc)) + } + } + else { + if (identical(partial.auc, FALSE)) { + df[nrow(df) + 1, ] <- c(NA, 0, 0, 0) + } + else if (attr(data, "partial.auc.focus") == "sensitivity") { + df[nrow(df) + c(1, 2), ] <- c(NA, NA, 0, 0, partial.auc, 0, 0) + } + else { # partial.auc.focus == "specificity" + df[nrow(df) + c(1, 2), ] <- c(NA, NA, rev(partial.auc), 0, 0, one.or.hundred - rev(partial.auc)) + } + } + + # Prepare the aesthetics + aes <- get.aes.for.ggplot(attr(data, "roc"), legacy.axes) + + # Do the plotting + ggplot2::geom_polygon(aes$aes, data=df, ...) +} + +geom_polygon_auc.roc <- function(data, ...) { + geom_polygon_auc(data$auc, ...) +} + +geom_polygon_auc.smooth.roc <- geom_polygon_auc.roc diff --git a/R/ggroc.R b/R/ggroc.R index 9308377..d0723e7 100644 --- a/R/ggroc.R +++ b/R/ggroc.R @@ -1,7 +1,7 @@ # Returns the coords as a data.frame in the right ordering for ggplot2 -get.coords.for.ggplot <- function(roc) { - df <- coords(roc, "all", transpose = FALSE) +get.coords.for.ggplot <- function(roc, ignore.partial.auc) { + df <- coords(roc, "all", transpose = FALSE, ignore.partial.auc = ignore.partial.auc) df[["1-specificity"]] <- ifelse(roc$percent, 100, 1) - df[["specificity"]] return(df[rev(seq(nrow(df))),]) } @@ -61,7 +61,7 @@ ggroc <- function(data, ...) { ggroc.roc <- function(data, legacy.axes = FALSE, ...) { load.ggplot2() # Get the roc data with coords - df <- get.coords.for.ggplot(data) + df <- get.coords.for.ggplot(data, ignore.partial.auc = TRUE) # Prepare the aesthetics aes <- get.aes.for.ggplot(data, legacy.axes) @@ -101,7 +101,7 @@ ggroc.list <- function(data, aes = c("colour", "alpha", "linetype", "linewidth", } # Get the coords - coord.dfs <- sapply(data, get.coords.for.ggplot, simplify = FALSE) + coord.dfs <- sapply(data, get.coords.for.ggplot, simplify = FALSE, ignore.partial.auc = TRUE) # Add a "name" colummn for (i in seq_along(coord.dfs)) { diff --git a/man/geom_polygon_auc.roc.Rd b/man/geom_polygon_auc.roc.Rd new file mode 100644 index 0000000..e838f99 --- /dev/null +++ b/man/geom_polygon_auc.roc.Rd @@ -0,0 +1,56 @@ +\encoding{UTF-8} +\name{geom_polygon_auc} +\alias{geom_polygon_auc.auc} +\alias{geom_polygon_auc.roc} +\alias{geom_polygon_auc.smooth.roc} +\alias{geom_polygon_auc} + +\title{ + Add an AUC polygon to a ggroc plot +} +\description{ + EXPERIMENTAL - Add an AUC polygon to a ggroc plot. +} +\usage{ +\S3method{geom_polygon_auc}{roc}(data, legacy.axes = FALSE, ...) +\S3method{geom_polygon_auc}{smooth.roc}(data, legacy.axes = FALSE, ...) +} + +\arguments{ + \item{data}{a roc object from the \link{roc} function, same as the one + used to build the ggroc initially. + } + \item{legacy.axes}{must match the value given to \code{ggroc}. + } + \item{...}{additional aesthetics for \code{\link[ggplot2:geom_polygon]{geom_polygon}} + to set: \code{alpha}, \code{colour}, \code{linetype} and \code{linewidth}. + } +} + +\details{ +} + + +\seealso{ +\code{\link{ggroc}} +} +\examples{ + +# Create a ROC curve: +data(aSAH) +roc.s100b <- roc(aSAH$outcome, aSAH$s100b) +roc.s100b.percent <- roc(aSAH$outcome, aSAH$s100b, percent = TRUE) + +ggroc(roc.s100b) + geom_polygon_auc(roc.s100b$auc) + +# legacy.axes must be repeated +ggroc(roc.s100b.percent, legacy.axes=TRUE) + geom_polygon_auc(roc.s100b.percent, legacy.axes=TRUE) + +# Partial AUCs +auc.s100b.partial.sp <- auc(roc.s100b, partial.auc = c(0.9, 1)) +auc.s100b.partial.se <- auc(roc.s100b, partial.auc = c(0.8, 0.9), partial.auc.focus="se") + +ggroc(roc.s100b) + geom_polygon_auc(auc.s100b.partial.sp) +ggroc(roc.s100b) + geom_polygon_auc(auc.s100b.partial.se) + +} diff --git a/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-partial-screenshot.svg b/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-partial-screenshot.svg new file mode 100644 index 0000000..c982a0b --- /dev/null +++ b/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-partial-screenshot.svg @@ -0,0 +1,76 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +specificity +sensitivity + + diff --git a/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-percent-legacy-screenshot.svg b/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-percent-legacy-screenshot.svg new file mode 100644 index 0000000..c852d3e --- /dev/null +++ b/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-percent-legacy-screenshot.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +25 +50 +75 +100 + + + + + + + + + + +0 +25 +50 +75 +100 +1-specificity +sensitivity + + diff --git a/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-screenshot.svg b/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-screenshot.svg new file mode 100644 index 0000000..d67e13d --- /dev/null +++ b/tests/testthat/_snaps/geom_polygon_auc/geom-polygon-auc-screenshot.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +specificity +sensitivity + + diff --git a/tests/testthat/helper-rocs.R b/tests/testthat/helper-rocs.R index 5d42248..ed90fb2 100644 --- a/tests/testthat/helper-rocs.R +++ b/tests/testthat/helper-rocs.R @@ -21,3 +21,4 @@ r.ndka.percent.partial1 <- roc(aSAH$outcome, aSAH$ndka, percent = TRUE, quiet = r.s100b.percent.partial1 <- roc(aSAH$outcome, aSAH$s100b, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99)) r.s100b.partial2 <- roc(aSAH$outcome, aSAH$s100b, quiet = TRUE, partial.auc = c(.9, .99), partial.auc.focus = "se") +r.s100b.percent.partial2 <- roc(aSAH$outcome, aSAH$s100b, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99), partial.auc.focus = "se") diff --git a/tests/testthat/test-geom_polygon_auc.R b/tests/testthat/test-geom_polygon_auc.R new file mode 100644 index 0000000..1140918 --- /dev/null +++ b/tests/testthat/test-geom_polygon_auc.R @@ -0,0 +1,27 @@ +context("geom_polygon_auc") + +test_that("geom_polygon_auc works", { + test_geom_polygon_auc_screenshot <- function() { + print(ggroc(r.s100b) + geom_polygon_auc(r.s100b$auc)) + } + expect_ggroc_doppelganger("geom_polygon_auc.screenshot", test_geom_polygon_auc_screenshot) +}) + +test_that("geom_polygon_auc works with percent and legacy.axes = TRUE", { + test_geom_polygon_auc_percent_legacy_screenshot <- function() { + print(ggroc(r.s100b.percent, legacy.axes = TRUE) + geom_polygon_auc(r.s100b.percent$auc, legacy.axes = TRUE)) + } + expect_ggroc_doppelganger("geom_polygon_auc.percent.legacy.screenshot", test_geom_polygon_auc_percent_legacy_screenshot) +}) + + +test_that("geom_polygon_auc works with percent and legacy.axes = TRUE", { + test_geom_polygon_auc_partial_screenshot <- function() { + auc_sp = auc(roc.s100b, partial.auc = c(0.8, 0.9), partial.auc.focus="sp") + auc_se = auc(roc.s100b, partial.auc = c(0.8, 0.9), partial.auc.focus="se") + print(ggroc(roc.s100b) + + geom_polygon_auc(auc_se) + + geom_polygon_auc(auc_sp)) + } + expect_ggroc_doppelganger("geom_polygon_auc.partial.screenshot", test_geom_polygon_auc_partial_screenshot) +})