R/print.R

In pROC: Display and Analyze ROC Curves

# pROC: Tools Receiver operating characteristic (ROC curves) with
# (partial) area under the curve, confidence intervals and comparison. 
# Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck,
# Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez
# and Markus Müller
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

print.smooth.roc <- function(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) {
  # do we print the call?
  if (call)
    cat("\nCall:\n", deparse(x$call), "\n\n", sep="")
  # Always print number of patients, controls, thresholds, levels?
  print_dataline(attr(x, "roc")) # take this from original roc

  # Smoothing
  cat("Smoothing: ")
  if (is.null(x$smoothing.args)) {
    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="")
  }
  else if (x$smoothing.args$method == "density")
    cat("density (bandwidth: ", x$smoothing.args$bw, "; adjust: ", ifelse(is.null(x$smoothing.args$adjust), 1, x$smoothing.args$adjust), ")\n", sep="")
  else if (x$smoothing.args$method == "density") {
    cat("fitting ", x$fit.controls$densfun, " distribution for controls:\n", sep="")
    print(x$fit.controls$estimate)
    cat("fitting ", x$fit.cases$densfun, " distribution for cases:\n", sep="")
    print(x$fit.cases$estimate)
  }
  else
  	cat(x$smoothing.args$method, "\n")

  # AUC if exists
  if (!is.null(x$auc)) {
    print(x$auc, digits=digits, ...)
  }
  else
    cat("Area under the curve not computed.\n")

  # CI if exists, print it
  if(!is.null(x$ci)) {
    print(x$ci, digits=digits, ...)
  }

  invisible(x)
}

print.multiclass.roc <- function(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) {
  # do we print the call?
  if (call)
    cat("\nCall:\n", deparse(x$call), "\n\n", sep="")
  # get predictor name
  if ("predictor" %in% names(x$call))
    predictor.name <- as.character(x$call[match("predictor", names(x$call))])
  else if (!is.null(x$call$formula)) 
    predictor.name <- attr(terms(as.formula(x$call$formula), data=x$data), "term.labels")
  # Get response
  if ("response" %in% names(x$call))
    response.name <- as.character(x$call[match("response", names(x$call))])
  else if (!is.null(x$call$formula)) {
    formula.attrs <- attributes(terms(as.formula(x$call$formula), data=x$data))
    response.name <- rownames(formula.attrs$factors)[formula.attrs$response]
  }
  cat("Data: ", predictor.name, " with ", length(x$levels), " levels of ", response.name, ": ", paste(x$levels, collapse=", "),  ".\n", sep="")

  # AUC if exists
  if (!is.null(x$auc)) {
    print(x$auc, digits=digits, ...)
  }
  else
    cat("Multi-class area under the curve not computed.\n")

  # CI if exists, print it
  if(!is.null(x$ci)) {
    print(x$ci, digits=digits, ...)
  }

  invisible(x)
}

print.mv.multiclass.roc <- function(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) {
	# do we print the call?
	if (call)
		cat("\nCall:\n", deparse(x$call), "\n\n", sep="")
	# get predictor name
	if ("predictor" %in% names(x$call))
		predictor.name <- as.character(x$call[match("predictor", names(x$call))])
	else if (!is.null(x$call$formula)) 
		predictor.name <- attr(terms(as.formula(x$call$formula), data=x$data), "term.labels")
	# Get response
	if ("response" %in% names(x$call))
		response.name <- as.character(x$call[match("response", names(x$call))])
	else if (!is.null(x$call$formula)) {
		formula.attrs <- attributes(terms(as.formula(x$call$formula), data=x$data))
		response.name <- rownames(formula.attrs$factors)[formula.attrs$response]
	}
	cat("Data: multivariate predictor ", predictor.name, " with ", length(x$levels), " levels of ", response.name, ": ", paste(x$levels, collapse=", "),  ".\n", sep="")
	
	# AUC if exists
	if (!is.null(x$auc)) {
		print(x$auc, digits=digits, ...)
	}
	else
		cat("Multi-class area under the curve not computed.\n")
	
	# CI if exists, print it
	if(!is.null(x$ci)) {
		print(x$ci, digits=digits, ...)
	}
	
	invisible(x)
}

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

  # AUC if exists
  if (!is.null(x$auc)) {
    print(x$auc, digits=digits, ...)
  }
  else
    cat("Area under the curve not computed.\n")

  # CI if exists, print it
  if(!is.null(x$ci)) {
    print(x$ci, digits=digits, ...)
  }

  invisible(x)
}

