Commit ⋅ evalclass/precrec

@@ -66,8 +66,10 @@

Loading

#' @export
join_scores <- function(..., byrow = FALSE, chklen = TRUE) {
  # Call join datasets
  .join_datasets(..., efunc_vtype = .validate_scores, efunc_nrow = NULL,
                 byrow = byrow, chklen = chklen)
  .join_datasets(...,
    efunc_vtype = .validate_scores, efunc_nrow = NULL,
    byrow = byrow, chklen = chklen
  )
}

#' Join observed labels of multiple test datasets into a list

@@ -137,8 +139,10 @@

Loading

#' @export
join_labels <- function(..., byrow = FALSE, chklen = TRUE) {
  # Call join datasets
  .join_datasets(..., efunc_vtype = .validate_labels, efunc_nrow = NULL,
                 byrow = byrow, chklen = chklen)
  .join_datasets(...,
    efunc_vtype = .validate_labels, efunc_nrow = NULL,
    byrow = byrow, chklen = chklen
  )
}

#

@@ -148,9 +152,11 @@

Loading

                           byrow = FALSE, chklen = TRUE) {

  # Validate arguments
  .validate_join_datasets_args(..., efunc_vtype = efunc_vtype,
                               efunc_nrow = efunc_nrow, byrow = byrow,
                               chklen = chklen)
  .validate_join_datasets_args(...,
    efunc_vtype = efunc_vtype,
    efunc_nrow = efunc_nrow, byrow = byrow,
    chklen = chklen
  )

  # Set a default error function for checking values
  if (is.null(efunc_vtype)) {

@@ -243,25 +249,28 @@

Loading

  }

  # Check efunc_vtype
  if (!is.null(efunc_vtype)
      && (!methods::is(efunc_vtype, "function")
          || length(as.list(formals(efunc_vtype))) != 1)) {
  if (!is.null(efunc_vtype) &&
    (!methods::is(efunc_vtype, "function") ||
      length(as.list(formals(efunc_vtype))) != 1)) {
    stop("efunc_vtype must be a function with 1 argument", call. = FALSE)
  }

  # Check efunc_nrow
  if (!is.null(efunc_nrow)
      && (!methods::is(efunc_nrow, "function")
          || length(as.list(formals(efunc_nrow))) != 2)) {
  if (!is.null(efunc_nrow) &&
    (!methods::is(efunc_nrow, "function") ||
      length(as.list(formals(efunc_nrow))) != 2)) {
    stop("efunc_nrow must be a function with 2 arguments", call. = FALSE)
  }

  # Check byrow
  assertthat::assert_that(assertthat::is.flag(byrow),
                          assertthat::noNA(byrow))
  assertthat::assert_that(
    assertthat::is.flag(byrow),
    assertthat::noNA(byrow)
  )

  # Check chklen
  assertthat::assert_that(assertthat::is.flag(chklen),
                          assertthat::noNA(chklen))

  assertthat::assert_that(
    assertthat::is.flag(chklen),
    assertthat::noNA(chklen)
  )
}

@@ -5,12 +5,15 @@

Loading

  curve_df <- .prepare_autoplot(object)

  # === Create a ggplot object ===
  p <- ggplot2::ggplot(curve_df,
                       ggplot2::aes_string(x = 'x', y = 'y', color = 'x'))
  p <- ggplot2::ggplot(
    curve_df,
    ggplot2::aes_string(x = "x", y = "y", color = "x")
  )
  p <- p + ggplot2::geom_jitter()
  p <- p + ggplot2::coord_flip()
  p <- .geom_basic(p, "Score distributions by rank", NULL, "rank",
                   show_legend = FALSE)
    show_legend = FALSE
  )
}

#

@@ -20,11 +23,15 @@

Loading

  curve_df <- .prepare_autoplot(object)

  # === Create a ggplot object ===
  p <- ggplot2::ggplot(curve_df,
                       ggplot2::aes_string(x = 'x', y = 'y', color = 'group'))
  p <- ggplot2::ggplot(
    curve_df,
    ggplot2::aes_string(x = "x", y = "y", color = "group")
  )
  p <- p + ggplot2::geom_line()
  p <- .geom_basic(p, "TPs, FNs, FPs, and TNs by ranks",
                   "rank", "count", show_legend = TRUE)
    "rank", "count",
    show_legend = TRUE
  )
}

#

@@ -34,47 +41,50 @@

Loading

  curve_df <- .prepare_autoplot(object)

  # === Create a ggplot object ===
  p <- ggplot2::ggplot(curve_df,
                       ggplot2::aes_string(x = 'x', y = 'y'))
  p <- ggplot2::ggplot(
    curve_df,
    ggplot2::aes_string(x = "x", y = "y")
  )
  p <- p + ggplot2::geom_line()
  p <- p + ggplot2::facet_wrap(~ group, ncol = 2)
  p <- p + ggplot2::facet_wrap(~group, ncol = 2)

  p <- .geom_basic(p, "Evaluation measures by ranks",
                   "normalized rank", "evaluation value", show_legend = FALSE)
    "normalized rank", "evaluation value",
    show_legend = FALSE
  )
}

#' @rdname autoplot
#' @export
autoplot.sscurves <- function(object, curvetype = c("ROC", "PRC"), ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "l",
                                   def_show_cb = FALSE, def_raw_curves = TRUE,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = FALSE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = TRUE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "l",
    def_show_cb = FALSE, def_raw_curves = TRUE,
    def_add_np_nn = TRUE,
    def_show_legend = FALSE,
    def_ret_grob = FALSE,
    def_reduce_points = TRUE,
    def_multiplot_lib = "patchwork", ...
  )
  arglist[["raw_curves"]] <- TRUE
  arglist[["show_cb"]] <- FALSE
  arglist[["curvetype"]] <- .pmatch_curvetype_rocprc(arglist[["curvetype"]])

  .autoplot_multi(object, arglist)

}

#' @rdname autoplot
#' @export
autoplot.mscurves <- function(object, curvetype = c("ROC", "PRC"), ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "l",
                                   def_show_cb = FALSE, def_raw_curves = TRUE,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = TRUE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = TRUE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "l",
    def_show_cb = FALSE, def_raw_curves = TRUE,
    def_add_np_nn = TRUE,
    def_show_legend = TRUE,
    def_ret_grob = FALSE,
    def_reduce_points = TRUE,
    def_multiplot_lib = "patchwork", ...
  )
  arglist[["raw_curves"]] <- TRUE
  arglist[["show_cb"]] <- FALSE
  arglist[["curvetype"]] <- .pmatch_curvetype_rocprc(arglist[["curvetype"]])

@@ -85,15 +95,15 @@

Loading

#' @rdname autoplot
#' @export
autoplot.smcurves <- function(object, curvetype = c("ROC", "PRC"), ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "l",
                                   def_show_cb = TRUE, def_raw_curves = NULL,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = FALSE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = TRUE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "l",
    def_show_cb = TRUE, def_raw_curves = NULL,
    def_add_np_nn = TRUE,
    def_show_legend = FALSE,
    def_ret_grob = FALSE,
    def_reduce_points = TRUE,
    def_multiplot_lib = "patchwork", ...
  )

  arglist[["curvetype"]] <- .pmatch_curvetype_rocprc(arglist[["curvetype"]])


@@ -103,15 +113,15 @@

Loading

#' @rdname autoplot
#' @export
autoplot.mmcurves <- function(object, curvetype = c("ROC", "PRC"), ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "l",
                                   def_show_cb = FALSE, def_raw_curves = NULL,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = TRUE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = TRUE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "l",
    def_show_cb = FALSE, def_raw_curves = NULL,
    def_add_np_nn = TRUE,
    def_show_legend = TRUE,
    def_ret_grob = FALSE,
    def_reduce_points = TRUE,
    def_multiplot_lib = "patchwork", ...
  )

  arglist[["curvetype"]] <- .pmatch_curvetype_rocprc(arglist[["curvetype"]])


@@ -122,36 +132,35 @@

Loading

#' @export
autoplot.sspoints <- function(object, curvetype = .get_metric_names("basic"),
                              ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "p",
                                   def_show_cb = FALSE, def_raw_curves = TRUE,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = FALSE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = FALSE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "p",
    def_show_cb = FALSE, def_raw_curves = TRUE,
    def_add_np_nn = TRUE,
    def_show_legend = FALSE,
    def_ret_grob = FALSE,
    def_reduce_points = FALSE,
    def_multiplot_lib = "patchwork", ...
  )
  arglist[["raw_curves"]] <- TRUE
  arglist[["show_cb"]] <- FALSE
  arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])

  .autoplot_multi(object, arglist)

}

#' @rdname autoplot
#' @export
autoplot.mspoints <- function(object, curvetype = .get_metric_names("basic"),
                              ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "p",
                                   def_show_cb = FALSE, def_raw_curves = TRUE,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = TRUE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = FALSE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "p",
    def_show_cb = FALSE, def_raw_curves = TRUE,
    def_add_np_nn = TRUE,
    def_show_legend = TRUE,
    def_ret_grob = FALSE,
    def_reduce_points = FALSE,
    def_multiplot_lib = "patchwork", ...
  )
  arglist[["raw_curves"]] <- TRUE
  arglist[["show_cb"]] <- FALSE
  arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])

@@ -163,15 +172,15 @@

Loading

#' @export
autoplot.smpoints <- function(object, curvetype = .get_metric_names("basic"),
                              ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "p",
                                   def_show_cb = TRUE, def_raw_curves = NULL,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = FALSE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = FALSE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "p",
    def_show_cb = TRUE, def_raw_curves = NULL,
    def_add_np_nn = TRUE,
    def_show_legend = FALSE,
    def_ret_grob = FALSE,
    def_reduce_points = FALSE,
    def_multiplot_lib = "patchwork", ...
  )

  arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])


@@ -182,15 +191,15 @@

Loading

#' @export
autoplot.mmpoints <- function(object, curvetype = .get_metric_names("basic"),
                              ...) {

  arglist <- .get_autoplot_arglist(attr(object, "args"),
                                   def_curvetype = curvetype, def_type = "p",
                                   def_show_cb = FALSE, def_raw_curves = NULL,
                                   def_add_np_nn = TRUE,
                                   def_show_legend = TRUE,
                                   def_ret_grob = FALSE,
                                   def_reduce_points = FALSE,
                                   def_multiplot_lib = "patchwork", ...)
    def_curvetype = curvetype, def_type = "p",
    def_show_cb = FALSE, def_raw_curves = NULL,
    def_add_np_nn = TRUE,
    def_show_legend = TRUE,
    def_ret_grob = FALSE,
    def_reduce_points = FALSE,
    def_multiplot_lib = "patchwork", ...
  )

  arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])


@@ -43,8 +43,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "good_er")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat)

@@ -62,8 +63,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat)

@@ -75,10 +77,12 @@

Loading

#' mm_auc_ci
#'
#' @export
auc_ci <- function(curves, alpha=NULL, dtype=NULL) UseMethod("auc_ci", curves)
auc_ci <- function(curves, alpha = NULL, dtype = NULL) {
  UseMethod("auc_ci", curves)
}

#' @export
auc_ci.default <- function(curves, alpha=NULL, dtype=NULL) {
auc_ci.default <- function(curves, alpha = NULL, dtype = NULL) {
  stop("An object of unknown class is specified")
}


@@ -87,13 +91,16 @@

Loading

#
#' @rdname auc_ci
#' @export
auc_ci.aucs <- function(curves, alpha=0.05, dtype="normal") {
auc_ci.aucs <- function(curves, alpha = 0.05, dtype = "normal") {
  # Validation
  .validate(curves)
  assertthat::assert_that(attr(curves, "dataset_type") == "multiple",
                          msg = "'curves' must contain multiple datasets.")
  assertthat::assert_that(assertthat::is.number(alpha),
                          alpha >= 0 && alpha <= 1)
    msg = "'curves' must contain multiple datasets."
  )
  assertthat::assert_that(
    assertthat::is.number(alpha),
    alpha >= 0 && alpha <= 1
  )
  assertthat::assert_that(assertthat::is.string(dtype))

  # Check type of distribution

@@ -102,7 +109,10 @@

Loading

  if (!is.na(dype_match)) {
    dtype <- dtype_tab[dype_match]
  }
  err_msg = paste0("'dtype' must be one of ", paste(dtype_tab, collapse = ", "))
  err_msg <- paste0(
    "'dtype' must be one of ",
    paste(dtype_tab, collapse = ", ")
  )
  assertthat::assert_that(dtype %in% dtype_tab, msg = err_msg)

  # Get AUC scores

@@ -122,14 +132,18 @@

Loading

      aucs_mean <- mean(aucs_subset$aucs)
      aucs_n <- length(aucs_subset$aucs)
      if (aucs_n < 2) {
        ci_df <- rbind(ci_df,
                       data.frame(modnames = modname,
                                  curvetypes = curvetype,
                                  mean = aucs_mean,
                                  error = 0,
                                  lower_bound = aucs_mean,
                                  upper_bound = aucs_mean,
                                  n = aucs_n))
        ci_df <- rbind(
          ci_df,
          data.frame(
            modnames = modname,
            curvetypes = curvetype,
            mean = aucs_mean,
            error = 0,
            lower_bound = aucs_mean,
            upper_bound = aucs_mean,
            n = aucs_n
          )
        )
        next
      }
      aucs_sd <- sd(aucs_subset$aucs)

@@ -145,16 +159,19 @@

Loading

      acus_lower <- max(aucs_mean - aucs_error, 0.0)
      acus_upper <- min(aucs_mean + aucs_error, 1.0)

      ci_df <- rbind(ci_df,
                     data.frame(modnames = modname,
                                curvetypes = curvetype,
                                mean = aucs_mean,
                                error = aucs_error,
                                lower_bound = acus_lower,
                                upper_bound = acus_upper,
                                n = aucs_n))
      ci_df <- rbind(
        ci_df,
        data.frame(
          modnames = modname,
          curvetypes = curvetype,
          mean = aucs_mean,
          error = aucs_error,
          lower_bound = acus_lower,
          upper_bound = acus_upper,
          n = aucs_n
        )
      )
    }

  }

  ci_df

@@ -103,7 +103,6 @@

Loading

103	103		#' with \pkg{ggplot2}.
104	104		#'
105	105		#' @examples
106		-	#'
107	106		#' \dontrun{
108	107		#' ##################################################
109	108		#' ### Single model & single test dataset

@@ -125,8 +124,10 @@

Loading

#' plot(sscurves, curvetype = "PRC")
#'
#' ## Generate an sspoints object that contains basic evaluation measures
#' sspoints <- evalmod(mode = "basic", scores = P10N10$scores,
#'                     labels = P10N10$labels)
#' sspoints <- evalmod(
#'   mode = "basic", scores = P10N10$scores,
#'   labels = P10N10$labels
#' )
#'
#' ## Plot normalized ranks vs. basic evaluation measures
#' plot(sspoints)

@@ -142,7 +143,8 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)

@@ -170,8 +172,9 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -199,8 +202,9 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -229,9 +233,11 @@

Loading

#' 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)
#' 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)

@@ -247,8 +253,7 @@

Loading

#'
#' ## Normalized ranks vs. average basic evaluation measures
#' plot(cvpoints)
#'
#'}
#' }
#' @name plot
NULL


@@ -279,7 +284,6 @@

Loading

