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
ci.auc <- function(...) {
21 1
  UseMethod("ci.auc")
22
}
23

24
ci.auc.formula <- function(formula, data, ...) {
25 1
	data.missing <- missing(data)
26 1
	roc.data <- roc.utils.extract.formula(formula, data, ..., 
27 1
										  data.missing = data.missing,
28 1
										  call = match.call())
29 1
	if (length(roc.data$predictor.name) > 1) {
30 0
		stop("Only one predictor supported in 'ci.auc'.")
31
	}
32 1
	response <- roc.data$response
33 1
	predictor <- roc.data$predictors[, 1]
34 1
	ci.auc.roc(roc.default(response, predictor, ci=FALSE, ...), ...)
35
}
36

37
ci.auc.default <- function(response, predictor, ...) {
38 1
	roc <- roc.default(response, predictor, ci = FALSE, ...)
39 1
	if (methods::is(roc, "smooth.roc")) {
40 0
		return(ci.auc(smooth.roc = roc, ...))
41
	}
42
	else {
43 1
		return(ci.auc(roc = roc, ...))
44
	}
45
}
46

47
ci.auc.auc <- function(auc, ...) {
48 1
	roc <- attr(auc, "roc")
49 1
	roc$auc <- auc
50 1
	ci.auc(roc, reuse.auc = TRUE, ...)
51
}
52

53
ci.auc.smooth.roc <- function(smooth.roc,
54
                   conf.level = 0.95,
55
                   boot.n = 2000,
56
                   boot.stratified = TRUE,
57
                   reuse.auc=TRUE,
58
                   progress = getOption("pROCProgress")$name,
59
                   parallel = FALSE,
60
                   ...
61
                   ) {
62 1
  if (conf.level > 1 | conf.level < 0)
63 0
    stop("conf.level must be within the interval [0,1].")
64
  
65 1
  if (roc.utils.is.perfect.curve(smooth.roc)) {
66 0
  	warning("ci.auc() of a ROC curve with AUC == 1 is always 1-1 and can be misleading.")
67
  }
68

69
  # We need an auc
70 1
  if (is.null(smooth.roc$auc) | !reuse.auc)
71 0
    smooth.roc$auc <- auc(smooth.roc, ...)
72

73
  # Check if called with density.cases or density.controls
74 1
  if (is.null(smooth.roc$smoothing.args) || is.numeric(smooth.roc$smoothing.args$density.cases) || is.numeric(smooth.roc$smoothing.args$density.controls))
75 0
    stop("Cannot compute CI of ROC curves smoothed with numeric density.controls and density.cases.")
76

77
  # Get the non smoothed roc.
78 1
  roc <- attr(smooth.roc, "roc")
79 1
  roc$ci <- NULL # remove potential ci in roc to avoid infinite loop with smooth.roc()
80

81
  # do all the computations in fraction, re-transform in percent later if necessary
82 1
  percent <- smooth.roc$percent
83 1
  smooth.roc$percent <- FALSE
84 1
  roc$percent <- FALSE
85 1
  oldauc <- smooth.roc$auc
86 1
  if (percent) {
87 0
    attr(smooth.roc$auc, "percent") <- FALSE
88 0
    if (! identical(attr(smooth.roc$auc, "partial.auc"), FALSE)) {
89 0
      attr(smooth.roc$auc, "partial.auc") <- attr(smooth.roc$auc, "partial.auc") / 100
90
    }
91
  }
92

93
  # prepare the calls
94 1
  smooth.roc.call <- as.call(c(utils::getS3method("smooth", "roc"), smooth.roc$smoothing.args))
95 1
  auc.args <- attributes(smooth.roc$auc)[grep("partial.auc", names(attributes(smooth.roc$auc)))]
96 1
  auc.args$allow.invalid.partial.auc.correct <- TRUE
97 1
  auc.call <- as.call(c(utils::getS3method("auc", "smooth.roc"), auc.args))
98

99 1
  if(class(progress) != "list")
100 1
    progress <- roc.utils.get.progress.bar(progress, title="AUC confidence interval", label="Bootstrap in progress...", ...)
101

102 1
  if (boot.stratified) {
103 1
    aucs <- unlist(llply(1:boot.n, stratified.ci.smooth.auc, roc=roc, smooth.roc.call=smooth.roc.call, auc.call=auc.call, .progress=progress, .parallel=parallel))
104
  }
105
  else {
106 1
    aucs <- unlist(llply(1:boot.n, nonstratified.ci.smooth.auc, roc=roc, smooth.roc.call=smooth.roc.call, auc.call=auc.call, .progress=progress, .parallel=parallel))
107
  }
108

109 1
  if (sum(is.na(aucs)) > 0) {
110 0
    warning("NA value(s) produced during bootstrap were ignored.")
111 0
    aucs <- aucs[!is.na(aucs)]
112
  }
113
  # TODO: Maybe apply a correction (it's in the Tibshirani?) What do Carpenter-Bithell say about that?
114
  # Prepare the return value
115 1
  ci <- quantile(aucs, c(0+(1-conf.level)/2, .5, 1-(1-conf.level)/2))
116 1
  if (percent) {
117 0
    ci <- ci * 100
118 0
    aucs <- aucs * 100
119
  }
120 1
  attr(ci, "conf.level") <- conf.level
121 1
  attr(ci, "method") <- "bootstrap"
122 1
  attr(ci, "boot.n") <- boot.n
123 1
  attr(ci, "boot.stratified") <- boot.stratified
124 1
  attr(ci, "auc") <- oldauc
125 1
  class(ci) <- c("ci.auc", "ci", class(ci))
126 1
  return(ci)  
127
}
128

