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

20
plot.ci.thresholds <- function(x, length=.01*ifelse(attr(x, "roc")$percent, 100, 1), col=par("fg"), ...) {
21 14
  bounds <- cbind(x$sp, x$se)
22 14
  apply(bounds, 1, function(x, ...) {
23 14
    suppressWarnings(segments(x[2], x[4], x[2], x[6], col=col, ...))
24 14
    suppressWarnings(segments(x[2] - length, x[4], x[2] + length, x[4], col=col, ...))
25 14
    suppressWarnings(segments(x[2] - length, x[6], x[2] + length, x[6], col=col, ...))
26 14
    suppressWarnings(segments(x[1], x[5], x[3], x[5], col=col, ...))
27 14
    suppressWarnings(segments(x[1], x[5] + length, x[1], x[5] - length, col=col, ...))
28 14
    suppressWarnings(segments(x[3], x[5] + length, x[3], x[5] - length, col=col, ...))
29
  }, ...)
30 14
  invisible(x)
31
}
32

33
plot.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 14
  type <- match.arg(type)
35 14
  if (type == "bars") {
36 14
    sapply(1:dim(x)[1], function(n, ...) {
37 14
      se <- attr(x, "sensitivities")[n]
38 14
      suppressWarnings(segments(x[n,1], se, x[n,3], se, col=col, ...))
39 14
      suppressWarnings(segments(x[n,1], se - length, x[n,1], se + length, col=col, ...))
40 14
      suppressWarnings(segments(x[n,3], se - length, x[n,3], se + length, col=col, ...))
41
    }, ...)
42
  }
43
  else {
44 0
    if (length(x[,1]) < 15)
45 0
      warning("Low definition shape.")
46 0
    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 0
    if (!no.roc)
48 0
      plot(attr(x, "roc"), add=TRUE)
49
  }
50 14
  invisible(x)
51
}
52

53

54
plot.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 14
  type <- match.arg(type)
56 14
  if (type == "bars") {
57 0
    sapply(1:dim(x)[1], function(n, ...) {
58 0
      sp <- attr(x, "specificities")[n]
59 0
      suppressWarnings(segments(sp, x[n,1], sp, x[n,3], col=col, ...))
60 0
      suppressWarnings(segments(sp - length, x[n,1], sp + length, x[n,1], col=col, ...))
61 0
      suppressWarnings(segments(sp - length, x[n,3], sp + length, x[n,3], col=col, ...))
62
    }, ...)
63
  }
64
  else {
65 14
    if (length(x[,1]) < 15)
66 0
      warning("Low definition shape.")
67 14
    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 14
    if (!no.roc)
69 14
      plot(attr(x, "roc"), add=TRUE)
70
  }
71 14
  invisible(x)
72
}

Read our documentation on viewing source code .

Loading