# Check partial match - Basic evaluation measures
#
.pmatch_curvetype_basic <- function(vals) {

  pfunc <- function(val) {
    if (assertthat::is.string(val)) {
      sval <- tolower(val)

@@ -296,8 +300,8 @@

Loading

        return("specificity")
      }

      if (!is.na(pmatch(sval, "sensitivity"))
          || !is.na(pmatch(sval, "recall")) || sval == "tpr" || sval == "sn") {
      if (!is.na(pmatch(sval, "sensitivity")) ||
        !is.na(pmatch(sval, "recall")) || sval == "tpr" || sval == "sn") {
        return("sensitivity")
      }


@@ -305,8 +309,8 @@

Loading

        return("precision")
      }

      if (!is.na(pmatch(sval, "matthews correlation coefficient"))
          || sval == "mcc") {
      if (!is.na(pmatch(sval, "matthews correlation coefficient")) ||
        sval == "mcc") {
        return("mcc")
      }


@@ -355,7 +359,8 @@

Loading

  }
  if (!evalmod_args[["calc_avg"]] && arglist[["show_cb"]]) {
    stop("Invalid show_cb. Inconsistent with calc_avg of evalmod.",
         call. = FALSE)
      call. = FALSE
    )
  }

  if (is.null(arglist[["raw_curves"]])) {

@@ -369,7 +374,8 @@

Loading

  }
  if (!evalmod_args[["raw_curves"]] && arglist[["raw_curves"]]) {
    stop("Invalid raw_curves. Inconsistent with the value of evalmod.",
         call. = FALSE)
      call. = FALSE
    )
  }

  if (is.null(arglist[["add_np_nn"]])) {

@@ -381,7 +387,6 @@

Loading

  }

  arglist

}

#

@@ -396,12 +401,12 @@

Loading


  show_cb <- arglist[["show_cb"]]
  if (!attr(x, "args")$calc_avg) {
    show_cb = FALSE
    show_cb <- FALSE
  }

  raw_curves <- arglist[["raw_curves"]]
  if (show_cb) {
    raw_curves = FALSE
    raw_curves <- FALSE
  }

  # === Validate input arguments ===

@@ -422,9 +427,11 @@

Loading

  }

  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)
    .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 = "")

@@ -443,14 +450,13 @@

Loading

# 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) {
  } else if (ctype_len == 2) {
    nrow1 <- 2
    ncol1 <- 2
    mat1 <- c(1, 2, 3, 3)

@@ -512,9 +518,11 @@

Loading

  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)
  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
  )
}

#

@@ -558,8 +566,10 @@

Loading


  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)
  graphics::plot(1,
    type = "n", main = main, xlab = xlab, ylab = ylab,
    ylim = ylim, xlim = xlim
  )

  if (length(avgcurves) == 1) {
    lcols <- "blue"

@@ -594,15 +604,21 @@

Loading

    }

    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))
    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))
  graphics::lines(x, y,
    type = type, lty = 1, pch = 19,
    col = grDevices::rgb(b[1], b[2], b[3], 200,
      maxColorValue = 255
    )
  )
}

#

@@ -611,7 +627,6 @@

Loading

.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"]]


@@ -630,19 +645,24 @@

Loading


  # === Create a plot ===
  if (show_cb) {
    .plot_avg(x, type, tlist[["ctype"]], main, tlist[["xlab"]],
              tlist[["ylab"]], 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"]])
    .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)
    .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)
  }

@@ -654,7 +674,7 @@

Loading

# Get title and subtitles
#
.get_titiles <- function(curvetype) {
  tlist = list()
  tlist <- list()

  if (curvetype == "ROC") {
    tlist[["main"]] <- "ROC"

@@ -667,15 +687,20 @@

Loading

    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")
    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))
      main <- paste0(
        toupper(substring(curvetype, 1, 1)),
        substring(curvetype, 2)
      )
    }
    tlist[["main"]] <- main
    tlist[["xlab"]] <- "normalized rank"

@@ -694,10 +719,12 @@

Loading

    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)
    graphics::legend(
      x = "top", lty = 1,
      legend = gnames,
      col = grDevices::rainbow(length(gnames), alpha = 1),
      horiz = TRUE
    )
  }
}


@@ -715,16 +742,20 @@

Loading

  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)
        na.rm = TRUE
      )
      min_score <- min(min_score, min(avgcurves[[i]][["y_ci_l"]], na.rm = TRUE),
                       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)
        na.rm = TRUE
      )
      min_score <- min(min_score, min(curves[[i]][["y"]], na.rm = TRUE),
                       na.rm = TRUE)
        na.rm = TRUE
      )
    }
  }


@@ -744,6 +775,8 @@

Loading

744	775		} else {
745	776		xlim <- c(0, 1)
746	777		}
	778	+
	779	+	xlim
747	780		}
748	781
749	782		#

@@ -759,4 +792,6 @@

Loading

759	792		} else {
760	793		ylim <- c(0, 1)
761	794		}
	795	+
	796	+	ylim
762	797		}

@@ -91,8 +91,10 @@

Loading

#' p_prc
#'
#' ## Generate an sspoints object that contains basic evaluation measures
#' sspoints <- evalmod(mode = "basic", scores = P10N10$scores,
#'                     labels = P10N10$labels)
#' sspoints <- evalmod(
#'   mode = "basic", scores = P10N10$scores,
#'   labels = P10N10$labels
#' )
#' ## Fortify sspoints
#' ssdf <- fortify(sspoints)
#'

@@ -109,7 +111,8 @@

Loading

#' ## Create sample datasets with 10 positives and 10 negatives
#' samps <- create_sim_samples(1, 10, 10, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]])
#'   modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)

@@ -155,8 +158,9 @@

Loading

#' ## Create sample datasets with 10 positives and 10 negatives
#' samps <- create_sim_samples(5, 10, 10, "good_er")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -192,8 +196,9 @@

Loading

#' df_prec <- subset(smdf, curvetype == "precision")
#' p_prec <- ggplot(df_prec, aes(x = x, y = y, ymin = ymin, ymax = ymax))
#' p_prec <- p_prec + geom_ribbon(aes(min = ymin, ymax = ymax),
#'                                stat = "identity", alpha = 0.25,
#'                                fill = "grey25")
#'   stat = "identity", alpha = 0.25,
#'   fill = "grey25"
#' )
#' p_prec <- p_prec + geom_point(aes(x = x, y = y))
#' p_prec
#'

@@ -205,8 +210,9 @@

Loading

#' ## Create sample datasets with 10 positives and 10 negatives
#' samps <- create_sim_samples(5, 10, 10, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -242,8 +248,9 @@

Loading

#' df_prec <- subset(mmdf, curvetype == "precision")
#' p_prec <- ggplot(df_prec, aes(x = x, y = y, ymin = ymin, ymax = ymax))
#' p_prec <- p_prec + geom_ribbon(aes(min = ymin, ymax = ymax, group = modname),
#'                                stat = "identity", alpha = 0.25,
#'                                fill = "grey25")
#'   stat = "identity", alpha = 0.25,
#'   fill = "grey25"
#' )
#' p_prec <- p_prec + geom_point(aes(x = x, y = y, color = modname))
#' p_prec
#' }

@@ -256,7 +263,6 @@

Loading

# Process ... for curve objects
#
.get_fortify_arglist <- function(evalmod_args, def_raw_curves, ...) {

  arglist <- list(...)

  if (!is.null(def_raw_curves)) {

@@ -10,10 +10,12 @@

Loading

  new_ties_method <- .pmatch_tiesmethod(ties_method, ...)
  new_na_worst <- .get_new_naworst(na_worst, ...)
  new_mode <- .pmatch_mode(mode)
  .validate_reformat_data_args(scores, labels, modname = modname, dsid = dsid,
                               posclass = posclass, na_worst = new_na_worst,
                               ties_method = new_ties_method, mode = new_mode,
                               ...)
  .validate_reformat_data_args(scores, labels,
    modname = modname, dsid = dsid,
    posclass = posclass, na_worst = new_na_worst,
    ties_method = new_ties_method, mode = new_mode,
    ...
  )

  # === Reformat input data ===
  # Get a factor with "positive" and "negative"

@@ -21,22 +23,29 @@

Loading


  if (mode == "aucroc") {
    # === Create an S3 object ===
    s3obj <- structure(list(scores = scores,
                            labels = fmtlabs[["labels"]]),
                       class = "sdat")
    s3obj <- structure(list(
      scores = scores,
      labels = fmtlabs[["labels"]]
    ),
    class = "sdat"
    )
  } else {
    # Get score ranks and sorted indices
    sranks <- .rank_scores(scores, new_na_worst, new_ties_method,
                           validate = FALSE)
      validate = FALSE
    )
    ranks <- sranks[["ranks"]]
    rank_idx <- sranks[["rank_idx"]]

    # === Create an S3 object ===
    s3obj <- structure(list(scores = scores,
                            labels = fmtlabs[["labels"]],
                            ranks = ranks,
                            rank_idx = rank_idx),
                       class = "fmdat")
    s3obj <- structure(list(
      scores = scores,
      labels = fmtlabs[["labels"]],
      ranks = ranks,
      rank_idx = rank_idx
    ),
    class = "fmdat"
    )
  }

  # Set attributes

@@ -44,9 +53,11 @@

Loading

  attr(s3obj, "dsid") <- dsid
  attr(s3obj, "nn") <- fmtlabs[["nn"]]
  attr(s3obj, "np") <- fmtlabs[["np"]]
  attr(s3obj, "args") <- list(posclass = posclass, na_worst = new_na_worst,
                              ties_method = new_ties_method,
                              modname = modname, dsid = dsid)
  attr(s3obj, "args") <- list(
    posclass = posclass, na_worst = new_na_worst,
    ties_method = new_ties_method,
    modname = modname, dsid = dsid
  )
  attr(s3obj, "validated") <- FALSE

  # Call .validate.fmdat() / .validate.sdat()

@@ -97,7 +108,6 @@

Loading

  }

  # === Create ranks ===
  #   ranks <- rank(scores, na_worst, ties_method)
  sranks <- get_score_ranks(scores, na_worst, ties_method)
  .check_cpp_func_error(sranks, "get_score_ranks")


@@ -115,7 +125,8 @@

Loading

  arglist <- list(...)
  if (!is.null(names(arglist))) {
    stop(paste0("Invalid arguments: ", paste(names(arglist), collapse = ", ")),
         call. = FALSE)
      call. = FALSE
    )
  }

  # Check scores and labels

@@ -138,7 +149,6 @@

Loading


  # Check mode
  .validate_mode(mode)

}

#

@@ -154,30 +164,38 @@

Loading

  item_names <- c("scores", "labels", "ranks", "rank_idx")
  attr_names <- c("modname", "dsid", "nn", "np", "args", "validated")
  arg_names <- c("posclass", "na_worst", "ties_method", "modname", "dsid")
  .validate_basic(fmdat, "fmdat", "reformat_data", item_names, attr_names,
                  arg_names)
  .validate_basic(
    fmdat, "fmdat", "reformat_data", item_names, attr_names,
    arg_names
  )

  # Check values of class items
  if (length(fmdat[["labels"]]) == 0
      || length(fmdat[["labels"]]) != length(fmdat[["ranks"]])
      || length(fmdat[["labels"]]) != length(fmdat[["rank_idx"]])) {
  if (length(fmdat[["labels"]]) == 0 ||
    length(fmdat[["labels"]]) != length(fmdat[["ranks"]]) ||
    length(fmdat[["labels"]]) != length(fmdat[["rank_idx"]])) {
    stop("List items in fmdat must be all the same lengths", call. = FALSE)
  }

  # Labels
  assertthat::assert_that(is.atomic(fmdat[["labels"]]),
                          is.vector(fmdat[["labels"]]),
                          is.numeric(fmdat[["labels"]]))
  assertthat::assert_that(
    is.atomic(fmdat[["labels"]]),
    is.vector(fmdat[["labels"]]),
    is.numeric(fmdat[["labels"]])
  )

  # Ranks
  assertthat::assert_that(is.atomic(fmdat[["ranks"]]),
                          is.vector(fmdat[["ranks"]]),
                          is.numeric(fmdat[["ranks"]]))
  assertthat::assert_that(
    is.atomic(fmdat[["ranks"]]),
    is.vector(fmdat[["ranks"]]),
    is.numeric(fmdat[["ranks"]])
  )

  # Rank index
  assertthat::assert_that(is.atomic(fmdat[["rank_idx"]]),
                          is.vector(fmdat[["rank_idx"]]),
                          is.integer(fmdat[["rank_idx"]]))
  assertthat::assert_that(
    is.atomic(fmdat[["rank_idx"]]),
    is.vector(fmdat[["rank_idx"]]),
    is.integer(fmdat[["rank_idx"]])
  )

  attr(fmdat, "validated") <- TRUE
  fmdat

@@ -196,21 +214,24 @@

Loading

  item_names <- c("scores", "labels")
  attr_names <- c("modname", "dsid", "nn", "np", "args", "validated")
  arg_names <- c("posclass", "na_worst", "ties_method", "modname", "dsid")
  .validate_basic(sdat, "sdat", "reformat_data", item_names, attr_names,
                  arg_names)
  .validate_basic(
    sdat, "sdat", "reformat_data", item_names, attr_names,
    arg_names
  )

  # Check values of class items
  if (length(sdat[["labels"]]) == 0
      || length(sdat[["labels"]]) != length(sdat[["scores"]])) {
  if (length(sdat[["labels"]]) == 0 ||
    length(sdat[["labels"]]) != length(sdat[["scores"]])) {
    stop("List items in sdat must be all the same lengths", call. = FALSE)
  }

  # Labels
  assertthat::assert_that(is.atomic(sdat[["labels"]]),
                          is.vector(sdat[["labels"]]),
                          is.numeric(sdat[["labels"]]))
  assertthat::assert_that(
    is.atomic(sdat[["labels"]]),
    is.vector(sdat[["labels"]]),
    is.numeric(sdat[["labels"]])
  )

  attr(sdat, "validated") <- TRUE
  sdat
}


@@ -8,7 +8,8 @@

Loading

#
.validate.default <- function(x) {
  stop(paste0("Unrecognized class for .validate(): '", class(x), "'"),
       call. = FALSE)
    call. = FALSE
  )
}

#

@@ -18,32 +19,44 @@

Loading

                            arg_names) {
  # Check class
  if (!methods::is(obj, class_name)) {
    stop(paste0("Expected ", class_name, " created by ", func_name, "(): ",
                class(obj)),
         call. = FALSE)
    stop(paste0(
      "Expected ", class_name, " created by ", func_name, "(): ",
      class(obj)
    ),
    call. = FALSE
    )
  }

  # Check class items
  ditems <- setdiff(item_names, names(obj))
  if (!is.null(item_names) && length(ditems) > 0) {
    stop(paste0("Invalid list items in ", class_name, ": ",
                paste(ditems, collapse = ", ")),
         call. = FALSE)
    stop(paste0(
      "Invalid list items in ", class_name, ": ",
      paste(ditems, collapse = ", ")
    ),
    call. = FALSE
    )
  }

  # Check attributes
  ditems <- setdiff(attr_names, names(attributes(obj)))
  if (!is.null(attr_names) && length(ditems) > 0) {
    stop(paste0("Invalid attributes in ", class_name, ": ",
                paste(ditems, collapse = ", ")),
         call. = FALSE)
    stop(paste0(
      "Invalid attributes in ", class_name, ": ",
      paste(ditems, collapse = ", ")
    ),
    call. = FALSE
    )
  }

  # Check args
  ditems <- setdiff(names(attr(obj, "args")), arg_names)
  if (!is.null(arg_names) && length(ditems) > 0) {
    stop(paste0("Invalid args attribute in ", class_name, ": ",
                paste(ditems, collapse = ", ")),
         call. = FALSE)
    stop(paste0(
      "Invalid args in ", class_name, ": ",
      paste(ditems, collapse = ", ")
    ),
    call. = FALSE
    )
  }
}

@@ -2,9 +2,9 @@

Loading

#' @export
as.data.frame.sscurves <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = TRUE, ...)
    def_raw_curves = TRUE, ...
  )

  .dataframe_common(x, raw_curves = arglist[["raw_curves"]], ...)
}

@@ -13,9 +13,9 @@

Loading

#' @export
as.data.frame.mscurves <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = TRUE, ...)
    def_raw_curves = TRUE, ...
  )

  .dataframe_common(x, raw_curves = arglist[["raw_curves"]], ...)
}

