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
are.paired <- function(...) {
21 29
  UseMethod("are.paired")
22
}
23

24
are.paired.auc <- function(roc1, roc2, ...) {
25 29
  return(are.paired.roc(roc1, roc2, ...))
26
}
27

28
are.paired.smooth.roc <- function(roc1, roc2, ...) {
29 29
  return(are.paired.roc(roc1, roc2, ...))
30
}
31

32
are.paired.roc <- function(roc1, roc2,
33
                           return.paired.rocs=FALSE,
34
                           reuse.auc = TRUE, reuse.ci = FALSE, reuse.smooth=TRUE,
35
                           ...) {
36
  # check return.paired.rocs
37 29
  if (! is.logical(return.paired.rocs) || length(return.paired.rocs) != 1)
38 0
    stop("'return.paired.rocs' must be either TRUE or FALSE.")
39
  # Recover base ROC curves (not auc or smoothed)
40 29
  if ("auc" %in% class(roc1))
41 29
    roc1 <- attr(roc1, "roc")
42 29
  if ("auc" %in% class(roc2))
43 29
    roc2 <- attr(roc2, "roc")
44 29
  if ("smooth.roc" %in% class(roc1)) {
45 29
    oroc1 <- roc1
46 29
    roc1 <- attr(roc1, "roc")
47
  }
48 29
  if ("smooth.roc" %in% class(roc2)) {
49 29
    oroc2 <- roc2
50 29
    roc2 <- attr(roc2, "roc")
51
  }
52
  # Check if the levels are the same. Otherwise it is not paired.
53 29
  if (!identical(roc1$levels, roc2$levels))
54 29
    return(FALSE)
55
  # check if responses of roc 1 and 2 are identical
56 29
  if (identical(roc1$response, roc2$response)) {
57 29
    retval <- TRUE
58 29
    if (return.paired.rocs) {
59 29
      attr(retval, "roc1") <- roc1
60 29
      attr(retval, "roc2") <- roc2
61
    }
62 29
    return(retval)
63
  }
64
  else {
65
    # Make sure the difference is not only due to missing values
66
    # compare original response (with NAs and response not in levels)
67 29
    if (identical(roc1$original.response, roc2$original.response)) {
68 29
      retval <- TRUE
69 29
      if (! return.paired.rocs)
70 29
        return(retval)
71
      # else prepare paired ROCs
72 29
      idx.exclude <- is.na(roc1$original.predictor) | is.na(roc2$original.predictor) | is.na(roc1$original.response) | ! roc1$original.response %in% roc1$levels
73 29
      roc1.paired <- roc(roc1$original.response[!idx.exclude], roc1$original.predictor[!idx.exclude], levels=roc1$levels, percent=roc1$percent, na.rm=FALSE, direction=roc1$direction, auc=FALSE)
74 29
      roc2.paired <- roc(roc2$original.response[!idx.exclude], roc2$original.predictor[!idx.exclude], levels=roc2$levels, percent=roc2$percent, na.rm=FALSE, direction=roc2$direction, auc=FALSE)
75
      # Re-use auc/ci/smooth for roc1
76 29
      if (exists("oroc1") && reuse.smooth) {
77 29
        args <- oroc1$smoothing.args
78 29
        args$roc <- roc1.paired
79 29
        roc1.paired <- do.call("smooth.roc", args)
80 29
        roc1.paired$call$roc <- as.name("roc1.paired")
81
      }
82 29
      if (!is.null(roc1$auc) && reuse.auc) {
83 29
        args <- attributes(roc1$auc)
84 29
        args$roc <- roc1.paired
85 29
        roc1.paired$auc <- do.call("auc.roc", args)
86
      }
87 29
      if (!is.null(roc1$ci) && reuse.ci) {
88 0
        args <- attributes(roc1$ci)
89 0
        args$roc <- NULL
90 0
        roc1.paired$ci <- do.call(class(roc1$ci)[1], c(roc=list(roc1.paired), args))
91
      }
92
      # Re-use auc/ci/smooth for roc2
93 29
      if (exists("oroc2") && reuse.smooth) {
94 29
        args <- oroc2$smoothing.args
95 29
        args$roc <- roc2.paired
96 29
        roc2.paired <- do.call("smooth.roc", args)
97 29
        roc2.paired$call$roc <- as.name("roc2.paired")
98
      }
99 29
      if (!is.null(roc2$auc) && reuse.auc) {
100 29
        args <- attributes(roc2$auc)
101 29
        args$roc <- roc2.paired
102 29
        roc2.paired$auc <- do.call("auc.roc", args)
103
      }
104 29
      if (!is.null(roc2$ci) && reuse.ci) {
105 0
        args <- attributes(roc2$ci)
106 0
        args$roc <- NULL
107 0
        roc2.paired$ci <- do.call(class(roc2$ci)[1], c(roc=list(roc2.paired), args))
108
      }
109

110
      # Attach ROCs and return value
111 29
      attr(retval, "roc1") <- roc1.paired
112 29
      attr(retval, "roc2") <- roc2.paired
113 29
      return(retval)
114
    }
115
    else {
116 29
      return(FALSE)
117
    }
118
  }
119
}

Read our documentation on viewing source code .

Loading