R/perm.a.r

In jjlynch2/AnthroStats: Anthropology Statistics

#' Metric performance statistics function
#' Calculated 
#' @param M data.frame containing true negatives, true positives, false negatives, and false positives 
#' @param type can be any of the following: "TPR", "TNR", "EFF", "PPV", "NPV", "FNR", "FPR", "FDR", "FPR", "All"
#' @param digits number of digits to round to
#'
#' @keywords performance.a
#' @export
#' performance.a()

performance.a <- function(X = NULL, type = "All", digits = 3, ROC = FALSE) {

	#Input san
	if(is.null(X)) {
		print("X contains no data")
		return()
	}
	if(type != "TPR" && type != "TNR" && type != "EFF" && type != "PPV" && type != "NPV" && type != "FNR" && type != "FPR" && type != "FDR" && type != "All") {
		print("Invalid type")
		return()
	}

	#define return object
	A <- data.frame(matrix(NA, ncol=0, nrow=1))

	#Calculations
	if(type == "TPR" || type == "All") {
		A$TPR <- round(X$TP / (X$TP + X$FN), digits = digits)
	}
	if(type == "TNR" || type == "All") {
		A$TNR <- round(X$TN / (X$TN + X$FP), digits = digits)
	}
	if(type == "EFF" || type == "All") {
		A$EFF <- round((X$TP+X$TN) / (X$TP+X$TN+X$FN+X$FP), digits = digits)
	}
	if(type == "PPV" || type == "All") {
		A$PPV <- round(X$TP / (X$TP + X$FP), digits = digits)
	}
	if(type == "NPV" || type == "All") {
		A$NPV <- round(X$TN / (X$TN + X$FN), digits = digits)
	}
	if(type == "FNR" || type == "All") {
		A$FNR <- round(X$FN / (X$TP + X$FN), digits = digits)
	}
	if(type == "FPR" || type == "All") {
		A$FPR <- round(X$FP / (X$FP + X$TN), digits = digits)
	}
	if(type == "FDR" || type == "All") {
		A$FDR <- round(X$FP / (X$TP + X$FP), digits = digits)
	}

	#ROC curve
	if(ROC) {
		TPR <- c(round(X$TP / (X$TP + X$FN), digits = digits), 0)
		FPR <- c(round(X$FP / (X$FP + X$TN), digits = digits), 0)
		names(TPR) <- "True Positive Rate"
		names(FPR) <- "False Positive Rate"
		plot(FPR, TPR, col = "white", cex.main=1.2, cex.lab=1.2, cex.axis=1.2)
		lines(FPR, TPR, lty = 1, lwd=2)

		height <- (TPR[-1] + TPR[-length(TPR)]) / 2
		width <- -diff(FPR)
		A$AUROC <- sum(height * width)
	}
	

	return(A)
}