@@ -24,9 +24,9 @@

Loading

#' @export
as.data.frame.smcurves <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(x, raw_curves = arglist[["raw_curves"]], ...)
}

@@ -35,9 +35,9 @@

Loading

#' @export
as.data.frame.mmcurves <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(x, raw_curves = arglist[["raw_curves"]], ...)
}

@@ -46,48 +46,56 @@

Loading

#' @export
as.data.frame.sspoints <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = TRUE, ...)
    def_raw_curves = TRUE, ...
  )

  .dataframe_common(x, mode = "basic", raw_curves = arglist[["raw_curves"]],
                    ...)
  .dataframe_common(x,
    mode = "basic", raw_curves = arglist[["raw_curves"]],
    ...
  )
}

#' @rdname as.data.frame
#' @export
as.data.frame.mspoints <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = TRUE, ...)
    def_raw_curves = TRUE, ...
  )

  .dataframe_common(x, mode = "basic", raw_curves = arglist[["raw_curves"]],
                    ...)
  .dataframe_common(x,
    mode = "basic", raw_curves = arglist[["raw_curves"]],
    ...
  )
}

#' @rdname as.data.frame
#' @export
as.data.frame.smpoints <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(x, mode = "basic", raw_curves = arglist[["raw_curves"]],
                    ...)
  .dataframe_common(x,
    mode = "basic", raw_curves = arglist[["raw_curves"]],
    ...
  )
}

#' @rdname as.data.frame
#' @export
as.data.frame.mmpoints <- function(x, row.names = NULL, optional = FALSE,
                                   raw_curves = NULL, ...) {

  arglist <- .get_dataframe_arglist(attr(x, "args"),
                                    def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(x, mode = "basic", raw_curves = arglist[["raw_curves"]],
                    ...)
  .dataframe_common(x,
    mode = "basic", raw_curves = arglist[["raw_curves"]],
    ...
  )
}

#' @rdname as.data.frame

@@ -95,4 +103,3 @@

Loading

95	103		as.data.frame.aucroc <- function(x, row.names = NULL, optional = FALSE, ...) {
96	104		x$uaucs
97	105		}
98		-

@@ -40,8 +40,8 @@

Loading

#'   input with calculated pAUCs and standardized pAUCs.
#'
#' @seealso \code{\link{evalmod}} for generating \code{S3} objects with
#'   performance evaluation measures. \code{\link{pauc}} for retrieving a dataset
#'   of pAUCs.
#'   performance evaluation measures. \code{\link{pauc}} for retrieving
#'   a dataset of pAUCs.
#'
#' @examples
#' \dontrun{

@@ -79,7 +79,8 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)

@@ -104,8 +105,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "good_er")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat)

@@ -130,8 +132,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -150,10 +153,12 @@

Loading

#' }
#'
#' @export
part <- function(curves, xlim=NULL, ylim=NULL, curvetype=NULL) UseMethod("part", curves)
part <- function(curves, xlim = NULL, ylim = NULL, curvetype = NULL) {
  UseMethod("part", curves)
}

#' @export
part.default <- function(curves, xlim=NULL, ylim=NULL, curvetype=NULL) {
part.default <- function(curves, xlim = NULL, ylim = NULL, curvetype = NULL) {
  stop("An object of unknown class is specified")
}


@@ -206,9 +211,13 @@

Loading

  # Calculate partial AUC scores for ROC
  if ("ROC" %in% new_curvetype) {
    if (avg_only) {
      attr(curves, "grp_avg")[["rocs"]] <- .calc_pauc(attr(curves,
                                                           "grp_avg")[["rocs"]],
                                                      xlim, ylim, avg_only)
      attr(curves, "grp_avg")[["rocs"]] <- .calc_pauc(
        attr(
          curves,
          "grp_avg"
        )[["rocs"]],
        xlim, ylim, avg_only
      )
    } else {
      curves[["rocs"]] <- .calc_pauc(curves[["rocs"]], xlim, ylim, avg_only)
    }

@@ -219,9 +228,13 @@

Loading

  # Calculate partial AUC scores for precision-recall
  if ("PRC" %in% new_curvetype) {
    if (avg_only) {
      attr(curves, "grp_avg")[["prcs"]] <- .calc_pauc(attr(curves,
                                                           "grp_avg")[["prcs"]],
                                                      xlim, ylim, avg_only)
      attr(curves, "grp_avg")[["prcs"]] <- .calc_pauc(
        attr(
          curves,
          "grp_avg"
        )[["prcs"]],
        xlim, ylim, avg_only
      )
    } else {
      curves[["prcs"]] <- .calc_pauc(curves[["prcs"]], xlim, ylim, avg_only)
    }

@@ -243,7 +256,6 @@

Loading

# Calculate partial AUC scores
#
.calc_pauc <- function(curves, xlim, ylim, avg_only) {

  for (i in seq_along(curves)) {
    # Trim x
    x <- curves[[i]][["x"]]

@@ -279,11 +291,11 @@

Loading


    # Max 1
    if (pauc > 1) {
      pauc = 1
      pauc <- 1
    }

    if (spauc > 1) {
      spauc = 1
      spauc <- 1
    }

    attr(curves[[i]], "pauc") <- pauc

@@ -304,19 +316,25 @@

Loading

  # Collect AUCs of ROC or PRC curves
  ct_len <- 2
  aucs <- attr(curves, "aucs")
  paucs <- data.frame(modnames = aucs$modnames,
                      dsids = aucs$dsids,
                      curvetypes = aucs$curvetypes,
                      paucs = rep(NA, length(aucs$modnames)),
                      spaucs = rep(NA, length(aucs$modnames)),
                      stringsAsFactors = FALSE)
  paucs <- data.frame(
    modnames = aucs$modnames,
    dsids = aucs$dsids,
    curvetypes = aucs$curvetypes,
    paucs = rep(NA, length(aucs$modnames)),
    spaucs = rep(NA, length(aucs$modnames)),
    stringsAsFactors = FALSE
  )

  for (i in seq_along(curves[["rocs"]])) {
    idx <- ct_len * i - 1
    paucs[["paucs"]][idx:(idx + 1)] <- c(attr(curves[["rocs"]][[i]], "pauc"),
                                         attr(curves[["prcs"]][[i]], "pauc"))
    paucs[["spaucs"]][idx:(idx + 1)] <- c(attr(curves[["rocs"]][[i]], "spauc"),
                                          attr(curves[["prcs"]][[i]], "spauc"))
    paucs[["paucs"]][idx:(idx + 1)] <- c(
      attr(curves[["rocs"]][[i]], "pauc"),
      attr(curves[["prcs"]][[i]], "pauc")
    )
    paucs[["spaucs"]][idx:(idx + 1)] <- c(
      attr(curves[["rocs"]][[i]], "spauc"),
      attr(curves[["prcs"]][[i]], "spauc")
    )
  }

  paucs

@@ -326,25 +344,30 @@

Loading

# Get pAUCs of average curves
#
.gather_paucs_avg <- function(curves) {

  avg_crvs <- attr(curves, "grp_avg")

  # Collect AUCs of ROC or PRC curves
  ct_len <- 2
  modnames <- attr(avg_crvs[["rocs"]], "uniq_modnames")
  paucs <- data.frame(modnames = rep(modnames, each = ct_len),
                      curvetypes = rep(c("ROC", "PRC"), length(modnames)),
                      paucs = rep(NA, length(modnames) * ct_len),
                      spaucs = rep(NA, length(modnames) * ct_len),
                      stringsAsFactors = FALSE)
  paucs <- data.frame(
    modnames = rep(modnames, each = ct_len),
    curvetypes = rep(c("ROC", "PRC"), length(modnames)),
    paucs = rep(NA, length(modnames) * ct_len),
    spaucs = rep(NA, length(modnames) * ct_len),
    stringsAsFactors = FALSE
  )

  for (i in seq_along(avg_crvs[["rocs"]])) {
    idx <- ct_len * i - 1
    idx2 <- idx + 1
    paucs[["paucs"]][idx:idx2] <- c(attr(avg_crvs[["rocs"]][[i]], "pauc"),
                                    attr(avg_crvs[["prcs"]][[i]], "pauc"))
    paucs[["spaucs"]][idx:idx2] <- c(attr(avg_crvs[["rocs"]][[i]], "spauc"),
                                     attr(avg_crvs[["prcs"]][[i]], "spauc"))
    paucs[["paucs"]][idx:idx2] <- c(
      attr(avg_crvs[["rocs"]][[i]], "pauc"),
      attr(avg_crvs[["prcs"]][[i]], "pauc")
    )
    paucs[["spaucs"]][idx:idx2] <- c(
      attr(avg_crvs[["rocs"]][[i]], "spauc"),
      attr(avg_crvs[["prcs"]][[i]], "spauc")
    )
  }

  paucs

@@ -3,16 +3,20 @@

Loading

#
calc_avg_rocprc <- function(curves, modnames, uniq_modnames, cb_alpha,
                            x_bins) {
  .calc_avg_common(curves, "curve", "avgcurves", modnames, uniq_modnames,
                   cb_alpha, x_bins)
  .calc_avg_common(
    curves, "curve", "avgcurves", modnames, uniq_modnames,
    cb_alpha, x_bins
  )
}

#
# Calculate the average points for a model
#
calc_avg_basic <- function(epoints, modnames, uniq_modnames, cb_alpha) {
  .calc_avg_common(epoints, "point", "avgpoints", modnames, uniq_modnames,
                   cb_alpha, NULL)
  .calc_avg_common(
    epoints, "point", "avgpoints", modnames, uniq_modnames,
    cb_alpha, NULL
  )
}

#

@@ -43,7 +47,6 @@

Loading

    if (mode == "curve") {
      avgs <- calc_avg_curve(obj_by_model[[i]], x_bins, cb_zval)
      .check_cpp_func_error(avgs, "calc_avg_curve")

    } else if (mode == "point") {
      avgs <- calc_avg_points(obj_by_model[[i]], cb_zval)
      .check_cpp_func_error(avgs, "calc_avg_basic")

@@ -60,8 +63,10 @@

Loading

  attr(s3obj, "cb_zval") <- cb_zval
  attr(s3obj, "pauc") <- NA
  attr(s3obj, "spauc") <- NA
  attr(s3obj, "args") <- list(cb_alpha = cb_alpha,
                              x_bins = x_bins)
  attr(s3obj, "args") <- list(
    cb_alpha = cb_alpha,
    x_bins = x_bins
  )
  attr(s3obj, "validated") <- FALSE

  # Call .validate()

@@ -81,8 +86,10 @@

Loading

  item_names <- NULL
  attr_names <- c("uniq_modnames", "cb_zval", "args", "validated")
  arg_names <- c("cb_alpha", "x_bins")
  .validate_basic(avgobj, class_name, func_name, item_names, attr_names,
                  arg_names)
  .validate_basic(
    avgobj, class_name, func_name, item_names, attr_names,
    arg_names
  )

  attr(avgobj, "validated") <- TRUE
  avgobj

@@ -15,22 +15,29 @@

Loading

      } else {
        cl <- "negative"
      }
      err_msg <- paste0("AUCs with the U statistic cannot be calculated. ",
                        "Only a single class (", cl, ") ",
                        "found in dataset (modname: ", attr(mdat[[s]], "modname"),
                        ", dsid: ",attr(mdat[[s]], "dsid"), ").")
      err_msg <- paste0(
        "AUCs with the U statistic cannot be calculated. ",
        "Only a single class (", cl, ") ",
        "found in dataset (modname: ",
        attr(mdat[[s]], "modname"),
        ", dsid: ", attr(mdat[[s]], "dsid"), ")."
      )
      stop(err_msg, call. = FALSE)
    }
    uauc <- calc_auc_with_u(mdat[[s]], na_worst = na_worst,
                            ties_method = ties_method)
    calc_auc_with_u(mdat[[s]],
      na_worst = na_worst,
      ties_method = ties_method
    )
  }
  aucrocs <- lapply(seq_along(mdat), plfunc)
  auc.df <- .summarize_uauc_results(aucrocs, attr(mdat, "uniq_modnames"),
                                    attr(mdat, "uniq_dsids"), calc_avg,
                                    cb_alpha, raw_curves)
  auc_df <- .summarize_uauc_results(
    aucrocs, attr(mdat, "uniq_modnames"),
    attr(mdat, "uniq_dsids"), calc_avg,
    cb_alpha, raw_curves
  )

  # === Create an S3 object ===
  s3obj <- structure(auc.df, class = "aucroc")
  s3obj <- structure(auc_df, class = "aucroc")

  # Set attributes
  attr(s3obj, "data_info") <- attr(mdat, "data_info")

@@ -38,12 +45,14 @@

Loading

  attr(s3obj, "uniq_dsids") <- attr(mdat, "uniq_dsids")
  attr(s3obj, "model_type") <- model_type
  attr(s3obj, "dataset_type") <- dataset_type
  attr(s3obj, "args") <- list(mode = "aucroc",
                              calc_avg = calc_avg,
                              cb_alpha = cb_alpha,
                              raw_curves = raw_curves,
                              na_worst = na_worst,
                              ties_method = ties_method)
  attr(s3obj, "args") <- list(
    mode = "aucroc",
    calc_avg = calc_avg,
    cb_alpha = cb_alpha,
    raw_curves = raw_curves,
    na_worst = na_worst,
    ties_method = ties_method
  )
  attr(s3obj, "validated") <- FALSE

  # Call .validate.class_name()

@@ -61,12 +70,18 @@

Loading


  # Validate class items and attributes
  item_names <- NULL
  attr_names <- c("data_info", "uniq_modnames", "uniq_dsids",
                  "model_type", "dataset_type", "args", "validated")
  arg_names <- c("mode", "calc_avg", "cb_alpha", "raw_curves", "na_worst",
                 "ties_method")
  .validate_basic(aucroc, "aucroc", ".pl_main_aucroc", item_names,
                  attr_names, arg_names)
  attr_names <- c(
    "data_info", "uniq_modnames", "uniq_dsids",
    "model_type", "dataset_type", "args", "validated"
  )
  arg_names <- c(
    "mode", "calc_avg", "cb_alpha", "raw_curves", "na_worst",
    "ties_method"
  )
  .validate_basic(
    aucroc, "aucroc", ".pl_main_aucroc", item_names,
    attr_names, arg_names
  )

  attr(aucroc, "validated") <- TRUE
  aucroc

@@ -93,12 +108,13 @@

Loading

      vustat[i] <- aucs[[i]]$ustat
    }

    auc_df <- data.frame(modnames = vmodname,
                         dsids = vdsid,
                         aucs = vaucs,
                         ustats = vustat)
    auc_df <- data.frame(
      modnames = vmodname,
      dsids = vdsid,
      aucs = vaucs,
      ustats = vustat
    )
  }

  list(uaucs = auc_df)
}


@@ -68,13 +68,15 @@

Loading


  # === Validate input arguments ===
  choices <- c("random", "poor_er", "good_er", "excel", "perf")
  if (assertthat::see_if(assertthat::is.string(score_names))
      && any(score_names == "all")) {
  if (assertthat::see_if(assertthat::is.string(score_names)) &&
    any(score_names == "all")) {
    score_names <- choices
  } else if (!is.atomic(score_names) || !is.character(score_names)
             || !(all(score_names %in% choices))) {
    stop(gettextf("'score_names' must be one of %s",
                  paste(dQuote(choices), collapse = ", ")), call. = FALSE)
  } else if (!is.atomic(score_names) || !is.character(score_names) ||
    !(all(score_names %in% choices))) {
    stop(gettextf(
      "'score_names' must be one of %s",
      paste(dQuote(choices), collapse = ", ")
    ), call. = FALSE)
  }
  snames <- paste0(score_names, "_scores")


@@ -97,10 +99,12 @@

Loading

  labels <- c(rep(1, np), rep(0, nn))

  # === Make a list ===
  list(scores = scores,
       labels = labels,
       modnames = rep(score_names, n_repeat),
       dsids = rep(seq(n_repeat), each = length(score_names)))
  list(
    scores = scores,
    labels = labels,
    modnames = rep(score_names, n_repeat),
    dsids = rep(seq(n_repeat), each = length(score_names))
  )
}

#

@@ -115,13 +119,14 @@

Loading

  excel_scores <- c(stats::rnorm(np, 3, 1), stats::rnorm(nn, 0, 1))
  perf_scores <- c(rep(1, np), rep(0, nn))

  list(np = np,
       nn = nn,
       labels = labels,
       random_scores = random_scores,
       poor_er_scores = poor_er_scores,
       good_er_scores = good_er_scores,
       excel_scores = excel_scores,
       perf_scores = perf_scores
  list(
    np = np,
    nn = nn,
    labels = labels,
    random_scores = random_scores,
    poor_er_scores = poor_er_scores,
    good_er_scores = good_er_scores,
    excel_scores = excel_scores,
    perf_scores = perf_scores
  )
}

@@ -11,10 +11,14 @@

Loading

  cat("    === Input data ===\n\n")

  data_info <- attr(x, "data_info")
  rownames(data_info) <- format(rownames(data_info), width = 4,
                                justify = "right")
  colnames(data_info) <- c("Model name", "Dataset ID", "# of negatives",
                           "# of positives")
  rownames(data_info) <- format(rownames(data_info),
    width = 4,
    justify = "right"
  )
  colnames(data_info) <- c(
    "Model name", "Dataset ID", "# of negatives",
    "# of positives"
  )

  print.data.frame(data_info, print.gap = 1)


@@ -51,8 +55,10 @@

Loading

      colnames(paucs) <- c("Model name", "Curve type", "pAUC", "Standardized")
    } else {
      cat("    === partial AUCs ===\n")
      colnames(paucs) <- c("Model name", "Dataset ID", "Curve type", "pAUC",
                           "Standardized")
      colnames(paucs) <- c(
        "Model name", "Dataset ID", "Curve type", "pAUC",
        "Standardized"
      )
    }

    cat("\n")

