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