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
print.smooth.roc <- function(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) {
21
  # do we print the call?
22 33
  if (call)
23 33
    cat("\nCall:\n", deparse(x$call), "\n\n", sep="")
24
  # Always print number of patients, controls, thresholds, levels?
25 33
  print.dataline(attr(x, "roc")) # take this from original roc
26

27
  # Smoothing
28 33
  cat("Smoothing: ")
29 33
  if (is.null(x$smoothing.args)) {
30 0
    cat("density with controls: ", as.character(x$call[match("density.controls", names(x$call))]), "; and cases: ", as.character(x$call[match("density.cases", names(x$call))]), "\n", sep="")
31
  }
32 33
  else if (x$smoothing.args$method == "density")
33 33
    cat("density (bandwidth: ", x$smoothing.args$bw, "; adjust: ", ifelse(is.null(x$smoothing.args$adjust), 1, x$smoothing.args$adjust), ")\n", sep="")
34 33
  else if (x$smoothing.args$method == "density") {
35 0
    cat("fitting ", x$fit.controls$densfun, " distribution for controls:\n", sep="")
36 0
    print(x$fit.controls$estimate)
37 0
    cat("fitting ", x$fit.cases$densfun, " distribution for cases:\n", sep="")
38 0
    print(x$fit.cases$estimate)
39
  }
40
  else
41 33
  	cat(x$smoothing.args$method, "\n")
42

43
  # AUC if exists
44 33
  if (!is.null(x$auc)) {
45 33
    print(x$auc, digits=digits, ...)
46
  }
47
  else
48 0
    cat("Area under the curve not computed.\n")
49

50
  # CI if exists, print it
51 33
  if(!is.null(x$ci)) {
52 0
    print(x$ci, digits=digits, ...)
53
  }
54

55 33
  invisible(x)
56
}
57

58
print.multiclass.roc <- function(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) {
59
  # do we print the call?
60 33
  if (call)
61 33
    cat("\nCall:\n", deparse(x$call), "\n\n", sep="")
62
  # get predictor name
63 33
  if ("predictor" %in% names(x$call))
64 33
    predictor.name <- as.character(x$call[match("predictor", names(x$call))])
65 33
  else if (!is.null(x$call$formula)) 
66 33
    predictor.name <- attr(terms(as.formula(x$call$formula), data=x$data), "term.labels")
67
  # Get response
68 33
  if ("response" %in% names(x$call))
69 33
    response.name <- as.character(x$call[match("response", names(x$call))])
70 33
  else if (!is.null(x$call$formula)) {
71 33
    formula.attrs <- attributes(terms(as.formula(x$call$formula), data=x$data))
72 33
    response.name <- rownames(formula.attrs$factors)[formula.attrs$response]
73
  }
74 33
  cat("Data: ", predictor.name, " with ", length(x$levels), " levels of ", response.name, ": ", paste(x$levels, collapse=", "),  ".\n", sep="")
75

76
  # AUC if exists
77 33
  if (!is.null(x$auc)) {
78 33
    print(x$auc, digits=digits, ...)
79
  }
80
  else
81 0
    cat("Multi-class area under the curve not computed.\n")
82

83
  # CI if exists, print it
84 33
  if(!is.null(x$ci)) {
85 0
    print(x$ci, digits=digits, ...)
86
  }
87

88 33
  invisible(x)
89
}
90