@@ -88,12 +94,18 @@

Loading

  cat("\n\n")

  eval_summary <- attr(x, "eval_summary")
  rownames(eval_summary) <- format(rownames(eval_summary), width = 4,
                                   justify = "right")
  colnames(eval_summary) <- c("Model", "ID", "Meas.", "Min.",
                              "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")
  evaltypes <- c("rank", "score", "label", "err", "acc", "sp", "sn", "prec",
                 "mcc", "fscore")
  rownames(eval_summary) <- format(rownames(eval_summary),
    width = 4,
    justify = "right"
  )
  colnames(eval_summary) <- c(
    "Model", "ID", "Meas.", "Min.",
    "1st Qu.", "Median", "Mean", "3rd Qu.", "Max."
  )
  evaltypes <- c(
    "rank", "score", "label", "err", "acc", "sp", "sn", "prec",
    "mcc", "fscore"
  )
  eval_summary[, "Meas."] <- evaltypes

  print.data.frame(eval_summary, print.gap = 1)

@@ -115,10 +127,14 @@

Loading

  cat("    === Input data ===\n\n")

  data_info <- attr(x, "data_info")
  rownames(data_info) <- format(rownames(data_info), width = 4,
                                justify = "right")
  colnames(data_info) <- c("Model name", "Dataset ID", "# of negatives",
                           "# of positives")
  rownames(data_info) <- format(rownames(data_info),
    width = 4,
    justify = "right"
  )
  colnames(data_info) <- c(
    "Model name", "Dataset ID", "# of negatives",
    "# of positives"
  )

  print.data.frame(data_info, print.gap = 1)
  cat("\n\n")

@@ -4,7 +4,8 @@

Loading

#'   \code{\link{evalmod}} to a data frame.
#'
#' @param x An \code{S3} object generated by \code{\link{evalmod}}.
#'   The \code{as.data.frame} function takes one of the following \code{S3} objects.
#'   The \code{as.data.frame} function takes
#'     one of the following \code{S3} objects.
#'
#' \enumerate{
#'

@@ -63,7 +64,6 @@

Loading

#'   performance evaluation measures.
#'
#' @examples
#'
#' \dontrun{
#' ##################################################
#' ### Single model & single test dataset

@@ -82,8 +82,10 @@

Loading

#' head(sscurves.df)
#'
#' ## Generate an sspoints object that contains basic evaluation measures
#' sspoints <- evalmod(mode = "basic", scores = P10N10$scores,
#'                     labels = P10N10$labels)
#' sspoints <- evalmod(
#'   mode = "basic", scores = P10N10$scores,
#'   labels = P10N10$labels
#' )
#' ## Convert sspoints to a data frame
#' sspoints.df <- as.data.frame(sspoints)
#'

@@ -98,7 +100,8 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)

@@ -126,8 +129,9 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -155,8 +159,9 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -185,9 +190,11 @@

Loading

#' 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)
#' 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)

@@ -214,8 +221,10 @@

Loading

#'
#' ## mode = "aucroc"
#' data(P10N10)
#' uauc1 <- evalmod(scores = P10N10$scores, labels = P10N10$labels,
#'                  mode="aucroc")
#' uauc1 <- evalmod(
#'   scores = P10N10$scores, labels = P10N10$labels,
#'   mode = "aucroc"
#' )
#'
#' # as.data.frame 'aucroc'
#' as.data.frame(uauc1)

@@ -223,9 +232,10 @@

Loading

#' ## mode = "aucroc"
#' samps <- create_sim_samples(10, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#' uauc2 <- evalmod(mdat, mode="aucroc")
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#' uauc2 <- evalmod(mdat, mode = "aucroc")
#'
#' # as.data.frame 'aucroc'
#' head(as.data.frame(uauc2))

@@ -271,51 +281,61 @@

Loading

    } else {
      x_bins <- 0
    }

  } else if (new_mode == "basic") {
    curvetype_names <- list(score = "score", label = "label", error = "err",
                            accuracy = "acc", specificity = "sp",
                            sensitivity = "sn", precision = "prec", mcc = "mcc",
                            fscore = "fscore")
    curvetype_names <- list(
      score = "score", label = "label", error = "err",
      accuracy = "acc", specificity = "sp",
      sensitivity = "sn", precision = "prec", mcc = "mcc",
      fscore = "fscore"
    )
    x_bins <- 0
  }

  # Make dsis-modname pairs
  dsid_modnames <- paste(attr(obj, "data_info")$modnames,
                         attr(obj, "data_info")$dsids, sep = ":")
    attr(obj, "data_info")$dsids,
    sep = ":"
  )

  # Create curve_df
  if (raw_curves) {
    if (use_rcpp) {
      list_df <- convert_curve_df(obj, uniq_modnames, as.character(uniq_dsids),
                                  match(modnames, uniq_modnames),
                                  match(dsids, uniq_dsids),
                                  dsid_modnames, curvetype_names, x_bins)
      list_df <- convert_curve_df(
        obj, uniq_modnames, as.character(uniq_dsids),
        match(modnames, uniq_modnames),
        match(dsids, uniq_dsids),
        dsid_modnames, curvetype_names, x_bins
      )
      .check_cpp_func_error(list_df, "convert_curve_df")
      curve_df <- list_df[["df"]]
    } else {
      curve_df <- .dataframe_curve(obj, uniq_modnames, uniq_dsids, modnames,
                                   dsids, dsid_modnames, curvetype_names)
      curve_df <- .dataframe_curve(
        obj, uniq_modnames, uniq_dsids, modnames,
        dsids, dsid_modnames, curvetype_names
      )
      warning("R version of .dataframe_common is used")
    }
  } else {
    if (use_rcpp) {
      list_df <- convert_curve_avg_df(attr(obj, "grp_avg"), uniq_modnames,
                                      match(modnames, uniq_modnames),
                                      curvetype_names, x_bins)
      list_df <- convert_curve_avg_df(
        attr(obj, "grp_avg"), uniq_modnames,
        match(modnames, uniq_modnames),
        curvetype_names, x_bins
      )
      .check_cpp_func_error(list_df, "convert_curve_avg_df")
      curve_df <- list_df[["df"]]
    } else {
      curve_df <- .dataframe_curve_avg(obj, uniq_modnames, uniq_dsids, modnames,
                                       dsids, dsid_modnames, curvetype_names)
      curve_df <- .dataframe_curve_avg(
        obj, uniq_modnames, uniq_dsids, modnames,
        dsids, dsid_modnames, curvetype_names
      )
      warning("R version of .dataframe_common is used")
    }

  }

  if (!check_ggplot) {
    if ("dsid_modname" %in% names(curve_df)) {
      curve_df <- with(curve_df, subset(curve_df, select = -dsid_modname))
      curve_df[["dsid_modname"]] <- NULL
    }
    colnum <- ncol(curve_df)
    names(curve_df) <- c(names(curve_df)[1:(colnum - 1)], "type")

@@ -329,7 +349,6 @@

Loading

#
.dataframe_curve <- function(obj, uniq_modnames, uniq_dsids, modnames, dsids,
                             dsid_modnames, curvetype_names) {

  curve_df <- NULL
  for (curvetype in names(curvetype_names)) {
    curves <- obj[[curvetype_names[[curvetype]]]]

@@ -339,15 +358,21 @@

Loading


      modname <- factor(rep(modnames[i], length(x)), levels = uniq_modnames)
      dsid <- factor(rep(dsids[i], length(x)), levels = uniq_dsids)
      dsid_modname <- factor(rep(paste(modnames[i], dsids[i], sep = ":"),
                                 length(x)),
                             levels = dsid_modnames)
      dsid_modname <- factor(rep(
        paste(modnames[i], dsids[i], sep = ":"),
        length(x)
      ),
      levels = dsid_modnames
      )
      curvename <- factor(rep(curvetype, length(x)),
                          levels = names(curvetype_names))
      curve_df <- rbind(curve_df, data.frame(x = x, y = y, modname = modname,
                                             dsid = dsid,
                                             dsid_modname = dsid_modname,
                                             curvetype = curvename))
        levels = names(curvetype_names)
      )
      curve_df <- rbind(curve_df, data.frame(
        x = x, y = y, modname = modname,
        dsid = dsid,
        dsid_modname = dsid_modname,
        curvetype = curvename
      ))
    }
  }


@@ -357,9 +382,8 @@

Loading

#
# Make a dataframe for plotting with average curves
#
.dataframe_curve_avg <- function(obj, uniq_modnames, uniq_dsids, modnames, dsids,
                               dsid_modnames, curvetype_names) {

.dataframe_curve_avg <- function(obj, uniq_modnames, uniq_dsids, modnames,
                                 dsids, dsid_modnames, curvetype_names) {
  grp_avg <- attr(obj, "grp_avg")
  curve_df <- NULL
  for (curvetype in names(curvetype_names)) {

@@ -372,13 +396,17 @@

Loading

      ymax <- avgcurves[[i]][["y_ci_h"]]

      modname <- factor(rep(uniq_modnames[i], length(x)),
                        levels = uniq_modnames)
        levels = uniq_modnames
      )
      curvename <- factor(rep(curvetype, length(x)),
                          levels = names(curvetype_names))
      curve_df <- rbind(curve_df, data.frame(x = x, y = y,
                                             ymin = ymin, ymax = ymax,
                                             modname = modname,
                                             curvetype = curvename))
        levels = names(curvetype_names)
      )
      curve_df <- rbind(curve_df, data.frame(
        x = x, y = y,
        ymin = ymin, ymax = ymax,
        modname = modname,
        curvetype = curvename
      ))
    }
  }


@@ -389,7 +417,6 @@

Loading

# Process ... for curve objects
#
.get_dataframe_arglist <- function(evalmod_args, def_raw_curves, ...) {

  arglist <- list(...)

  if (is.null(arglist[["raw_curves"]])) {

@@ -404,4 +431,3 @@

Loading

404	431
405	432		arglist
406	433		}
407		-

@@ -97,11 +97,12 @@

Loading

#'   the supporting points are calculated. \code{x_bins} is effective only
#'   when \code{mode} is set to \code{rocprc} or \code{prcroc}.
#'
#' @param interpolate A Boolean value to specify whether or not interpolation of
#'   ROC and precision-recall curves are performed. \code{x_bins} and \code{calc_avg} are
#'    ignored and  when \code{x_bins} is set to \code{FALSE}.
#'    \code{interpolate} is effective only when \code{mode} is set
#'    to \code{rocprc} or \code{prcroc}.
#' @param interpolate A Boolean value to specify whether or not
#'   interpolation of ROC and precision-recall curves are
#'   performed. \code{x_bins} and \code{calc_avg} are
#'   ignored and  when \code{x_bins} is set to \code{FALSE}.
#'   \code{interpolate} is effective only when \code{mode} is set
#'   to \code{rocprc} or \code{prcroc}.
#'
#' @param ... These additional arguments are passed to \code{\link{mmdata}}
#'   for data preparation.

@@ -151,7 +152,8 @@

Loading

#'   }
#'
#'   \item The \code{evalmod} function returns the \code{aucroc} S3 object
#'   when \code{mode} is "aucroc", which can be used with 'print' and 'as.data.frame'.
#'   when \code{mode} is "aucroc", which can be used with 'print'
#'   and 'as.data.frame'.
#'
#' }
#'

@@ -179,8 +181,10 @@

Loading

#' sscurves
#'
#' ## Generate an sspoints object that contains basic evaluation measures
#' sspoints <- evalmod(mode = "basic", scores = P10N10$scores,
#'                     labels = P10N10$labels)
#' sspoints <- evalmod(
#'   mode = "basic", scores = P10N10$scores,
#'   labels = P10N10$labels
#' )
#' sspoints
#'
#'

@@ -191,7 +195,8 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)

@@ -209,8 +214,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "good_er")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat)

@@ -228,8 +234,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mmcurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat)

@@ -248,9 +255,11 @@

Loading

#' 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)
#' 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)

@@ -261,9 +270,11 @@

Loading

#' cvpoints
#'
#' ## Specify mmdata arguments from evalmod
#' cvcurves2 <- evalmod(nfold_df = M2N50F5, score_cols = c(1, 2),
#'                      lab_col = 3, fold_col = 4,
#'                      modnames = c("m1", "m2"), dsids = 1:5)
#' cvcurves2 <- evalmod(
#'   nfold_df = M2N50F5, score_cols = c(1, 2),
#'   lab_col = 3, fold_col = 4,
#'   modnames = c("m1", "m2"), dsids = 1:5
#' )
#' cvcurves2
#'
#'

@@ -275,8 +286,10 @@

Loading

#' data(P10N10)
#'
#' # 'aucroc' S3 object
#' uauc1 <- evalmod(scores = P10N10$scores, labels = P10N10$labels,
#'                  mode="aucroc")
#' uauc1 <- evalmod(
#'   scores = P10N10$scores, labels = P10N10$labels,
#'   mode = "aucroc"
#' )
#'
#' # print 'aucroc'
#' uauc1

@@ -290,13 +303,13 @@

Loading

#'
#' # a function to test mode = "rocprc"
#' func_evalmod_rocprc <- function(samp) {
#'    curves <- evalmod(scores = samp$scores, labels = samp$labels)
#'    aucs <- auc(curves)
#'   curves <- evalmod(scores = samp$scores, labels = samp$labels)
#'   aucs <- auc(curves)
#' }
#'
#' # a function to test mode = "aucroc"
#' func_evalmod_aucroc <- function(samp) {
#'   uaucs <- evalmod(scores = samp$scores, labels = samp$labels, mode="aucroc")
#'   uaucs <- evalmod(scores = samp$scores, labels = samp$labels, mode = "aucroc")
#'   as.data.frame(uaucs)
#' }
#'

@@ -322,25 +335,29 @@

