1# pROC: Tools Receiver operating characteristic (ROC curves) with
2# (partial) area under the curve, confidence intervals and comparison.
3# Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck,
4# Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez
5# and Markus Müller
6#
7# This program is free software: you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation, either version 3 of the License, or
10# (at your option) any later version.
11#
12# This program is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with this program.  If not, see <http://www.gnu.org/licenses/>.
19
20plot.ci.thresholds <- function(x, length=.01*ifelse(attr(x, "roc")$percent, 100, 1), col=par("fg"), ...) {
21  bounds <- cbind(x$sp, x$se)
22  apply(bounds, 1, function(x, ...) {
23    suppressWarnings(segments(x[2], x[4], x[2], x[6], col=col, ...))
24    suppressWarnings(segments(x[2] - length, x[4], x[2] + length, x[4], col=col, ...))
25    suppressWarnings(segments(x[2] - length, x[6], x[2] + length, x[6], col=col, ...))
26    suppressWarnings(segments(x[1], x[5], x[3], x[5], col=col, ...))
27    suppressWarnings(segments(x[1], x[5] + length, x[1], x[5] - length, col=col, ...))
28    suppressWarnings(segments(x[3], x[5] + length, x[3], x[5] - length, col=col, ...))
29  }, ...)
30  invisible(x)
31}
32
33plot.ci.sp <- function(x, type=c("bars", "shape"), length=.01*ifelse(attr(x, "roc")$percent, 100, 1), col=ifelse(type=="bars", par("fg"), "gainsboro"), no.roc=FALSE, ...) {
34  type <- match.arg(type)
35  if (type == "bars") {
36    sapply(1:dim(x)[1], function(n, ...) {
37      se <- attr(x, "sensitivities")[n]
38      suppressWarnings(segments(x[n,1], se, x[n,3], se, col=col, ...))
39      suppressWarnings(segments(x[n,1], se - length, x[n,1], se + length, col=col, ...))
40      suppressWarnings(segments(x[n,3], se - length, x[n,3], se + length, col=col, ...))
41    }, ...)
42  }
43  else {
44    if (length(x[,1]) < 15)
45      warning("Low definition shape.")
46    suppressWarnings(polygon(c(1*ifelse(attr(x, "roc")$percent, 100, 1), x[,1], 0, rev(x[,3]), 1*ifelse(attr(x, "roc")$percent, 100, 1)), c(0, attr(x, "sensitivities"), 1*ifelse(attr(x, "roc")$percent, 100, 1), rev(attr(x, "sensitivities")), 0), col=col, ...))
47    if (!no.roc)
48      plot(attr(x, "roc"), add=TRUE)
49  }
50  invisible(x)
51}
52
53
54plot.ci.se <- function(x, type=c("bars", "shape"), length=.01*ifelse(attr(x, "roc")$percent, 100, 1), col=ifelse(type=="bars", par("fg"), "gainsboro"), no.roc=FALSE, ...) {
55  type <- match.arg(type)
56  if (type == "bars") {
57    sapply(1:dim(x)[1], function(n, ...) {
58      sp <- attr(x, "specificities")[n]
59      suppressWarnings(segments(sp, x[n,1], sp, x[n,3], col=col, ...))
60      suppressWarnings(segments(sp - length, x[n,1], sp + length, x[n,1], col=col, ...))
61      suppressWarnings(segments(sp - length, x[n,3], sp + length, x[n,3], col=col, ...))
62    }, ...)
63  }
64  else {
65    if (length(x[,1]) < 15)
66      warning("Low definition shape.")
67    suppressWarnings(polygon(c(0, attr(x, "specificities"), 1*ifelse(attr(x, "roc")$percent, 100, 1), rev(attr(x, "specificities")), 0), c(1*ifelse(attr(x, "roc")$percent, 100, 1), x[,1], 0, rev(x[,3]), 1*ifelse(attr(x, "roc")$percent, 100, 1)), col=col, ...))
68    if (!no.roc)
69      plot(attr(x, "roc"), add=TRUE)
70  }
71  invisible(x)
72}
73