91
print.mv.multiclass.roc <- function(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) {
92
	# do we print the call?
93 33
	if (call)
94 33
		cat("\nCall:\n", deparse(x$call), "\n\n", sep="")
95
	# get predictor name
96 33
	if ("predictor" %in% names(x$call))
97 33
		predictor.name <- as.character(x$call[match("predictor", names(x$call))])
98 33
	else if (!is.null(x$call$formula)) 
99 33
		predictor.name <- attr(terms(as.formula(x$call$formula), data=x$data), "term.labels")
100
	# Get response
101 33
	if ("response" %in% names(x$call))
102 33
		response.name <- as.character(x$call[match("response", names(x$call))])
103 33
	else if (!is.null(x$call$formula)) {
104 0
		formula.attrs <- attributes(terms(as.formula(x$call$formula), data=x$data))
105 0
		response.name <- rownames(formula.attrs$factors)[formula.attrs$response]
106
	}
107 33
	cat("Data: multivariate predictor ", predictor.name, " with ", length(x$levels), " levels of ", response.name, ": ", paste(x$levels, collapse=", "),  ".\n", sep="")
108
	
109
	# AUC if exists
110 33
	if (!is.null(x$auc)) {
111 33
		print(x$auc, digits=digits, ...)
112
	}
113
	else
114 33
		cat("Multi-class area under the curve not computed.\n")
115
	
116
	# CI if exists, print it
117 33
	if(!is.null(x$ci)) {
118 0
		print(x$ci, digits=digits, ...)
119
	}
120
	
121 33
	invisible(x)
122
}
123

124
print.roc <- function(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) {
125
  # do we print the call?
126 33
  if (call)
127 33
    cat("\nCall:\n", deparse(x$call), "\n\n", sep="")
128
  # Always print number of patients, controls, thresholds, levels?
129 33
  print.dataline(x)
130

131
  # AUC if exists
132 33
  if (!is.null(x$auc)) {
133 33
    print(x$auc, digits=digits, ...)
134
  }
135
  else
136 33
    cat("Area under the curve not computed.\n")
137

138
  # CI if exists, print it
139 33
  if(!is.null(x$ci)) {
140 33
    print(x$ci, digits=digits, ...)
141
  }
142

143 33
  invisible(x)
144
}
145

146
print.auc <- function(x, digits=max(3, getOption("digits") - 3), ...) {
147 33
  if (identical(attr(x, "partial.auc"), FALSE))
148 33
    cat("Area under the curve: ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
149
  else {
150 33
    cat(ifelse(identical(attr(x, "partial.auc.correct"), TRUE), "Corrected p", "P"), "artial area under the curve", sep="")
151 33
    cat(" (", attr(x, "partial.auc.focus"), " ", attr(x, "partial.auc")[1], ifelse(attr(x, "percent"), "%", ""), "-", attr(x, "partial.auc")[2], ifelse(attr(x, "percent"), "%", ""), ")", sep="")
152 33
    cat(": ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
153
  }
154 33
  invisible(x)
155
}
156

157
print.multiclass.auc <- function(x, digits=max(3, getOption("digits") - 3), ...) {
158 33
  if (identical(attr(x, "partial.auc"), FALSE))
159 33
    cat("Multi-class area under the curve: ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
160
  else {
161 33
    cat("Multi-class ", ifelse(identical(attr(x, "partial.auc.correct"), TRUE), "corrected ", ""), "partial area under the curve", sep="")
162 33
    cat(" (", attr(x, "partial.auc.focus"), " ", attr(x, "partial.auc")[1], ifelse(attr(x, "percent"), "%", ""), "-", attr(x, "partial.auc")[2], ifelse(attr(x, "percent"), "%", ""), ")", sep="")
163 33
    cat(": ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
164
  }
165 33
  invisible(x)
166
}
167

168
print.mv.multiclass.auc <- print.multiclass.auc
169

170
print.ci.auc <- function(x, digits=max(3, getOption("digits") - 3), ...) {
171 33
  signif.ci <- signif(x, digits=digits)
172 33
  cat(attr(x, "conf.level")*100, "% CI: ", sep="")
173 33
  cat(signif.ci[1], ifelse(attr(attr(x, "auc"), "percent"), "%", ""), "-", signif.ci[3], ifelse(attr(attr(x, "auc"), "percent"), "%", ""), sep="")
174 33
  if (attr(x, "method") == "delong")
175 33
    cat(" (DeLong)\n", sep="")
176
  else
177 33
    cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates)\n", sep="")
178 33
  invisible(x)
179
}
180

181
print.ci.thresholds <- function(x, digits=max(3, getOption("digits") - 3), ...) {
182 33
  cat(attr(x, "conf.level")*100, "% CI", sep="")
183 33
  cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates):\n", sep="")
184 33
  signif.sp <- signif(x$sp, digits=digits)
185 33
  signif.se <- signif(x$se, digits=digits)
186 33
  print(data.frame(thresholds=attr(x, "thresholds"), sp.low=signif.sp[,1], sp.median=signif.sp[,2], sp.high=signif.sp[,3], se.low=signif.se[,1], se.median=signif.se[,2], se.high=signif.se[,3]), row.names=FALSE)
187 33
  invisible(x)
188
}
189

190
print.ci.sp <- function(x, digits=max(3, getOption("digits") - 3), ...) {
191 33
  cat(attr(x, "conf.level")*100, "% CI", sep="")
192 33
  cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates):\n", sep="")
193 33
  signif.sp <- signif(x, digits=digits)
194 33
  print(data.frame(se=attr(x, "sensitivities"), sp.low=signif.sp[,1], sp.median=signif.sp[,2], sp.high=signif.sp[,3]), row.names=FALSE)
195 33
  invisible(x)
196
}
197

198
print.ci.se <- function(x, digits=max(3, getOption("digits") - 3), ...) {
199 33
  cat(attr(x, "conf.level")*100, "% CI", sep="")
200 33
  cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates):\n", sep="")
201 33
  signif.se <- signif(x, digits=digits)
202 33
  print(data.frame(sp=attr(x, "specificities"), se.low=signif.se[,1], se.median=signif.se[,2], se.high=signif.se[,3]), row.names=FALSE)
203 33
  invisible(x)
204
}
205