Loading

  if (x_bins == 0) {
    x_bins <- 1
  }
  .validate_evalmod_args(new_mode, modnames, dsids, posclass, new_na_worst,
                         new_ties_method, calc_avg, cb_alpha, raw_curves,
                         x_bins, interpolate)
  .validate_evalmod_args(
    new_mode, modnames, dsids, posclass, new_na_worst,
    new_ties_method, calc_avg, cb_alpha, raw_curves,
    x_bins, interpolate
  )

  # Create mdat if not provided
  if (missing(mdat)) {
    mdat <- mmdata(scores, labels,
                   modnames = modnames, dsids = dsids, posclass = posclass,
                   na_worst = new_na_worst, ties_method = new_ties_method,
                   mode = new_mode, ...)
      modnames = modnames, dsids = dsids, posclass = posclass,
      na_worst = new_na_worst, ties_method = new_ties_method,
      mode = new_mode, ...
    )
  }
  .validate(mdat)

  # Call pipeline controller
  pl_main(mdat, mode = new_mode, calc_avg = calc_avg, cb_alpha = cb_alpha,
          raw_curves = raw_curves, x_bins = x_bins, interpolate = interpolate,
          na_worst = new_na_worst,ties_method = new_ties_method,
          validate = FALSE)

  pl_main(mdat,
    mode = new_mode, calc_avg = calc_avg, cb_alpha = cb_alpha,
    raw_curves = raw_curves, x_bins = x_bins, interpolate = interpolate,
    na_worst = new_na_worst, ties_method = new_ties_method,
    validate = FALSE
  )
}

#

@@ -356,10 +373,13 @@

Loading

  new_mode <- NA
  if (!is.null(mode)) {
    new_mode <- .pmatch_mode(mode)
    if (new_mode != "aucroc" && !is.na(mdat_mode) &&  mdat_mode == "aucroc") {
      stop(paste0("Invalid 'mode': evalmod <- '", new_mode,
                  "'', mmdata <- '", mdat_mode, "'"),
           call. = FALSE)
    if (new_mode != "aucroc" && !is.na(mdat_mode) && mdat_mode == "aucroc") {
      stop(paste0(
        "Invalid 'mode': evalmod <- '", new_mode,
        "'', mmdata <- '", mdat_mode, "'"
      ),
      call. = FALSE
      )
    }
  } else if (!is.na(mdat_mode)) {
    new_mode <- mdat_mode

@@ -414,5 +434,4 @@

Loading


  # Check interpolate
  .validate_interpolate(interpolate)

}

@@ -6,8 +6,10 @@

Loading


  # === Validate input arguments ===
  # Create pevals from scores and labels if pevals is missing
  pevals <- .create_src_obj(pevals, "pevals", calc_measures, scores, labels,
                                 ...)
  pevals <- .create_src_obj(
    pevals, "pevals", calc_measures, scores, labels,
    ...
  )

  if (is.null(x_bins) || any(is.na(x_bins))) {
    x_bins <- 1

@@ -16,10 +18,14 @@

Loading

  .validate(pevals)

  # === Create ROC and Precision-Recall curves ===
  roc_curve <- create_roc(pevals, x_bins = x_bins,
                          keep_pevals = keep_pevals, ...)
  prc_curve <- create_prc(pevals, x_bins = x_bins,
                          keep_pevals = keep_pevals, ...)
  roc_curve <- create_roc(pevals,
    x_bins = x_bins,
    keep_pevals = keep_pevals, ...
  )
  prc_curve <- create_prc(pevals,
    x_bins = x_bins,
    keep_pevals = keep_pevals, ...
  )

  curves <- list(roc = roc_curve, prc = prc_curve)


@@ -50,9 +56,11 @@

Loading

                       keep_pevals = FALSE, ...) {

  # === Create a ROC curve ===
  .create_curve("specificity", "sensitivity", create_roc_curve,
                "create_roc_curve", "roc_curve", pevals, scores, labels,
                x_bins, keep_pevals, ...)
  .create_curve(
    "specificity", "sensitivity", create_roc_curve,
    "create_roc_curve", "roc_curve", pevals, scores, labels,
    x_bins, keep_pevals, ...
  )
}

#

@@ -62,9 +70,11 @@

Loading

                       keep_pevals = FALSE, ...) {

  # === Create a Precision-Recall curve ===
  .create_curve("sensitivity", "precision", create_prc_curve,
                "create_prc_curve", "prc_curve", pevals, scores, labels,
                x_bins, keep_pevals, ...)
  .create_curve(
    "sensitivity", "precision", create_prc_curve,
    "create_prc_curve", "prc_curve", pevals, scores, labels,
    x_bins, keep_pevals, ...
  )
}

#

@@ -76,23 +86,29 @@

Loading


  # === Validate input arguments ===
  # Create pevals from scores and labels if pevals is missing
  pevals <- .create_src_obj(pevals, "pevals", calc_measures, scores, labels,
                            ...)
  pevals <- .create_src_obj(
    pevals, "pevals", calc_measures, scores, labels,
    ...
  )
  .validate_x_bins(x_bins, allow_zero = TRUE)
  .validate(pevals)

  # === Create a curve ===
  # Calculate a curve
  pb <- pevals[["basic"]]
  crv <- func(attr(pevals, "src")[["tp"]], attr(pevals, "src")[["fp"]],
              pb[[x_name]], pb[[y_name]], x_bins)
  crv <- func(
    attr(pevals, "src")[["tp"]], attr(pevals, "src")[["fp"]],
    pb[[x_name]], pb[[y_name]], x_bins
  )
  .check_cpp_func_error(crv, func_name)

  # Calculate AUC
  auc <- calc_auc(crv[["curve"]][["x"]], crv[["curve"]][["y"]])
  if (auc[["errmsg"]] == "invalid-x-vals") {
    warning(paste0("Invalid ", x_name,
                   " values detected. AUC can be inaccurate."))
    warning(paste0(
      "Invalid ", x_name,
      " values detected. AUC can be inaccurate."
    ))
  } else {
    .check_cpp_func_error(auc, "calc_auc")
  }

@@ -163,26 +179,32 @@

Loading

.validate_curve <- function(obj, class_name, func_name) {
  # Validate class items and attributes
  item_names <- c("x", "y", "orig_points")
  attr_names <- c("modname", "dsid", "nn", "np", "auc", "args",
                  "cpp_errmsg1", "cpp_errmsg2", "src", "validated")
  arg_names <- c("x_bins", "na_worst", "na.last", "ties_method", "ties.method",
                 "modname", "dsid", "keep_fmdat", "keep_cmats")
  .validate_basic(obj, class_name, func_name, item_names, attr_names,
                  arg_names)
  attr_names <- c(
    "modname", "dsid", "nn", "np", "auc", "args",
    "cpp_errmsg1", "cpp_errmsg2", "src", "validated"
  )
  arg_names <- c(
    "x_bins", "na_worst", "na.last", "ties_method", "ties.method",
    "modname", "dsid", "keep_fmdat", "keep_cmats"
  )
  .validate_basic(
    obj, class_name, func_name, item_names, attr_names,
    arg_names
  )

  # Check values of class items
  if ((length(obj[["x"]]) != length(obj[["y"]]))
      || (length(obj[["x"]]) != length(obj[["orig_points"]]))) {
  if ((length(obj[["x"]]) != length(obj[["y"]])) ||
    (length(obj[["x"]]) != length(obj[["orig_points"]]))) {
    stop("x, y, and orig_points must be all the same lengths", call. = FALSE)
  } else if (!(length(obj[["x"]]) > 2)) {
    stop("The minimum length of x, y, and orig_points must be 3",
         call. = FALSE)
      call. = FALSE
    )
  }

  # Check values of class attributes
  # AUC
  assertthat::assert_that((attr(obj, "auc") >= 0) && (attr(obj, "auc") <= 1))

}

#

@@ -196,12 +218,18 @@

Loading


  # Validate class items and attributes
  item_names <- c("roc", "prc")
  attr_names <- c("modname", "dsid", "nn", "np", "args", "src",
                  "validated")
  arg_names <- c("x_bins", "na_worst", "na.last", "ties_method", "ties.method",
                 "modname", "dsid", "keep_fmdat", "keep_cmats")
  .validate_basic(curves, "curves", "calc_measures", item_names, attr_names,
                  arg_names)
  attr_names <- c(
    "modname", "dsid", "nn", "np", "args", "src",
    "validated"
  )
  arg_names <- c(
    "x_bins", "na_worst", "na.last", "ties_method", "ties.method",
    "modname", "dsid", "keep_fmdat", "keep_cmats"
  )
  .validate_basic(
    curves, "curves", "calc_measures", item_names, attr_names,
    arg_names
  )

  # Check values of class items
  curves[["roc"]] <- .validate(curves[["roc"]])

@@ -2,10 +2,11 @@

Loading

# Check if an internal Rcpp function returns en error
#
.check_cpp_func_error <- function(obj, func_name) {

  if (obj[["errmsg"]] != "") {
    stop(paste0("Internal cpp function (", func_name, "()) failed: ",
                obj[["errmsg"]]), call. = FALSE)
    stop(paste0(
      "Internal cpp function (", func_name, "()) failed: ",
      obj[["errmsg"]]
    ), call. = FALSE)
  }
}


@@ -39,7 +40,7 @@

Loading

