#' Plot performance evaluation measures
#'
#' The \code{plot} function creates a plot of performance evaluation measures.
#'
#' @param x An \code{S3} object generated by \code{\link{evalmod}}.
#' The \code{plot} function accepts the following \code{S3} objects.
#'
#' \enumerate{
#'
#' \item ROC and Precision-Recall curves (mode = "rocprc")
#'
#' \tabular{lll}{
#' \strong{\code{S3} object}
#' \tab \strong{# of models}
#' \tab \strong{# of test datasets} \cr
#'
#' sscurves \tab single \tab single \cr
#' mscurves \tab multiple \tab single \cr
#' smcurves \tab single \tab multiple \cr
#' mmcurves \tab multiple \tab multiple
#' }
#'
#' \item Basic evaluation measures (mode = "basic")
#'
#' \tabular{lll}{
#' \strong{\code{S3} object}
#' \tab \strong{# of models}
#' \tab \strong{# of test datasets} \cr
#'
#' sspoints \tab single \tab single \cr
#' mspoints \tab multiple \tab single \cr
#' smpoints \tab single \tab multiple \cr
#' mmpoints \tab multiple \tab multiple
#' }
#' }
#'
#' See the \strong{Value} section of \code{\link{evalmod}} for more details.
#'
#' @param y Equivalent with \code{curvetype}.
#'
#' @param ... All the following arguments can be specified.
#'
#' \describe{
#' \item{curvetype}{
#' \enumerate{
#'
#' \item ROC and Precision-Recall curves (mode = "rocprc")
#' \tabular{ll}{
#' \strong{curvetype}
#' \tab \strong{description} \cr
#'
#' ROC \tab ROC curve \cr
#' PRC \tab Precision-Recall curve
#' }
#' Multiple \code{curvetype} can be combined, such as
#' \code{c("ROC", "PRC")}.
#'
#' \item Basic evaluation measures (mode = "basic")
#' \tabular{ll}{
#' \strong{curvetype}
#' \tab \strong{description} \cr
#'
#' error \tab Normalized ranks vs. error rate \cr
#' accuracy \tab Normalized ranks vs. accuracy \cr
#' specificity \tab Normalized ranks vs. specificity \cr
#' sensitivity \tab Normalized ranks vs. sensitivity \cr
#' precision \tab Normalized ranks vs. precision \cr
#' mcc \tab Normalized ranks vs. Matthews correlation coefficient \cr
#' fscore \tab Normalized ranks vs. F-score
#' }
#' Multiple \code{curvetype} can be combined, such as
#' \code{c("precision", "sensitivity")}.
#' }
#' }
#' \item{type}{
#' A character to specify the line type as follows.
#' \describe{
#' \item{"l"}{lines}
#' \item{"p"}{points}
#' \item{"b"}{both lines and points}
#' }
#' }
#' \item{show_cb}{
#' A Boolean value to specify whether point-wise confidence
#' bounds are drawn. It is effective only when \code{calc_avg} of the
#' \code{\link{evalmod}} function is set to \code{TRUE}.
#' }
#' \item{raw_curves}{
#' A Boolean value to specify whether raw curves are
#' shown instead of the average curve. It is effective only
#' when \code{raw_curves} of the \code{\link{evalmod}} function is set to
#' \code{TRUE}.
#' }
#' \item{show_legend}{
#' A Boolean value to specify whether the legend is shown.
#' }
#' }
#'
#' @return The \code{plot} function shows a plot and returns NULL.
#'
#' @seealso \code{\link{evalmod}} for generating an \code{S3} object.
#' \code{\link{autoplot}} for plotting the equivalent curves
#' with \pkg{ggplot2}.
#'
#' @examples
#' \dontrun{
#' ##################################################
#' ### Single model & single test dataset
#' ###
#'
#' ## Load a dataset with 10 positives and 10 negatives
#' data(P10N10)
#'
#' ## Generate an sscurve object that contains ROC and Precision-Recall curves
#' sscurves <- evalmod(scores = P10N10$scores, labels = P10N10$labels)
#'
#' ## Plot both ROC and Precision-Recall curves
#' plot(sscurves)
#'
#' ## Plot a ROC curve
#' plot(sscurves, curvetype = "ROC")
#'
#' ## Plot a Precision-Recall curve
#' plot(sscurves, curvetype = "PRC")
#'
#' ## Generate an sspoints object that contains basic evaluation measures
#' sspoints <- evalmod(
#' mode = "basic", scores = P10N10$scores,
#' labels = P10N10$labels
#' )
#'
#' ## Plot normalized ranks vs. basic evaluation measures
#' plot(sspoints)
#'
#' ## Plot normalized ranks vs. precision
#' plot(sspoints, curvetype = "precision")
#'
#'
#' ##################################################
#' ### Multiple models & single test dataset
#' ###
#'
#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(1, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#' modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)
#'
#' ## Plot both ROC and Precision-Recall curves
#' plot(mscurves)
#'
#' ## Hide the legend
#' plot(mscurves, show_legend = FALSE)
#'
#' ## Generate an mspoints object that contains basic evaluation measures
#' mspoints <- evalmod(mdat, mode = "basic")
#'
#' ## Plot normalized ranks vs. basic evaluation measures
#' plot(mspoints)
#'
#' ## Hide the legend
#' plot(mspoints, show_legend = FALSE)
#'
#'
#' ##################################################
#' ### Single model & multiple test datasets
#' ###
#'
#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(10, 100, 100, "good_er")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#' modnames = samps[["modnames"]],
#' dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat, raw_curves = TRUE)
#'
#' ## Plot average ROC and Precision-Recall curves
#' plot(smcurves, raw_curves = FALSE)
#'
#' ## Hide confidence bounds
#' plot(smcurves, raw_curves = FALSE, show_cb = FALSE)
#'
#' ## Plot raw ROC and Precision-Recall curves
#' plot(smcurves, raw_curves = TRUE, show_cb = FALSE)
#'
#' ## Generate an smpoints object that contains basic evaluation measures
#' smpoints <- evalmod(mdat, mode = "basic")
#'
#' ## Plot normalized ranks vs. average basic evaluation measures
#' plot(smpoints)
#'
#'
#' ##################################################
#' ### Multiple models & multiple test datasets
#' ###
#'
#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(10, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#' modnames = samps[["modnames"]],
#' dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat, raw_curves = TRUE)
#'
#' ## Plot average ROC and Precision-Recall curves
#' plot(mmcurves, raw_curves = FALSE)
#'
#' ## Show confidence bounds
#' plot(mmcurves, raw_curves = FALSE, show_cb = TRUE)
#'
#' ## Plot raw ROC and Precision-Recall curves
#' plot(mmcurves, raw_curves = TRUE)
#'
#' ## Generate an mmpoints object that contains basic evaluation measures
#' mmpoints <- evalmod(mdat, mode = "basic")
#'
#' ## Plot normalized ranks vs. average basic evaluation measures
#' plot(mmpoints)
#'
#'
#' ##################################################
#' ### N-fold cross validation datasets
#' ###
#'
#' ## Load test data
#' data(M2N50F5)
#'
#' ## Speficy nessesary columns to create mdat
#' cvdat <- mmdata(
#' nfold_df = M2N50F5, score_cols = c(1, 2),
#' lab_col = 3, fold_col = 4,
#' modnames = c("m1", "m2"), dsids = 1:5
#' )
#'
#' ## Generate an mmcurve object that contains ROC and Precision-Recall curves
#' cvcurves <- evalmod(cvdat)
#'
#' ## Average ROC and Precision-Recall curves
#' plot(cvcurves)
#'
#' ## Show confidence bounds
#' plot(cvcurves, show_cb = TRUE)
#'
#' ## Generate an mmpoints object that contains basic evaluation measures
#' cvpoints <- evalmod(cvdat, mode = "basic")
#'
#' ## Normalized ranks vs. average basic evaluation measures
#' plot(cvpoints)
#' }
#' @name plot
NULL
#
# Check partial match - ROC and PRC curve type
#
.pmatch_curvetype_rocprc <- function(vals) {
pfunc <- function(val) {
if (assertthat::is.string(val)) {
sval <- tolower(val)
if (!is.na(pmatch(sval, "roc"))) {
return("ROC")
}
if (!is.na(pmatch(sval, "prc"))) {
return("PRC")
}
}
val
}
unlist(lapply(vals, pfunc))
}
#
# Check partial match - Basic evaluation measures
#
.pmatch_curvetype_basic <- function(vals) {
pfunc <- function(val) {
if (assertthat::is.string(val)) {
sval <- tolower(val)
if (!is.na(pmatch(sval, "error rate"))) {
return("error")
}
if (!is.na(pmatch(sval, "accuracy"))) {
return("accuracy")
}
if (!is.na(pmatch(sval, "specificity")) || sval == "tnr") {
return("specificity")
}
if (!is.na(pmatch(sval, "sensitivity")) ||
!is.na(pmatch(sval, "recall")) || sval == "tpr" || sval == "sn") {
return("sensitivity")
}
if (!is.na(pmatch(sval, "precision")) || sval == "ppv") {
return("precision")
}
if (!is.na(pmatch(sval, "matthews correlation coefficient")) ||
sval == "mcc") {
return("mcc")
}
if (!is.na(pmatch(sval, "fscore")) || !is.na(pmatch(sval, "f1score"))) {
return("fscore")
}
if (!is.na(pmatch(sval, "score"))) {
return("score")
}
if (!is.na(pmatch(sval, "label"))) {
return("label")
}
}
val
}
unlist(lapply(vals, pfunc))
}
#
# Process ... for curve objects
#
.get_plot_arglist <- function(evalmod_args, y,
def_curvetype, def_type, def_show_cb,
def_raw_curves, def_add_np_nn, def_show_legend,
...) {
arglist <- list(...)
if (!is.null(y)) {
arglist[["curvetype"]] <- y
}
if (is.null(arglist[["curvetype"]])) {
arglist[["curvetype"]] <- def_curvetype
}
if (is.null(arglist[["type"]])) {
arglist[["type"]] <- def_type
}
if (is.null(arglist[["show_cb"]])) {
arglist[["show_cb"]] <- def_show_cb
}
if (!evalmod_args[["calc_avg"]] && arglist[["show_cb"]]) {
stop("Invalid show_cb. Inconsistent with calc_avg of evalmod.",
call. = FALSE
)
}
if (is.null(arglist[["raw_curves"]])) {
if (!is.null(def_raw_curves)) {
arglist[["raw_curves"]] <- def_raw_curves
} else if (!is.null(evalmod_args[["raw_curves"]])) {
arglist[["raw_curves"]] <- evalmod_args[["raw_curves"]]
} else {
arglist[["raw_curves"]] <- FALSE
}
}
if (!evalmod_args[["raw_curves"]] && arglist[["raw_curves"]]) {
stop("Invalid raw_curves. Inconsistent with the value of evalmod.",
call. = FALSE
)
}
if (is.null(arglist[["add_np_nn"]])) {
arglist[["add_np_nn"]] <- def_add_np_nn
}
if (is.null(arglist[["show_legend"]])) {
arglist[["show_legend"]] <- def_show_legend
}
arglist
}
#
# Plot ROC and Precision-Recall
#
.plot_multi <- function(x, arglist) {
curvetype <- arglist[["curvetype"]]
type <- arglist[["type"]]
raw_curves <- arglist[["raw_curves"]]
add_np_nn <- arglist[["add_np_nn"]]
show_legend <- arglist[["show_legend"]]
show_cb <- arglist[["show_cb"]]
if (!attr(x, "args")$calc_avg) {
show_cb <- FALSE
}
raw_curves <- arglist[["raw_curves"]]
if (show_cb) {
raw_curves <- FALSE
}
# === Validate input arguments ===
.validate(x)
.check_curvetype(curvetype, x)
.check_type(type)
.check_show_cb(show_cb, x)
.check_raw_curves(raw_curves, x)
.check_add_np_nn(add_np_nn)
.check_show_legend(show_legend)
# === Create a plot ===
show_legend2 <- show_legend
if (length(curvetype) > 1) {
.set_layout(length(curvetype), show_legend)
on.exit(graphics::layout(1), add = TRUE)
show_legend2 <- FALSE
}
for (ct in curvetype) {
.plot_single(x, ct,
type = type, show_cb = show_cb,
raw_curves = raw_curves, add_np_nn = add_np_nn,
show_legend = show_legend2
)
}
if (length(curvetype) > 4 && length(curvetype) %% 3 == 2) {
graphics::plot(1, type = "n", axes = FALSE, xlab = "", ylab = "")
}
if (length(curvetype) > 4 && length(curvetype) %% 3 == 1) {
graphics::plot(1, type = "n", axes = FALSE, xlab = "", ylab = "")
graphics::plot(1, type = "n", axes = FALSE, xlab = "", ylab = "")
}
if (length(curvetype) > 1) {
.show_legend(x, show_legend)
}
}
#
# Set layout
#
.set_layout <- function(ctype_len, show_legend) {
if (ctype_len == 1) {
nrow1 <- 2
ncol1 <- 1
mat1 <- c(1, 2)
mat2 <- 1
heights <- c(0.85, 0.15)
} else if (ctype_len == 2) {
nrow1 <- 2
ncol1 <- 2
mat1 <- c(1, 2, 3, 3)
mat2 <- c(1, 2)
heights <- c(0.85, 0.15)
} else if (ctype_len == 3) {
nrow1 <- 2
ncol1 <- 3
mat1 <- c(1, 2, 3, 4, 4, 4)
mat2 <- c(1, 2, 3)
heights <- c(0.85, 0.15)
} else if (ctype_len == 4) {
nrow1 <- 3
ncol1 <- 2
mat1 <- c(1, 2, 3, 4, 5, 5)
mat2 <- c(1, 2, 3, 4)
heights <- c(0.425, 0.425, 0.15)
} else if (ctype_len == 5 || ctype_len == 6) {
nrow1 <- 3
ncol1 <- 3
mat1 <- c(1, 2, 3, 4, 5, 6, 7, 7, 7)
mat2 <- c(1, 2, 3, 4, 5, 6)
heights <- c(0.425, 0.425, 0.15)
} else if (ctype_len == 7 || ctype_len == 8 || ctype_len == 9) {
nrow1 <- 4
ncol1 <- 3
mat1 <- c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 10, 10)
mat2 <- c(1, 2, 3, 4, 5, 6, 7, 8, 9)
heights <- c(0.28, 0.28, 0.28, 0.16)
}
if (show_legend) {
m <- matrix(mat1, nrow = nrow1, ncol = ncol1, byrow = TRUE)
graphics::layout(mat = m, heights = heights)
} else {
m <- matrix(mat2, nrow = nrow1 - 1, ncol = ncol1, byrow = TRUE)
graphics::layout(mat = m)
}
}
#
# matplot wrapper
#
.matplot_wrapper <- function(obj, type, curvetype, main, xlab, ylab) {
# === Validate input arguments ===
.validate(obj[[curvetype]])
# === Create line colours ===
model_type <- attr(obj, "model_type")
if (model_type == "single") {
line_col <- "black"
} else {
line_col <- .make_multi_colors(obj)
}
# === Create a plot ===
xlim <- .get_xlim(obj, curvetype)
ylim <- .get_ylim(obj, curvetype)
mats <- .make_matplot_mats(obj[[curvetype]])
graphics::matplot(mats[["x"]], mats[["y"]],
type = type, lty = 1, pch = 19,
col = line_col, main = main, xlab = xlab, ylab = ylab,
ylim = ylim, xlim = xlim
)
}
#
# Make matrices for matplot
#
.make_matplot_mats <- function(obj) {
ncol <- length(obj)
max_nrow <- max(unlist(lapply(obj, function(o) length(o[["x"]]))))
x <- matrix(as.double(NA), nrow = max_nrow, ncol = ncol)
y <- matrix(as.double(NA), nrow = max_nrow, ncol = ncol)
for (i in seq_along(obj)) {
x[seq_len(length(obj[[i]][["x"]])), i] <- obj[[i]][["x"]]
y[seq_len(length(obj[[i]][["y"]])), i] <- obj[[i]][["y"]]
}
list(x = x, y = y)
}
#
# Make colours for multiple models and multiple datasets
#
.make_multi_colors <- function(obj) {
uniq_modnames <- attr(obj, "uniq_modnames")
modnames <- attr(obj, "data_info")[["modnames"]]
uniq_col <- grDevices::rainbow(length(uniq_modnames), alpha = 1)
modnams_idx <- as.numeric(factor(modnames, levels = uniq_modnames))
unlist(lapply(seq_along(modnames), function(i) uniq_col[modnams_idx[i]]))
}
#
# Plot average line with CI
#
.plot_avg <- function(obj, type, curvetype, main, xlab, ylab, show_cb) {
# === Create a plot ===
grp_avg <- attr(obj, "grp_avg")
avgcurves <- grp_avg[[curvetype]]
xlim <- .get_xlim(obj, curvetype)
ylim <- .get_ylim(obj, curvetype)
graphics::plot(1,
type = "n", main = main, xlab = xlab, ylab = ylab,
ylim = ylim, xlim = xlim
)
if (length(avgcurves) == 1) {
lcols <- "blue"
} else {
lcols <- grDevices::rainbow(length(avgcurves), alpha = 1)
}
for (i in seq_len(length(avgcurves))) {
.add_curve_with_ci(avgcurves, type, i, "grey", lcols[i], show_cb)
}
}
#
# Add a curve with CI
#
.add_curve_with_ci <- function(avgcurves, type, idx, pcol, lcol, show_cb) {
x <- avgcurves[[idx]][["x"]]
y <- avgcurves[[idx]][["y_avg"]]
naidx <- is.na(y)
if (any(naidx)) {
x <- x[!naidx]
y <- y[!naidx]
}
if (show_cb) {
ymin <- avgcurves[[idx]][["y_ci_l"]]
ymax <- avgcurves[[idx]][["y_ci_h"]]
if (any(naidx)) {
ymin <- ymin[!naidx]
ymax <- ymax[!naidx]
}
g <- grDevices::col2rgb(pcol)
graphics::polygon(c(x, rev(x)), c(ymin, rev(ymax)),
border = FALSE,
col = grDevices::rgb(g[1], g[2], g[3], 180,
maxColorValue = 255
)
)
}
b <- grDevices::col2rgb(lcol)
graphics::lines(x, y,
type = type, lty = 1, pch = 19,
col = grDevices::rgb(b[1], b[2], b[3], 200,
maxColorValue = 255
)
)
}
#
# Plot ROC or Precision-Recall
#
.plot_single <- function(x, curvetype, type = type, show_cb = FALSE,
raw_curves = FALSE, add_np_nn = TRUE,
show_legend = TRUE) {
tlist <- .get_titiles(curvetype)
main <- tlist[["main"]]
pn_info <- .get_pn_info(x)
if (add_np_nn && pn_info$is_consistant) {
np <- pn_info$avg_np
nn <- pn_info$avg_nn
main <- paste0(main, " - P: ", np, ", N: ", nn)
}
withr::local_par(list(pty = "s"))
if (show_legend) {
.set_layout(1, show_legend)
on.exit(graphics::layout(1), add = TRUE)
}
# === Create a plot ===
if (show_cb) {
.plot_avg(
x, type, tlist[["ctype"]], main, tlist[["xlab"]],
tlist[["ylab"]], show_cb
)
} else if (raw_curves) {
.matplot_wrapper(
x, type, tlist[["ctype"]], main, tlist[["xlab"]],
tlist[["ylab"]]
)
} else {
.plot_avg(
x, type, tlist[["ctype"]], main, tlist[["xlab"]],
tlist[["ylab"]], show_cb
)
}
if (curvetype == "ROC") {
graphics::abline(a = 0, b = 1, col = "grey", lty = 3)
} else if (curvetype == "PRC") {
graphics::abline(h = pn_info$prc_base, col = "grey", lty = 3)
}
.show_legend(x, show_legend)
}
#
# Get title and subtitles
#
.get_titiles <- function(curvetype) {
tlist <- list()
if (curvetype == "ROC") {
tlist[["main"]] <- "ROC"
tlist[["xlab"]] <- "1 - Specificity"
tlist[["ylab"]] <- "Sensitivity"
tlist[["ctype"]] <- "rocs"
} else if (curvetype == "PRC") {
tlist[["main"]] <- "Precision-Recall"
tlist[["xlab"]] <- "Recall"
tlist[["ylab"]] <- "Precision"
tlist[["ctype"]] <- "prcs"
} else {
mnames <- list(
score = "score", label = "label", error = "err",
accuracy = "acc", specificity = "sp", sensitivity = "sn",
precision = "prec", mcc = "mcc", fscore = "fscore"
)
if (curvetype == "mcc") {
main <- "MCC"
} else if (curvetype == "label") {
main <- "Label (1:pos, -1:neg)"
} else {
main <- paste0(
toupper(substring(curvetype, 1, 1)),
substring(curvetype, 2)
)
}
tlist[["main"]] <- main
tlist[["xlab"]] <- "normalized rank"
tlist[["ylab"]] <- curvetype
tlist[["ctype"]] <- mnames[[curvetype]]
}
tlist
}
#
# Show legend
#
.show_legend <- function(obj, show_legend, gnames = "modnames") {
if (show_legend) {
withr::local_par(list(mar = c(0, 0, 0, 0), pty = "m"))
gnames <- attr(obj, paste0("uniq_", gnames))
graphics::plot(1, type = "n", axes = FALSE, xlab = "", ylab = "")
graphics::legend(
x = "top", lty = 1,
legend = gnames,
col = grDevices::rainbow(length(gnames), alpha = 1),
horiz = TRUE
)
}
}
#
# Get value range
#
.get_value_range <- function(obj, curvetype) {
curves <- obj[[curvetype]]
grp_avg <- attr(obj, "grp_avg")
avgcurves <- grp_avg[[curvetype]]
max_score <- NA
min_score <- NA
if (!all(is.na(avgcurves))) {
for (i in seq_len(length(avgcurves))) {
max_score <- max(max_score, max(avgcurves[[i]][["y_ci_h"]], na.rm = TRUE),
na.rm = TRUE
)
min_score <- min(min_score, min(avgcurves[[i]][["y_ci_l"]], na.rm = TRUE),
na.rm = TRUE
)
}
} else {
for (i in seq_len(length(curves))) {
max_score <- max(max_score, max(curves[[i]][["y"]], na.rm = TRUE),
na.rm = TRUE
)
min_score <- min(min_score, min(curves[[i]][["y"]], na.rm = TRUE),
na.rm = TRUE
)
}
}
c(min_score, max_score)
}
#
# Get xlim
#
.get_xlim <- function(obj, curvetype) {
if (curvetype == "rocs" || curvetype == "prcs") {
xlim <- attr(obj[[curvetype]], "xlim")
} else if (curvetype == "mcc" || curvetype == "label") {
xlim <- c(0, 1)
} else if (curvetype == "score") {
xlim <- c(0, 1)
} else {
xlim <- c(0, 1)
}
xlim
}
#
# Get ylim
#
.get_ylim <- function(obj, curvetype) {
if (curvetype == "rocs" || curvetype == "prcs") {
ylim <- attr(obj[[curvetype]], "ylim")
} else if (curvetype == "mcc" || curvetype == "label") {
ylim <- c(-1, 1)
} else if (curvetype == "score") {
ylim <- .get_value_range(obj, curvetype)
} else {
ylim <- c(0, 1)
}
ylim
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.