206
print.ci.coords <- function(x, digits=max(3, getOption("digits") - 3), ...) {
207 33
  cat(attr(x, "conf.level")*100, "% CI", sep="")
208 33
  cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates):\n", sep="")
209

210 33
  table <- do.call(cbind, x)
211 33
  table <- signif(table, digits = digits)
212 33
  table <- cbind(x = attr(x, "x"), as.data.frame(table))
213
  
214 33
  colnames.grid <- expand.grid(c("low", "median", "high"), attr(x, "ret"))
215 33
  colnames.vec <- paste(colnames.grid$Var2, colnames.grid$Var1, sep=".")
216 33
  colnames(table) <- c(attr(x, "input"), colnames.vec)
217 33
  rownames(table) <- attr(x, "x")
218
  
219 33
  print(table, row.names=length(attr(x, "ret")) > 1)
220 33
  invisible(x)
221
}
222

223
print.dataline <- function(x) {
224
  # Case / Controls call
225 33
  if ("cases" %in%  names(x$call) && "controls" %in% names(x$call)) {
226 0
    cat("Data: ", length(x$controls), " controls ", x$direction, " ", length(x$cases), " cases.\n", sep="")
227
  }
228
  else {
229
    # get predictor name
230 33
    if ("predictor" %in% names(x$call))
231 33
      predictor.name <- as.character(x$call[match("predictor", names(x$call))])
232 33
    else if (!is.null(x$call$formula)) 
233 33
      predictor.name <- attr(terms(as.formula(x$call$formula), data=x$data), "term.labels")
234
    else
235 0
      return()
236
    # Get response
237 33
    if ("response" %in% names(x$call))
238 33
      response.name <- as.character(x$call[match("response", names(x$call))])
239 33
    else if (!is.null(x$call$formula)) {
240 33
      formula.attrs <- attributes(terms(as.formula(x$call$formula), data=x$data))
241 33
      response.name <- rownames(formula.attrs$factors)[formula.attrs$response]
242
    }
243 0
    else if ("x" %in% names(x$call))
244 0
      response.name <- as.character(x$call[match("x", names(x$call))])
245
    else
246 0
      return()
247 33
    cat("Data: ", predictor.name, " in ", length(x$controls), " controls (", response.name, " ", x$levels[1], ") ", x$direction, " ", length(x$cases), " cases (", response.name, " ", x$levels[2], ").\n", sep="")
248
  }
249
}

Read our documentation on viewing source code .

Loading