# Use scores and labels to create obj
#
.create_src_obj <- function(obj, obj_name, func, scores, labels,
                                         ...) {
                            ...) {
  if (missing(obj)) {
    if (!is.null(scores) && !is.null(labels)) {
      obj <- func(scores = scores, labels = labels, ...)

@@ -58,8 +59,10 @@

Loading

  if (mode == "rocprc" || mode == "prcroc") {
    mnames <- c("ROC", "PRC")
  } else if (mode == "basic") {
    mnames <- c("score", "label", "error", "accuracy", "specificity",
                "sensitivity", "precision", "mcc", "fscore")
    mnames <- c(
      "score", "label", "error", "accuracy", "specificity",
      "sensitivity", "precision", "mcc", "fscore"
    )
  }

  mnames

@@ -93,8 +96,8 @@

Loading

93	96		np <- nps[i]
94	97		nn <- nns[i]
95	98
96		-	if ((!is.na(prev_np) && np != prev_np)
97		-	\|\| (!is.na(prev_nn) && nn != prev_nn)) {
	99	+	if ((!is.na(prev_np) && np != prev_np) \|\|
	100	+	(!is.na(prev_nn) && nn != prev_nn)) {
98	101		is_consistant <- FALSE
99	102		}
100	103

@@ -110,8 +113,8 @@

Loading


  prc_base <- avg_np / (avg_np + avg_nn)

  list(avg_np = avg_np, avg_nn = avg_nn, is_consistant = is_consistant,
       prc_base = prc_base)

  list(
    avg_np = avg_np, avg_nn = avg_nn, is_consistant = is_consistant,
    prc_base = prc_base
  )
}


@@ -53,18 +53,20 @@

Loading

#'  five different performance levels.
#'
#' @section Data visualization:
#' \code{\link{plot}} takes an \code{S3} object generated by \code{\link{evalmod}} as input
#' and plot corresponding curves.
#' \code{\link{plot}} takes an \code{S3} object generated
#' by \code{\link{evalmod}} as input and plot corresponding curves.
#'
#' \code{\link{autoplot}} uses \code{ggplot} to plot curves.
#'
#' @section Result retrieval:
#' \code{\link{as.data.frame}} takes an \code{S3} object generated by \code{\link{evalmod}}
#' as input and and returns a data frame with calculated curve points.
#' \code{\link{as.data.frame}} takes an \code{S3} object generated
#' by \code{\link{evalmod}} as input and and returns a data frame
#' with calculated curve points.
#'
#' \code{\link{auc}} and \code{\link{pauc}} returns a data frame with AUC scores
#' and partial AUC scores, respectively. \code{\link{auc_ci}} returns confidence intervals
#' of AUCs for both ROC and precision-recall curves.
#' and partial AUC scores, respectively. \code{\link{auc_ci}}
#' returns confidence intervals of AUCs for both ROC
#' and precision-recall curves.
#'
#'
#' @docType package

@@ -75,7 +77,8 @@

Loading

#' @importFrom ggplot2 autoplot
#' @importFrom ggplot2 fortify
#' @importFrom grDevices col2rgb rainbow rgb
#' @importFrom graphics abline layout legend lines matplot par plot plot.new polygon
#' @importFrom graphics abline layout legend lines
#' @importFrom matplot par plot plot.new polygon
#' @importFrom methods is
#' @importFrom stats qnorm rbeta rnorm sd qt
#' @importFrom data.table frank

@@ -24,13 +24,22 @@

Loading


  # === Prepare a data frame for ggplot2 ===
  n <- length(model[["ranks"]])
  data.frame(x = rep(seq_len(length(model[["ranks"]])), 4),
             y = c(model[["tp"]], model[["fn"]],
                   model[["fp"]], model[["tn"]]),
             group = factor(c(rep("TPs", n), rep("FNs", n),
                              rep("FPs", n), rep("TNs", n)),
                            levels = c("TPs", "FNs",
                                       "FPs", "TNs")))
  data.frame(
    x = rep(seq_len(length(model[["ranks"]])), 4),
    y = c(
      model[["tp"]], model[["fn"]],
      model[["fp"]], model[["tn"]]
    ),
    group = factor(c(
      rep("TPs", n), rep("FNs", n),
      rep("FPs", n), rep("TNs", n)
    ),
    levels = c(
      "TPs", "FNs",
      "FPs", "TNs"
    )
    )
  )
}

#

@@ -46,108 +55,133 @@

Loading

  # === Prepare a data frame for ggplot2 ===
  pb <- model[["basic"]]
  n <- length(pb[["error"]])
  data.frame(x = rep(1:n, 10),
             y = c(pb[["score"]], pb[["label"]],
                   pb[["error"]], pb[["accuracy"]],
                   pb[["specificity"]], pb[["sensitivity"]],
                   1 - pb[["specificity"]], pb[["precision"]],
                   pb[["mcc"]], pb[["fscore"]]),
             group = factor(c(rep("score", n),
                              rep("label", n),
                              rep("error", n),
                              rep("accuracy", n),
                              rep("specificity", n),
                              rep("sensitivity", n),
                              rep("1 - specificity", n),
                              rep("precision", n),
                              rep("mcc", n),
                              rep("fscore", n)),
                            levels = c("score", "label",
                                       "error", "accuracy",
                                       "specificity",
                                       "sensitivity",
                                       "1 - specificity",
                                       "precision",
                                       "mcc",
                                       "fscore")))
  data.frame(
    x = rep(1:n, 10),
    y = c(
      pb[["score"]], pb[["label"]],
      pb[["error"]], pb[["accuracy"]],
      pb[["specificity"]], pb[["sensitivity"]],
      1 - pb[["specificity"]], pb[["precision"]],
      pb[["mcc"]], pb[["fscore"]]
    ),
    group = factor(c(
      rep("score", n),
      rep("label", n),
      rep("error", n),
      rep("accuracy", n),
      rep("specificity", n),
      rep("sensitivity", n),
      rep("1 - specificity", n),
      rep("precision", n),
      rep("mcc", n),
      rep("fscore", n)
    ),
    levels = c(
      "score", "label",
      "error", "accuracy",
      "specificity",
      "sensitivity",
      "1 - specificity",
      "precision",
      "mcc",
      "fscore"
    )
    )
  )
}

#' @rdname fortify
#' @export
fortify.sscurves <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {
  .dataframe_common(model, raw_curves = TRUE, reduce_points = reduce_points,
                    check_ggplot = TRUE, ...)
  .dataframe_common(model,
    raw_curves = TRUE, reduce_points = reduce_points,
    check_ggplot = TRUE, ...
  )
}

#' @rdname fortify
#' @export
fortify.mscurves <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {
  .dataframe_common(model, raw_curves = TRUE, reduce_points = reduce_points,
                    check_ggplot = TRUE, ...)
  .dataframe_common(model,
    raw_curves = TRUE, reduce_points = reduce_points,
    check_ggplot = TRUE, ...
  )
}

#' @rdname fortify
#' @export
fortify.smcurves <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {

  arglist <- .get_fortify_arglist(attr(model, "args"),
                                  def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(model, raw_curves = arglist[["raw_curves"]],
                    reduce_points = reduce_points, check_ggplot = TRUE, ...)
  .dataframe_common(model,
    raw_curves = arglist[["raw_curves"]],
    reduce_points = reduce_points, check_ggplot = TRUE, ...
  )
}

#' @rdname fortify
#' @export
fortify.mmcurves <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {

  arglist <- .get_fortify_arglist(attr(model, "args"),
                                  def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(model, raw_curves = arglist[["raw_curves"]],
                    reduce_points = reduce_points, check_ggplot = TRUE, ...)
  .dataframe_common(model,
    raw_curves = arglist[["raw_curves"]],
    reduce_points = reduce_points, check_ggplot = TRUE, ...
  )
}

#' @rdname fortify
#' @export
fortify.sspoints <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {
  .dataframe_common(model, mode = "basic", raw_curves = TRUE,
                    check_ggplot = TRUE, reduce_points = FALSE, ...)
  .dataframe_common(model,
    mode = "basic", raw_curves = TRUE,
    check_ggplot = TRUE, reduce_points = FALSE, ...
  )
}

#' @rdname fortify
#' @export
fortify.mspoints <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {
  .dataframe_common(model, mode = "basic", raw_curves = TRUE,
                    check_ggplot = TRUE, reduce_points = FALSE, ...)
  .dataframe_common(model,
    mode = "basic", raw_curves = TRUE,
    check_ggplot = TRUE, reduce_points = FALSE, ...
  )
}

#' @rdname fortify
#' @export
fortify.smpoints <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {

  arglist <- .get_fortify_arglist(attr(model, "args"),
                                  def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(model, mode = "basic", raw_curves = arglist[["raw_curves"]],
                    check_ggplot = TRUE, reduce_points = FALSE, ...)
  .dataframe_common(model,
    mode = "basic", raw_curves = arglist[["raw_curves"]],
    check_ggplot = TRUE, reduce_points = FALSE, ...
  )
}

#' @rdname fortify
#' @export
fortify.mmpoints <- function(model, raw_curves = NULL, reduce_points = FALSE,
                             ...) {

  arglist <- .get_fortify_arglist(attr(model, "args"),
                                  def_raw_curves = raw_curves, ...)
    def_raw_curves = raw_curves, ...
  )

  .dataframe_common(model, mode = "basic", raw_curves = arglist[["raw_curves"]],
                    check_ggplot = TRUE, reduce_points = FALSE, ...)
  .dataframe_common(model,
    mode = "basic", raw_curves = arglist[["raw_curves"]],
    check_ggplot = TRUE, reduce_points = FALSE, ...
  )
}

@@ -23,8 +23,8 @@

Loading

#' @return The \code{auc} function returns a data frame with AUC scores.
#'
#' @seealso \code{\link{evalmod}} for generating \code{S3} objects with
#'   performance evaluation measures. \code{\link{pauc}} for retrieving a dataset
#'   of pAUCs.
#'   performance evaluation measures. \code{\link{pauc}} for retrieving
#'   a dataset of pAUCs.
#'
#' @examples
#'

@@ -49,7 +49,8 @@

Loading

#' ## 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"]])
#'   modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)

@@ -65,8 +66,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "good_er")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -90,8 +92,9 @@

Loading

#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(4, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'                modnames = samps[["modnames"]],
#'                dsids = samps[["dsids"]])
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat, raw_curves = TRUE)

@@ -2,7 +2,6 @@

Loading

# Validate scores and labels
#
.validate_scores_and_labels <- function(obj, obj_name, scores, labels, ...) {

  if (missing(obj) || is.null(obj)) {

    # Check if scores and labels are specified

@@ -11,11 +10,7 @@

Loading

    } else if (!is.null(scores) && is.null(labels)) {
      stop("Invalid labels", call. = FALSE)
    } else if (is.null(scores) && is.null(labels)) {
      if (is.null(obj)) {
        stop("Invalid scores & labels", call. = FALSE)
      } else {
        stop(paste0(obj_name, " must be specified"), call. = FALSE)
      }
      stop("Invalid scores & labels", call. = FALSE)
    }

    # Check scores

@@ -28,7 +23,6 @@

Loading

    if (length(labels) != length(scores)) {
      stop("scores and labels must be the same lengths", call. = FALSE)
    }

  } else if (!is.null(obj)) {
    # Validate the first argument
    obj <- .validate(obj)

@@ -39,29 +33,35 @@

Loading


# Check mode
.validate_mode <- function(mode) {
  assertthat::assert_that(assertthat::is.string(mode),
                          (mode == "rocprc"
                           || mode == "basic"
                           || mode == "aucroc"))
  assertthat::assert_that(
    assertthat::is.string(mode),
    (mode == "rocprc" ||
      mode == "basic" ||
      mode == "aucroc")
  )
}

#
# Validate scores
#
.validate_scores <- function(scores) {
  assertthat::assert_that(is.atomic(scores),
                          is.vector(scores),
                          is.numeric(scores),
                          length(scores) > 0L)
  assertthat::assert_that(
    is.atomic(scores),
    is.vector(scores),
    is.numeric(scores),
    length(scores) > 0L
  )
}

#
# Validate labels
#
.validate_labels <- function(labels) {
  assertthat::assert_that(is.atomic(labels),
                          (is.vector(labels) || is.factor(labels)),
                          length(labels) > 0L)
  assertthat::assert_that(
    is.atomic(labels),
    (is.vector(labels) || is.factor(labels)),
    length(labels) > 0L
  )
}

#

@@ -78,10 +78,11 @@

Loading

#
.validate_modnames <- function(modnames, datalen) {
  if (!is.null(modnames)) {

    assertthat::assert_that(is.vector(modnames),
                            is.character(modnames),
                            length(modnames) == datalen)
    assertthat::assert_that(
      is.vector(modnames),
      is.character(modnames),
      length(modnames) == datalen
    )

    for (i in seq_len(length(modnames))) {
      .validate_modname(modnames[i])

@@ -103,10 +104,11 @@

Loading

#
.validate_dsids <- function(dsids, datalen) {
  if (!is.null(dsids)) {

    assertthat::assert_that(is.vector(dsids),
                            is.numeric(dsids),
                            length(dsids) == datalen)
    assertthat::assert_that(
      is.vector(dsids),
      is.numeric(dsids),
      length(dsids) == datalen
    )

    for (i in seq_len(length(dsids))) {
      .validate_dsid(dsids[i])

@@ -119,9 +121,11 @@

Loading

#
.validate_posclass <- function(posclass) {
  if (!is.null(posclass)) {
    assertthat::assert_that(is.atomic(posclass),
                            (is.vector(posclass) || is.factor(posclass)),
                            length(posclass) == 1L)
    assertthat::assert_that(
      is.atomic(posclass),
      (is.vector(posclass) || is.factor(posclass)),
      length(posclass) == 1L
    )
  }
}


@@ -131,8 +135,10 @@

Loading

#
.validate_na_worst <- function(na_worst) {
  if (!is.null(na_worst)) {
    assertthat::assert_that(assertthat::is.flag(na_worst),
                            assertthat::noNA(na_worst))
    assertthat::assert_that(
      assertthat::is.flag(na_worst),
      assertthat::noNA(na_worst)
    )
  }
}


@@ -143,10 +149,12 @@

Loading

  if (!is.null(ties_method)) {
    assertthat::assert_that(assertthat::is.string(ties_method))

    choices = c("equiv", "random", "first")
    choices <- c("equiv", "random", "first")
    if (!(ties_method %in% choices)) {
      stop(gettextf("ties_method must be one of %s",
                    paste(dQuote(choices), collapse = ", ")), call. = FALSE)
      stop(gettextf(
        "ties_method must be one of %s",
        paste(dQuote(choices), collapse = ", ")
      ), call. = FALSE)
    }
  }
}

@@ -156,31 +164,11 @@

Loading

#
.validate_expd_first <- function(expd_first) {
  if (!is.null(expd_first)) {
    assertthat::assert_that(assertthat::is.string(expd_first),
                            (expd_first == "modnames"
                             || expd_first == "dsids"))
  }
}

#
# Validate model type
#
.validate_model_type <- function(model_type) {
  if (!is.null(model_type)) {
    assertthat::assert_that(assertthat::is.string(model_type),
                            (model_type == "single"
                             || model_type == "multiple"))
  }
}

#
# Validate data type
#
.validate_data_type <- function(data_type) {
  if (!is.null(data_type)) {
    assertthat::assert_that(assertthat::is.string(data_type),
                            (data_type == "single"
                             || data_type == "multiple"))
    assertthat::assert_that(
      assertthat::is.string(expd_first),
      (expd_first == "modnames" ||
        expd_first == "dsids")
    )
  }
}


@@ -189,8 +177,10 @@

Loading

#
.validate_calc_avg <- function(calc_avg) {
  if (!is.null(calc_avg)) {
    assertthat::assert_that(assertthat::is.flag(calc_avg),
                            assertthat::noNA(calc_avg))
    assertthat::assert_that(
      assertthat::is.flag(calc_avg),
      assertthat::noNA(calc_avg)
    )
  }
}


@@ -199,8 +189,10 @@

Loading

#
.validate_cb_alpha <- function(cb_alpha, calc_avg = NULL) {
  if (!is.null(cb_alpha)) {
    assertthat::assert_that(assertthat::is.number(cb_alpha),
                            cb_alpha >= 0 && cb_alpha <= 1)
    assertthat::assert_that(
      assertthat::is.number(cb_alpha),
      cb_alpha >= 0 && cb_alpha <= 1
    )
    if (!is.null(calc_avg)) {
      if (!calc_avg && cb_alpha) {
        warning("cb_alpha is ignored when calc_avg = FALSE", call. = FALSE)

@@ -214,8 +206,10 @@

Loading

#
.validate_raw_curves <- function(raw_curves, calc_avg = NULL) {
  if (!is.null(raw_curves)) {
    assertthat::assert_that(assertthat::is.flag(raw_curves),
                            assertthat::noNA(raw_curves))
    assertthat::assert_that(
      assertthat::is.flag(raw_curves),
      assertthat::noNA(raw_curves)
    )
    if (!is.null(calc_avg)) {
      if (!calc_avg && raw_curves) {
        warning("raw_curves is ignored when calc_avg = FALSE", call. = FALSE)

@@ -227,7 +221,7 @@

Loading

#
# Validate x_bins
#
.validate_x_bins <- function(x_bins, allow_zero=FALSE) {
.validate_x_bins <- function(x_bins, allow_zero = FALSE) {
  if (allow_zero) {
    min_x_bin <- 0
  } else {

@@ -235,9 +229,11 @@

Loading

  }

  if (!is.null(x_bins) && all(!is.na(x_bins))) {
    assertthat::assert_that(assertthat::is.number(x_bins),
                            x_bins %% 1 == 0,
                            x_bins >= min_x_bin)
    assertthat::assert_that(
      assertthat::is.number(x_bins),
      x_bins %% 1 == 0,
      x_bins >= min_x_bin
    )
  }
}


@@ -253,46 +249,50 @@

Loading

# Check score column names
.validate_score_cols <- function(score_cols, nfold_df) {
  assertthat::assert_that(is.vector(score_cols))
  assertthat::assert_that(is.numeric(score_cols)
                          || is.character(score_cols))
  assertthat::assert_that(is.numeric(score_cols) ||
    is.character(score_cols))

  if (is.numeric(score_cols)) {
    assertthat::assert_that(all(score_cols <= ncol(nfold_df)),
                            msg = "Invalid score_cols")
      msg = "Invalid score_cols"
    )
  } else if (is.character(score_cols)) {
    assertthat::assert_that(all(score_cols %in% colnames(nfold_df)),
                            msg = "Invalid score_cols")
      msg = "Invalid score_cols"
    )
  }

}

# Check label column name
.validate_lab_col <- function(lab_col, nfold_df) {
  assertthat::assert_that(assertthat::see_if(assertthat::is.number(lab_col))
                          || assertthat::see_if(assertthat::is.string(lab_col)))
  assertthat::assert_that(assertthat::see_if(assertthat::is.number(lab_col)) ||
    assertthat::see_if(assertthat::is.string(lab_col)))

  if (assertthat::see_if(assertthat::is.number(lab_col))) {
    assertthat::assert_that(lab_col <= ncol(nfold_df),
                            msg = "Invalid lab_col")
      msg = "Invalid lab_col"
    )
  } else if (assertthat::see_if(assertthat::is.string(lab_col))) {
    assertthat::assert_that(lab_col %in% colnames(nfold_df),
                            msg = "Invalid lab_col")
      msg = "Invalid lab_col"
    )
  }
}

# Check fold column name
.validate_fold_col <- function(fold_col, nfold_df) {
  assertthat::assert_that(assertthat::see_if(assertthat::is.number(fold_col))
                          || assertthat::see_if(assertthat::is.string(fold_col)))
  assertthat::assert_that(assertthat::see_if(assertthat::is.number(fold_col)) ||
    assertthat::see_if(assertthat::is.string(fold_col)))

  if (assertthat::see_if(assertthat::is.number(fold_col))) {
    assertthat::assert_that(fold_col <= ncol(nfold_df),
                            msg = "Invalid fold_col")
      msg = "Invalid fold_col"
    )
  } else if (assertthat::see_if(assertthat::is.string(fold_col))) {
    assertthat::assert_that(fold_col %in% colnames(nfold_df),
                            msg = "Invalid fold_col")
      msg = "Invalid fold_col"
    )
  }

}

# Check mode

@@ -312,19 +312,23 @@

Loading

  basic_eval <- TRUE

  cfunc <- function(curvetype, all_types, all_len) {
    if (!is.atomic(curvetype) || !is.character(curvetype)
        || length(curvetype) > all_len
        || length(setdiff(curvetype, all_types)) != 0) {
    if (!is.atomic(curvetype) || !is.character(curvetype) ||
      length(curvetype) > all_len ||
      length(setdiff(curvetype, all_types)) != 0) {
      FALSE
    } else {
      TRUE
    }
  }
  roc_prc <- cfunc(curvetype, c("ROC", "PRC"), 2)
  basic_eval <- cfunc(curvetype, c("score", "label", "error", "accuracy",
                                   "specificity", "sensitivity", "precision",
                                   "mcc", "fscore"),
                      9)
  basic_eval <- cfunc(
    curvetype, c(
      "score", "label", "error", "accuracy",
      "specificity", "sensitivity", "precision",
      "mcc", "fscore"
    ),
    9
  )

  if (!roc_prc && !basic_eval) {
    stop("Invalid curvetype", call. = FALSE)

@@ -332,12 +336,11 @@

Loading


  if (!is.null(obj)) {
    obj_mode <- attr(obj, "args")[["mode"]]
    if (((obj_mode == "rocprc") && !roc_prc)
        || ((obj_mode == "basic") && !basic_eval)) {
    if (((obj_mode == "rocprc") && !roc_prc) ||
      ((obj_mode == "basic") && !basic_eval)) {
      stop("Invalid curvetype", call. = FALSE)
    }
  }

}

#

@@ -345,27 +348,33 @@

Loading

#
.check_type <- function(type) {
  if (!is.null(type)) {
    assertthat::assert_that(assertthat::is.string(type),
                            (type == "l" || type == "p" || type == "b"))
    assertthat::assert_that(
      assertthat::is.string(type),
      (type == "l" || type == "p" || type == "b")
    )
  }

}

#
# Check show_cb
#
.check_show_cb <- function(show_cb, obj = NULL) {
  assertthat::assert_that(is.atomic(show_cb),
                          assertthat::is.flag(show_cb),
                          assertthat::noNA(show_cb))
  assertthat::assert_that(
    is.atomic(show_cb),
    assertthat::is.flag(show_cb),
    assertthat::noNA(show_cb)
  )

  if (!is.null(obj) && (attr(obj, "dataset_type") == "multiple")) {
    obj_calc_avg <- attr(obj, "args")[["calc_avg"]]
    if (show_cb && !obj_calc_avg ) {
      stop(paste0("calc_avg of the evalmod function",
                  " must be set as TRUE before using show_cb",
                  " of this function"),
           call. = FALSE)
    if (show_cb && !obj_calc_avg) {
      stop(paste0(
        "calc_avg of the evalmod function",
        " must be set as TRUE before using show_cb",
        " of this function"
      ),
      call. = FALSE
      )
    }
  }
}

@@ -374,18 +383,23 @@

Loading

# Check raw_curves
#
.check_raw_curves <- function(raw_curves, obj = NULL) {
  assertthat::assert_that(is.atomic(raw_curves),
                          assertthat::is.flag(raw_curves),
                          assertthat::noNA(raw_curves))
  assertthat::assert_that(
    is.atomic(raw_curves),
    assertthat::is.flag(raw_curves),
    assertthat::noNA(raw_curves)
  )

  if (!is.null(obj) && (attr(obj, "dataset_type") == "multiple")) {
    obj_calc_avg <- attr(obj, "args")[["calc_avg"]]
    obj_raw_curves <- attr(obj, "args")[["raw_curves"]]
    if (raw_curves && (!obj_calc_avg || !obj_raw_curves)) {
      stop(paste0("Both calc_avg and raw_curves of the evalmod function",
                  " must be set as TRUE before using raw_curves",
                  " of this function"),
           call. = FALSE)
      stop(paste0(
        "Both calc_avg and raw_curves of the evalmod function",
        " must be set as TRUE before using raw_curves",
        " of this function"
      ),
      call. = FALSE
      )
    }
  }
}

@@ -394,51 +408,63 @@

Loading

# Check show_legend
#
.check_show_legend <- function(show_legend) {
  assertthat::assert_that(is.atomic(show_legend),
                          assertthat::is.flag(show_legend),
                          assertthat::noNA(show_legend))
  assertthat::assert_that(
    is.atomic(show_legend),
    assertthat::is.flag(show_legend),
    assertthat::noNA(show_legend)
  )


443	450		# Set layout
444	451		#
445	452		.set_layout <- function(ctype_len, show_legend) {
446		-
447	453		if (ctype_len == 1) {
448	454		nrow1 <- 2
449	455		ncol1 <- 1
450	456		mat1 <- c(1, 2)
451	457		mat2 <- 1
452	458		heights <- c(0.85, 0.15)
453		-	} else if (ctype_len == 2) {
	459	+	} else if (ctype_len == 2) {
454	460		nrow1 <- 2
455	461		ncol1 <- 2
456	462		mat1 <- c(1, 2, 3, 3)

512	518		xlim <- .get_xlim(obj, curvetype)
513	519		ylim <- .get_ylim(obj, curvetype)
514	520		mats <- .make_matplot_mats(obj[[curvetype]])
515		-	graphics::matplot(mats[["x"]], mats[["y"]], type = type, lty = 1, pch = 19,
516		-	col = line_col, main = main, xlab = xlab, ylab = ylab,
517		-	ylim = ylim, xlim = xlim)
	521	+	graphics::matplot(mats[["x"]], mats[["y"]],
	522	+	type = type, lty = 1, pch = 19,
	523	+	col = line_col, main = main, xlab = xlab, ylab = ylab,
	524	+	ylim = ylim, xlim = xlim
	525	+	)
518	526		}
519	527
520	528		#

558	566
559	567		xlim <- .get_xlim(obj, curvetype)
560	568		ylim <- .get_ylim(obj, curvetype)
561		-	graphics::plot(1, type = "n", main = main, xlab = xlab, ylab = ylab,
562		-	ylim = ylim, xlim = xlim)
	569	+	graphics::plot(1,
	570	+	type = "n", main = main, xlab = xlab, ylab = ylab,
	571	+	ylim = ylim, xlim = xlim
	572	+	)
563	573
564	574		if (length(avgcurves) == 1) {
565	575		lcols <- "blue"

594	604		}
595	605
596	606		g <- grDevices::col2rgb(pcol)
597		-	graphics::polygon(c(x, rev(x)), c(ymin, rev(ymax)), border = FALSE,
598		-	col = grDevices::rgb(g[1], g[2], g[3], 180,
599		-	maxColorValue = 255))
	607	+	graphics::polygon(c(x, rev(x)), c(ymin, rev(ymax)),
	608	+	border = FALSE,
	609	+	col = grDevices::rgb(g[1], g[2], g[3], 180,
	610	+	maxColorValue = 255
	611	+	)
	612	+	)
600	613		}
601	614
602	615		b <- grDevices::col2rgb(lcol)
603		-	graphics::lines(x, y, type = type, lty = 1, pch = 19,
604		-	col = grDevices::rgb(b[1], b[2], b[3], 200,
605		-	maxColorValue = 255))
	616	+	graphics::lines(x, y,
	617	+	type = type, lty = 1, pch = 19,
	618	+	col = grDevices::rgb(b[1], b[2], b[3], 200,
	619	+	maxColorValue = 255
	620	+	)
	621	+	)
606	622		}
607	623
608	624		#

611	627		.plot_single <- function(x, curvetype, type = type, show_cb = FALSE,
612	628		raw_curves = FALSE, add_np_nn = TRUE,
613	629		show_legend = TRUE) {
614		-
615	630		tlist <- .get_titiles(curvetype)
616	631		main <- tlist[["main"]]
617	632

66	66		#' @export
67	67		join_scores <- function(..., byrow = FALSE, chklen = TRUE) {
68	68		# Call join datasets
69		-	.join_datasets(..., efunc_vtype = .validate_scores, efunc_nrow = NULL,
70		-	byrow = byrow, chklen = chklen)
	69	+	.join_datasets(...,
	70	+	efunc_vtype = .validate_scores, efunc_nrow = NULL,
	71	+	byrow = byrow, chklen = chklen
	72	+	)
71	73		}
72	74
73	75		#' Join observed labels of multiple test datasets into a list

137	139		#' @export
138	140		join_labels <- function(..., byrow = FALSE, chklen = TRUE) {
139	141		# Call join datasets
140		-	.join_datasets(..., efunc_vtype = .validate_labels, efunc_nrow = NULL,
141		-	byrow = byrow, chklen = chklen)
	142	+	.join_datasets(...,
	143	+	efunc_vtype = .validate_labels, efunc_nrow = NULL,
	144	+	byrow = byrow, chklen = chklen
	145	+	)
142	146		}
143	147
144	148		#

148	152		byrow = FALSE, chklen = TRUE) {
149	153
150	154		# Validate arguments
151		-	.validate_join_datasets_args(..., efunc_vtype = efunc_vtype,
152		-	efunc_nrow = efunc_nrow, byrow = byrow,
153		-	chklen = chklen)
	155	+	.validate_join_datasets_args(...,
	156	+	efunc_vtype = efunc_vtype,
	157	+	efunc_nrow = efunc_nrow, byrow = byrow,
	158	+	chklen = chklen
	159	+	)
154	160
155	161		# Set a default error function for checking values
156	162		if (is.null(efunc_vtype)) {

243	249		}
244	250
245	251		# Check efunc_vtype
246		-	if (!is.null(efunc_vtype)
247		-	&& (!methods::is(efunc_vtype, "function")
248		-	\|\| length(as.list(formals(efunc_vtype))) != 1)) {
	252	+	if (!is.null(efunc_vtype) &&
	253	+	(!methods::is(efunc_vtype, "function") \|\|
	254	+	length(as.list(formals(efunc_vtype))) != 1)) {
249	255		stop("efunc_vtype must be a function with 1 argument", call. = FALSE)
250	256		}
251	257
252	258		# Check efunc_nrow
253		-	if (!is.null(efunc_nrow)
254		-	&& (!methods::is(efunc_nrow, "function")
255		-	\|\| length(as.list(formals(efunc_nrow))) != 2)) {
	259	+	if (!is.null(efunc_nrow) &&
	260	+	(!methods::is(efunc_nrow, "function") \|\|
	261	+	length(as.list(formals(efunc_nrow))) != 2)) {
256	262		stop("efunc_nrow must be a function with 2 arguments", call. = FALSE)
257	263		}
258	264
259	265		# Check byrow
260		-	assertthat::assert_that(assertthat::is.flag(byrow),
261		-	assertthat::noNA(byrow))
	266	+	assertthat::assert_that(
	267	+	assertthat::is.flag(byrow),
	268	+	assertthat::noNA(byrow)
	269	+	)
262	270
263	271		# Check chklen
264		-	assertthat::assert_that(assertthat::is.flag(chklen),
265		-	assertthat::noNA(chklen))
266		-
	272	+	assertthat::assert_that(
	273	+	assertthat::is.flag(chklen),
	274	+	assertthat::noNA(chklen)
	275	+	)
267	276		}

5	5		curve_df <- .prepare_autoplot(object)
6	6
7	7		# === Create a ggplot object ===
8		-	p <- ggplot2::ggplot(curve_df,
9		-	ggplot2::aes_string(x = 'x', y = 'y', color = 'x'))
	8	+	p <- ggplot2::ggplot(
	9	+	curve_df,
	10	+	ggplot2::aes_string(x = "x", y = "y", color = "x")
	11	+	)
10	12		p <- p + ggplot2::geom_jitter()
11	13		p <- p + ggplot2::coord_flip()
12	14		p <- .geom_basic(p, "Score distributions by rank", NULL, "rank",
13		-	show_legend = FALSE)
	15	+	show_legend = FALSE
	16	+	)
14	17		}
15	18
16	19		#

85	95		#' @rdname autoplot
86	96		#' @export
87	97		autoplot.smcurves <- function(object, curvetype = c("ROC", "PRC"), ...) {
88		-
89	98		arglist <- .get_autoplot_arglist(attr(object, "args"),
90		-	def_curvetype = curvetype, def_type = "l",
91		-	def_show_cb = TRUE, def_raw_curves = NULL,
92		-	def_add_np_nn = TRUE,
93		-	def_show_legend = FALSE,
94		-	def_ret_grob = FALSE,
95		-	def_reduce_points = TRUE,
96		-	def_multiplot_lib = "patchwork", ...)
	99	+	def_curvetype = curvetype, def_type = "l",
	100	+	def_show_cb = TRUE, def_raw_curves = NULL,
	101	+	def_add_np_nn = TRUE,
	102	+	def_show_legend = FALSE,
	103	+	def_ret_grob = FALSE,
	104	+	def_reduce_points = TRUE,
	105	+	def_multiplot_lib = "patchwork", ...
	106	+	)
97	107
98	108		arglist[["curvetype"]] <- .pmatch_curvetype_rocprc(arglist[["curvetype"]])
99	109

103	113		#' @rdname autoplot
104	114		#' @export
105	115		autoplot.mmcurves <- function(object, curvetype = c("ROC", "PRC"), ...) {
106		-
107	116		arglist <- .get_autoplot_arglist(attr(object, "args"),
108		-	def_curvetype = curvetype, def_type = "l",
109		-	def_show_cb = FALSE, def_raw_curves = NULL,
110		-	def_add_np_nn = TRUE,
111		-	def_show_legend = TRUE,
112		-	def_ret_grob = FALSE,
113		-	def_reduce_points = TRUE,
114		-	def_multiplot_lib = "patchwork", ...)
	117	+	def_curvetype = curvetype, def_type = "l",
	118	+	def_show_cb = FALSE, def_raw_curves = NULL,
	119	+	def_add_np_nn = TRUE,
	120	+	def_show_legend = TRUE,
	121	+	def_ret_grob = FALSE,
	122	+	def_reduce_points = TRUE,
	123	+	def_multiplot_lib = "patchwork", ...
	124	+	)
115	125
116	126		arglist[["curvetype"]] <- .pmatch_curvetype_rocprc(arglist[["curvetype"]])
117	127

122	132		#' @export
123	133		autoplot.sspoints <- function(object, curvetype = .get_metric_names("basic"),
124	134		...) {
125		-
126	135		arglist <- .get_autoplot_arglist(attr(object, "args"),
127		-	def_curvetype = curvetype, def_type = "p",
128		-	def_show_cb = FALSE, def_raw_curves = TRUE,
129		-	def_add_np_nn = TRUE,
130		-	def_show_legend = FALSE,
131		-	def_ret_grob = FALSE,
132		-	def_reduce_points = FALSE,
133		-	def_multiplot_lib = "patchwork", ...)
	136	+	def_curvetype = curvetype, def_type = "p",
	137	+	def_show_cb = FALSE, def_raw_curves = TRUE,
	138	+	def_add_np_nn = TRUE,
	139	+	def_show_legend = FALSE,
	140	+	def_ret_grob = FALSE,
	141	+	def_reduce_points = FALSE,
	142	+	def_multiplot_lib = "patchwork", ...
	143	+	)
134	144		arglist[["raw_curves"]] <- TRUE
135	145		arglist[["show_cb"]] <- FALSE
136	146		arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])
137	147
138	148		.autoplot_multi(object, arglist)
139		-
140	149		}
141	150
142	151		#' @rdname autoplot
143	152		#' @export
144	153		autoplot.mspoints <- function(object, curvetype = .get_metric_names("basic"),
145	154		...) {
146		-
147	155		arglist <- .get_autoplot_arglist(attr(object, "args"),
148		-	def_curvetype = curvetype, def_type = "p",
149		-	def_show_cb = FALSE, def_raw_curves = TRUE,
150		-	def_add_np_nn = TRUE,
151		-	def_show_legend = TRUE,
152		-	def_ret_grob = FALSE,
153		-	def_reduce_points = FALSE,
154		-	def_multiplot_lib = "patchwork", ...)
	156	+	def_curvetype = curvetype, def_type = "p",
	157	+	def_show_cb = FALSE, def_raw_curves = TRUE,
	158	+	def_add_np_nn = TRUE,
	159	+	def_show_legend = TRUE,
	160	+	def_ret_grob = FALSE,
	161	+	def_reduce_points = FALSE,
	162	+	def_multiplot_lib = "patchwork", ...
	163	+	)
155	164		arglist[["raw_curves"]] <- TRUE
156	165		arglist[["show_cb"]] <- FALSE
157	166		arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])

163	172		#' @export
164	173		autoplot.smpoints <- function(object, curvetype = .get_metric_names("basic"),
165	174		...) {
166		-
167	175		arglist <- .get_autoplot_arglist(attr(object, "args"),
168		-	def_curvetype = curvetype, def_type = "p",
169		-	def_show_cb = TRUE, def_raw_curves = NULL,
170		-	def_add_np_nn = TRUE,
171		-	def_show_legend = FALSE,
172		-	def_ret_grob = FALSE,
173		-	def_reduce_points = FALSE,
174		-	def_multiplot_lib = "patchwork", ...)
	176	+	def_curvetype = curvetype, def_type = "p",
	177	+	def_show_cb = TRUE, def_raw_curves = NULL,
	178	+	def_add_np_nn = TRUE,
	179	+	def_show_legend = FALSE,
	180	+	def_ret_grob = FALSE,
	181	+	def_reduce_points = FALSE,
	182	+	def_multiplot_lib = "patchwork", ...
	183	+	)
175	184
176	185		arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])
177	186

182	191		#' @export
183	192		autoplot.mmpoints <- function(object, curvetype = .get_metric_names("basic"),
184	193		...) {
185		-
186	194		arglist <- .get_autoplot_arglist(attr(object, "args"),
187		-	def_curvetype = curvetype, def_type = "p",
188		-	def_show_cb = FALSE, def_raw_curves = NULL,
189		-	def_add_np_nn = TRUE,
190		-	def_show_legend = TRUE,
191		-	def_ret_grob = FALSE,
192		-	def_reduce_points = FALSE,
193		-	def_multiplot_lib = "patchwork", ...)
	195	+	def_curvetype = curvetype, def_type = "p",
	196	+	def_show_cb = FALSE, def_raw_curves = NULL,
	197	+	def_add_np_nn = TRUE,
	198	+	def_show_legend = TRUE,
	199	+	def_ret_grob = FALSE,
	200	+	def_reduce_points = FALSE,
	201	+	def_multiplot_lib = "patchwork", ...
	202	+	)
194	203
195	204		arglist[["curvetype"]] <- .pmatch_curvetype_basic(arglist[["curvetype"]])
196	205

279	284		# Check partial match - Basic evaluation measures
280	285		#
281	286		.pmatch_curvetype_basic <- function(vals) {
282		-
283	287		pfunc <- function(val) {
284	288		if (assertthat::is.string(val)) {
285	289		sval <- tolower(val)

305	309		return("precision")
306	310		}
307	311
308		-	if (!is.na(pmatch(sval, "matthews correlation coefficient"))
309		-	\|\| sval == "mcc") {
	312	+	if (!is.na(pmatch(sval, "matthews correlation coefficient")) \|\|
	313	+	sval == "mcc") {
310	314		return("mcc")
311	315		}
312	316

355	359		}
356	360		if (!evalmod_args[["calc_avg"]] && arglist[["show_cb"]]) {
357	361		stop("Invalid show_cb. Inconsistent with calc_avg of evalmod.",
358		-	call. = FALSE)
	362	+	call. = FALSE
	363	+	)
359	364		}
360	365
361	366		if (is.null(arglist[["raw_curves"]])) {

369	374		}
370	375		if (!evalmod_args[["raw_curves"]] && arglist[["raw_curves"]]) {
371	376		stop("Invalid raw_curves. Inconsistent with the value of evalmod.",
372		-	call. = FALSE)
	377	+	call. = FALSE
	378	+	)
373	379		}
374	380
375	381		if (is.null(arglist[["add_np_nn"]])) {

43	43		#' ## Create sample datasets with 100 positives and 100 negatives
44	44		#' samps <- create_sim_samples(4, 100, 100, "good_er")
45	45		#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
46		-	#' modnames = samps[["modnames"]],
47		-	#' dsids = samps[["dsids"]])
	46	+	#' modnames = samps[["modnames"]],
	47	+	#' dsids = samps[["dsids"]]
	48	+	#' )
48	49		#'
49	50		#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
50	51		#' smcurves <- evalmod(mdat)

75	77		#' mm_auc_ci
76	78		#'
77	79		#' @export
78		-	auc_ci <- function(curves, alpha=NULL, dtype=NULL) UseMethod("auc_ci", curves)
	80	+	auc_ci <- function(curves, alpha = NULL, dtype = NULL) {
	81	+	UseMethod("auc_ci", curves)
	82	+	}
79	83
80	84		#' @export
81		-	auc_ci.default <- function(curves, alpha=NULL, dtype=NULL) {
	85	+	auc_ci.default <- function(curves, alpha = NULL, dtype = NULL) {
82	86		stop("An object of unknown class is specified")
83	87		}
84	88

87	91		#
88	92		#' @rdname auc_ci
89	93		#' @export
90		-	auc_ci.aucs <- function(curves, alpha=0.05, dtype="normal") {
	94	+	auc_ci.aucs <- function(curves, alpha = 0.05, dtype = "normal") {
91	95		# Validation
92	96		.validate(curves)
93	97		assertthat::assert_that(attr(curves, "dataset_type") == "multiple",
94		-	msg = "'curves' must contain multiple datasets.")
95		-	assertthat::assert_that(assertthat::is.number(alpha),
96		-	alpha >= 0 && alpha <= 1)
	98	+	msg = "'curves' must contain multiple datasets."
	99	+	)
	100	+	assertthat::assert_that(
	101	+	assertthat::is.number(alpha),
	102	+	alpha >= 0 && alpha <= 1
	103	+	)
97	104		assertthat::assert_that(assertthat::is.string(dtype))
98	105
99	106		# Check type of distribution

102	109		if (!is.na(dype_match)) {
103	110		dtype <- dtype_tab[dype_match]
104	111		}
105		-	err_msg = paste0("'dtype' must be one of ", paste(dtype_tab, collapse = ", "))
	112	+	err_msg <- paste0(
	113	+	"'dtype' must be one of ",
	114	+	paste(dtype_tab, collapse = ", ")
	115	+	)
106	116		assertthat::assert_that(dtype %in% dtype_tab, msg = err_msg)
107	117
108	118		# Get AUC scores

122	132		aucs_mean <- mean(aucs_subset$aucs)
123	133		aucs_n <- length(aucs_subset$aucs)
124	134		if (aucs_n < 2) {
125		-	ci_df <- rbind(ci_df,
126		-	data.frame(modnames = modname,
127		-	curvetypes = curvetype,
128		-	mean = aucs_mean,
129		-	error = 0,
130		-	lower_bound = aucs_mean,
131		-	upper_bound = aucs_mean,
132		-	n = aucs_n))
	135	+	ci_df <- rbind(
	136	+	ci_df,
	137	+	data.frame(
	138	+	modnames = modname,
	139	+	curvetypes = curvetype,
	140	+	mean = aucs_mean,
	141	+	error = 0,
	142	+	lower_bound = aucs_mean,
	143	+	upper_bound = aucs_mean,
	144	+	n = aucs_n
	145	+	)
	146	+	)
133	147		next
134	148		}
135	149		aucs_sd <- sd(aucs_subset$aucs)

145	159		acus_lower <- max(aucs_mean - aucs_error, 0.0)
146	160		acus_upper <- min(aucs_mean + aucs_error, 1.0)
147	161
148		-	ci_df <- rbind(ci_df,
149		-	data.frame(modnames = modname,
150		-	curvetypes = curvetype,
151		-	mean = aucs_mean,
152		-	error = aucs_error,
153		-	lower_bound = acus_lower,
154		-	upper_bound = acus_upper,
155		-	n = aucs_n))
	162	+	ci_df <- rbind(
	163	+	ci_df,
	164	+	data.frame(
	165	+	modnames = modname,
	166	+	curvetypes = curvetype,
	167	+	mean = aucs_mean,
	168	+	error = aucs_error,
	169	+	lower_bound = acus_lower,
	170	+	upper_bound = acus_upper,
	171	+	n = aucs_n
	172	+	)
	173	+	)
156	174		}
157		-
158	175		}
159	176
160	177		ci_df

125	124		#' plot(sscurves, curvetype = "PRC")
126	125		#'
127	126		#' ## Generate an sspoints object that contains basic evaluation measures
128		-	#' sspoints <- evalmod(mode = "basic", scores = P10N10$scores,
129		-	#' labels = P10N10$labels)
	127	+	#' sspoints <- evalmod(
	128	+	#' mode = "basic", scores = P10N10$scores,
	129	+	#' labels = P10N10$labels
	130	+	#' )
130	131		#'
131	132		#' ## Plot normalized ranks vs. basic evaluation measures
132	133		#' plot(sspoints)

142	143		#' ## Create sample datasets with 100 positives and 100 negatives
143	144		#' samps <- create_sim_samples(1, 100, 100, "all")
144	145		#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
145		-	#' modnames = samps[["modnames"]])
	146	+	#' modnames = samps[["modnames"]]
	147	+	#' )
146	148		#'
147	149		#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
148	150		#' mscurves <- evalmod(mdat)

170	172		#' ## Create sample datasets with 100 positives and 100 negatives
171	173		#' samps <- create_sim_samples(10, 100, 100, "good_er")
172	174		#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
173		-	#' modnames = samps[["modnames"]],
174		-	#' dsids = samps[["dsids"]])
	175	+	#' modnames = samps[["modnames"]],
	176	+	#' dsids = samps[["dsids"]]
	177	+	#' )
175	178		#'
176	179		#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
177	180		#' smcurves <- evalmod(mdat, raw_curves = TRUE)

229	233		#' data(M2N50F5)
230	234		#'
231	235		#' ## Speficy nessesary columns to create mdat
232		-	#' cvdat <- mmdata(nfold_df = M2N50F5, score_cols = c(1, 2),
233		-	#' lab_col = 3, fold_col = 4,
234		-	#' modnames = c("m1", "m2"), dsids = 1:5)
	236	+	#' cvdat <- mmdata(
	237	+	#' nfold_df = M2N50F5, score_cols = c(1, 2),
	238	+	#' lab_col = 3, fold_col = 4,
	239	+	#' modnames = c("m1", "m2"), dsids = 1:5
	240	+	#' )
235	241		#'
236	242		#' ## Generate an mmcurve object that contains ROC and Precision-Recall curves
237	243		#' cvcurves <- evalmod(cvdat)

Updating our web app

247	253		#'
248	254		#' ## Normalized ranks vs. average basic evaluation measures
249	255		#' plot(cvpoints)
250		-	#'
251		-	#'}
	256	+	#' }
252	257		#' @name plot
253	258		NULL
254	259

296	300		return("specificity")
297	301		}
298	302
299		-	if (!is.na(pmatch(sval, "sensitivity"))
300		-	\|\| !is.na(pmatch(sval, "recall")) \|\| sval == "tpr" \|\| sval == "sn") {
	303	+	if (!is.na(pmatch(sval, "sensitivity")) \|\|
	304	+	!is.na(pmatch(sval, "recall")) \|\| sval == "tpr" \|\| sval == "sn") {
301	305		return("sensitivity")
302	306		}
303	307

396	401
397	402		show_cb <- arglist[["show_cb"]]
398	403		if (!attr(x, "args")$calc_avg) {
399		-	show_cb = FALSE
	404	+	show_cb <- FALSE
400	405		}
401	406
402	407		raw_curves <- arglist[["raw_curves"]]
403	408		if (show_cb) {
404		-	raw_curves = FALSE
	409	+	raw_curves <- FALSE
405	410		}
406	411
407	412		# === Validate input arguments ===

422	427		}
423	428
424	429		for (ct in curvetype) {
425		-	.plot_single(x, ct, type = type, show_cb = show_cb,
426		-	raw_curves = raw_curves, add_np_nn = add_np_nn,
427		-	show_legend = show_legend2)
	430	+	.plot_single(x, ct,
	431	+	type = type, show_cb = show_cb,
	432	+	raw_curves = raw_curves, add_np_nn = add_np_nn,
	433	+	show_legend = show_legend2
	434	+	)
428	435		}
429	436		if (length(curvetype) > 4 && length(curvetype) %% 3 == 2) {
430	437		graphics::plot(1, type = "n", axes = FALSE, xlab = "", ylab = "")

630	645
631	646		# === Create a plot ===
632	647		if (show_cb) {
633		-	.plot_avg(x, type, tlist[["ctype"]], main, tlist[["xlab"]],
634		-	tlist[["ylab"]], show_cb)
	648	+	.plot_avg(
	649	+	x, type, tlist[["ctype"]], main, tlist[["xlab"]],
	650	+	tlist[["ylab"]], show_cb
	651	+	)
635	652		} else if (raw_curves) {
636		-	.matplot_wrapper(x, type, tlist[["ctype"]], main, tlist[["xlab"]],
637		-	tlist[["ylab"]])
	653	+	.matplot_wrapper(
	654	+	x, type, tlist[["ctype"]], main, tlist[["xlab"]],
	655	+	tlist[["ylab"]]
	656	+	)
638	657		} else {
639		-	.plot_avg(x, type, tlist[["ctype"]], main, tlist[["xlab"]],
640		-	tlist[["ylab"]], show_cb)
	658	+	.plot_avg(
	659	+	x, type, tlist[["ctype"]], main, tlist[["xlab"]],
	660	+	tlist[["ylab"]], show_cb
	661	+	)
641	662		}
642	663
643	664		if (curvetype == "ROC") {
644	665		graphics::abline(a = 0, b = 1, col = "grey", lty = 3)
645		-
646	666		} else if (curvetype == "PRC") {
647	667		graphics::abline(h = pn_info$prc_base, col = "grey", lty = 3)
648	668		}

654	674		# Get title and subtitles
655	675		#
656	676		.get_titiles <- function(curvetype) {
657		-	tlist = list()
	677	+	tlist <- list()
658	678
659	679		if (curvetype == "ROC") {
660	680		tlist[["main"]] <- "ROC"

667	687		tlist[["ylab"]] <- "Precision"
668	688		tlist[["ctype"]] <- "prcs"
669	689		} else {
670		-	mnames <- list(score = "score", label = "label", error = "err",
671		-	accuracy = "acc", specificity = "sp", sensitivity = "sn",
672		-	precision = "prec", mcc = "mcc", fscore = "fscore")
	690	+	mnames <- list(
	691	+	score = "score", label = "label", error = "err",
	692	+	accuracy = "acc", specificity = "sp", sensitivity = "sn",
	693	+	precision = "prec", mcc = "mcc", fscore = "fscore"
	694	+	)
673	695		if (curvetype == "mcc") {
674	696		main <- "MCC"
675	697		} else if (curvetype == "label") {
676	698		main <- "Label (1:pos, -1:neg)"
677	699		} else {
678		-	main <- paste0(toupper(substring(curvetype, 1, 1)), substring(curvetype, 2))
	700	+	main <- paste0(
	701	+	toupper(substring(curvetype, 1, 1)),
	702	+	substring(curvetype, 2)
	703	+	)
679	704		}
680	705		tlist[["main"]] <- main
681	706		tlist[["xlab"]] <- "normalized rank"

694	719		withr::local_par(list(mar = c(0, 0, 0, 0), pty = "m"))
695	720		gnames <- attr(obj, paste0("uniq_", gnames))
696	721		graphics::plot(1, type = "n", axes = FALSE, xlab = "", ylab = "")
697		-	graphics::legend(x = "top", lty = 1,
698		-	legend = gnames,
699		-	col = grDevices::rainbow(length(gnames), alpha = 1),
700		-	horiz = TRUE)
	722	+	graphics::legend(
	723	+	x = "top", lty = 1,
	724	+	legend = gnames,
	725	+	col = grDevices::rainbow(length(gnames), alpha = 1),
	726	+	horiz = TRUE
	727	+	)
701	728		}
702	729		}
703	730

715	742		if (!all(is.na(avgcurves))) {
716	743		for (i in seq_len(length(avgcurves))) {
717	744		max_score <- max(max_score, max(avgcurves[[i]][["y_ci_h"]], na.rm = TRUE),
718		-	na.rm = TRUE)
	745	+	na.rm = TRUE
	746	+	)
719	747		min_score <- min(min_score, min(avgcurves[[i]][["y_ci_l"]], na.rm = TRUE),
720		-	na.rm = TRUE)
	748	+	na.rm = TRUE
	749	+	)
721	750		}
722	751		} else {
723	752		for (i in seq_len(length(curves))) {
724	753		max_score <- max(max_score, max(curves[[i]][["y"]], na.rm = TRUE),
725		-	na.rm = TRUE)
	754	+	na.rm = TRUE
	755	+	)
726	756		min_score <- min(min_score, min(curves[[i]][["y"]], na.rm = TRUE),
727		-	na.rm = TRUE)
	757	+	na.rm = TRUE
	758	+	)
728	759		}
729	760		}
730	761

91	91		#' p_prc
92	92		#'
93	93		#' ## Generate an sspoints object that contains basic evaluation measures
94		-	#' sspoints <- evalmod(mode = "basic", scores = P10N10$scores,
95		-	#' labels = P10N10$labels)
	94	+	#' sspoints <- evalmod(
	95	+	#' mode = "basic", scores = P10N10$scores,
	96	+	#' labels = P10N10$labels
	97	+	#' )
96	98		#' ## Fortify sspoints
97	99		#' ssdf <- fortify(sspoints)
98	100		#'