129
ci.auc.roc <- function(roc,
130
                   conf.level = 0.95,
131
                   method=c("delong", "bootstrap"),
132
                   boot.n = 2000,
133
                   boot.stratified = TRUE,
134
                   reuse.auc=TRUE,
135
                   progress = getOption("pROCProgress")$name,
136
                   parallel = FALSE,
137
                   ...
138
                   ) {
139 1
  if (conf.level > 1 | conf.level < 0)
140 0
    stop("conf.level must be within the interval [0,1].")
141
  
142 1
  if (roc.utils.is.perfect.curve(roc)) {
143 0
  	warning("ci.auc() of a ROC curve with AUC == 1 is always 1-1 and can be misleading.")
144
  }
145

146
  # We need an auc
147 1
  if (is.null(roc$auc) | !reuse.auc)
148 0
    roc$auc <- auc(roc, ...)
149

150
  # do all the computations in fraction, re-transform in percent later if necessary
151 1
  percent <- roc$percent
152 1
  oldauc <- roc$auc
153 1
  if (percent) {
154 1
  	roc <- roc.utils.unpercent(roc)
155
  }
156

157
  # Check the method
158 1
  if (missing(method) | is.null(method)) {
159
    # determine method if missing
160 1
    if (has.partial.auc(roc)) {
161
      # partial auc: go for bootstrap
162 1
      method <- "bootstrap"
163
    }
164 1
    else if ("smooth.roc" %in% class(roc)) {
165
      # smoothing: bootstrap
166 0
      method <- "bootstrap"
167
    }
168
    else {
169 1
      method <- "delong"
170
    }
171
  }
172
  else {
173 1
    method <- match.arg(method, c("delong", "bootstrap"))
174
    # delong NA to pAUC: warn + change
175 1
    if (has.partial.auc(roc) && method == "delong") {
176 0
      stop("DeLong method is not supported for partial AUC. Use method=\"bootstrap\" instead.")
177
    }
178 1
    else if ("smooth.roc" %in% class(roc)) {
179 0
      stop("DeLong method is not supported for smoothed ROCs. Use method=\"bootstrap\" instead.")
180
    }
181
  }
182

183 1
  if (method == "delong")
184 1
    ci <- ci.auc.delong(roc, conf.level)
185
  else
186 1
    ci <- ci.auc.bootstrap(roc, conf.level, boot.n, boot.stratified, progress, parallel, ...)
187

188 1
  if (percent) {
189 1
    ci <- ci * 100
190
  }
191 1
  attr(ci, "conf.level") <- conf.level
192 1
  attr(ci, "method") <- method
193 1
  attr(ci, "boot.n") <- boot.n
194 1
  attr(ci, "boot.stratified") <- boot.stratified
195 1
  attr(ci, "auc") <- oldauc
196 1
  class(ci) <- c("ci.auc", "ci", class(ci))
197 1
  return(ci)
198
}
199

200
ci.auc.multiclass.roc <- function(multiclass.roc, ...) {
201 0
	stop("CI of a multiclass ROC curve not implemented")
202
}
203

204
ci.auc.multiclass.auc <- function(multiclass.auc, ...) {
205 0
	stop("CI of a multiclass AUC not implemented")
206
}

Read our documentation on viewing source code .

Loading