print.auc <- function(x, digits=max(3, getOption("digits") - 3), ...) {
  if (identical(attr(x, "partial.auc"), FALSE))
    cat("Area under the curve: ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
  else {
    cat(ifelse(identical(attr(x, "partial.auc.correct"), TRUE), "Corrected p", "P"), "artial area under the curve", sep="")
    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="")
    cat(": ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
  }
  invisible(x)
}

print.multiclass.auc <- function(x, digits=max(3, getOption("digits") - 3), ...) {
  if (identical(attr(x, "partial.auc"), FALSE))
    cat("Multi-class area under the curve: ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
  else {
    cat("Multi-class ", ifelse(identical(attr(x, "partial.auc.correct"), TRUE), "corrected ", ""), "partial area under the curve", sep="")
    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="")
    cat(": ", signif(x, digits=digits), ifelse(attr(x, "percent"), "%", ""), "\n", sep="")
  }
  invisible(x)
}

print.mv.multiclass.auc <- print.multiclass.auc

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

print.ci.thresholds <- function(x, digits=max(3, getOption("digits") - 3), ...) {
  cat(attr(x, "conf.level")*100, "% CI", sep="")
  cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates):\n", sep="")
  signif.sp <- signif(x$sp, digits=digits)
  signif.se <- signif(x$se, digits=digits)
  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)
  invisible(x)
}

print.ci.sp <- function(x, digits=max(3, getOption("digits") - 3), ...) {
  cat(attr(x, "conf.level")*100, "% CI", sep="")
  cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates):\n", sep="")
  signif.sp <- signif(x, digits=digits)
  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)
  invisible(x)
}

print.ci.se <- function(x, digits=max(3, getOption("digits") - 3), ...) {
  cat(attr(x, "conf.level")*100, "% CI", sep="")
  cat(" (", attr(x, "boot.n"), " ", ifelse(attr(x, "boot.stratified"), "stratified", "non-stratified"), " bootstrap replicates):\n", sep="")
  signif.se <- signif(x, digits=digits)
  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)
  invisible(x)
}

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

  table <- do.call(cbind, x)
  table <- signif(table, digits = digits)
  table <- cbind(x = attr(x, "x"), as.data.frame(table))
  
  colnames.grid <- expand.grid(c("low", "median", "high"), attr(x, "ret"))
  colnames.vec <- paste(colnames.grid$Var2, colnames.grid$Var1, sep=".")
  colnames(table) <- c(attr(x, "input"), colnames.vec)
  rownames(table) <- attr(x, "x")
  
  print(table, row.names=length(attr(x, "ret")) > 1)
  invisible(x)
}

print_dataline <- function(x) {
  # Case / Controls call
  if ("cases" %in%  names(x$call) && "controls" %in% names(x$call)) {
    cat("Data: ", length(x$controls), " controls ", x$direction, " ", length(x$cases), " cases.\n", sep="")
  }
  else {
  	if ("predictor.name" %in% names(x)) {
  		predictor.name <- x$predictor.name
  	}
    else if ("predictor" %in% names(x$call)) {
    	predictor.name <- as.character(x$call[match("predictor", names(x$call))])
    }
    else if (!is.null(x$call$formula)) {
    	# TODO: remove this case in a future version.
    	# This is kept for backward-compatibility with older objects.
    	# See issue #101.
    	indx <- match(c("formula", "data", "weights", "subset", "na.action"), names(x$call), nomatch=0)
    	temp <- x$call[c(1,indx)]
    	temp[[1]] <- as.name("model.frame")
    	m <- eval.parent(temp, n = 2)
    	response.name <- names(m)[1]
    	predictor.name <- names(m)[-1]
    }
    else {
    	predictor.name <- "(unknown)"
    }
    # Get response
  	if ("response.name" %in% names(x)) {
  		response.name <- x$response.name
  	}
    else if ("response" %in% names(x$call)) {
    	response.name <- as.character(x$call[match("response", names(x$call))])
    }
    else if (!is.null(x$call$formula)) {
    	# We've already extracted it with the predictor
    	# TODO: remove this case in a future version.
    	# See above.
    }
    else if ("x" %in% names(x$call)) {
    	response.name <- as.character(x$call[match("x", names(x$call))])
    }
    else {
    	response.name <- "(unknown)"
    }
    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="")
  }
}