R/etc_utils_dataframe.R

In takayasaito/precrec: Calculate Accurate Precision-Recall and ROC (Receiver Operator Characteristics) Curves

#' Convert a curves and points object to a data frame
#'
#' The \code{as.data.frame} function converts an \code{S3} object generated by
#'   \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.
#'
#' \enumerate{
#'
#'   \item ROC and Precision-Recall curves (mode = "rocprc")
#'
#'   \tabular{lll}{
#'     \strong{\code{S3} object}
#'     \tab \strong{# of models}
#'     \tab \strong{# of test datasets} \cr
#'
#'     sscurves \tab single   \tab single   \cr
#'     mscurves \tab multiple \tab single   \cr
#'     smcurves \tab single   \tab multiple \cr
#'     mmcurves \tab multiple \tab multiple
#'   }
#'
#'   \item Basic evaluation measures (mode = "basic")
#'
#'   \tabular{lll}{
#'     \strong{\code{S3} object}
#'     \tab \strong{# of models}
#'     \tab \strong{# of test datasets} \cr
#'
#'     sspoints \tab single   \tab single   \cr
#'     mspoints \tab multiple \tab single   \cr
#'     smpoints \tab single   \tab multiple \cr
#'     mmpoints \tab multiple \tab multiple
#'   }
#'
#'   \item Fast AUC (ROC) calculation with the U statistic (mode = "aucroc")
#'   \tabular{lll}{
#'     \strong{\code{S3} object}
#'     \tab \strong{# of models}
#'     \tab \strong{# of test datasets} \cr
#'
#'     aucroc \tab -   \tab -
#'   }
#' }
#'
#' See the \strong{Value} section of \code{\link{evalmod}} for more details.
#'
#' @param raw_curves A Boolean value to specify whether raw curves are
#'   shown instead of the average curve. It is effective only
#'   when \code{raw_curves} is set to \code{TRUE}
#'   of the \code{\link{evalmod}} function.
#'
#' @param ... Not used by this method.
#'
#' @param row.names Not used by this method.
#'
#' @param optional Not used by this method.
#'
#' @return The \code{as.data.frame} function returns a data frame.
#'
#' @seealso \code{\link{evalmod}} for generating \code{S3} objects with
#'   performance evaluation measures.
#'
#' @examples
#' \dontrun{
#' ##################################################
#' ### Single model & single test dataset
#' ###
#'
#' ## Load a dataset with 10 positives and 10 negatives
#' data(P10N10)
#'
#' ## Generate an sscurve object that contains ROC and Precision-Recall curves
#' sscurves <- evalmod(scores = P10N10$scores, labels = P10N10$labels)
#'
#' ## Convert sscurves to a data frame
#' sscurves.df <- as.data.frame(sscurves)
#'
#' ## Show data frame
#' head(sscurves.df)
#'
#' ## Generate an sspoints object that contains basic evaluation measures
#' sspoints <- evalmod(
#'   mode = "basic", scores = P10N10$scores,
#'   labels = P10N10$labels
#' )
#' ## Convert sspoints to a data frame
#' sspoints.df <- as.data.frame(sspoints)
#'
#' ## Show data frame
#' head(sspoints.df)
#'
#'
#' ##################################################
#' ### Multiple models & single test dataset
#' ###
#'
#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(1, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'   modnames = samps[["modnames"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mscurves <- evalmod(mdat)
#'
#' ## Convert mscurves to a data frame
#' mscurves.df <- as.data.frame(mscurves)
#'
#' ## Show data frame
#' head(mscurves.df)
#'
#' ## Generate an mspoints object that contains basic evaluation measures
#' mspoints <- evalmod(mdat, mode = "basic")
#'
#' ## Convert mspoints to a data frame
#' mspoints.df <- as.data.frame(mspoints)
#'
#' ## Show data frame
#' head(mspoints.df)
#'
#'
#' ##################################################
#' ### Single model & multiple test datasets
#' ###
#'
#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(10, 100, 100, "good_er")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an smcurve object that contains ROC and Precision-Recall curves
#' smcurves <- evalmod(mdat, raw_curves = TRUE)
#'
#' ## Convert smcurves to a data frame
#' smcurves.df <- as.data.frame(smcurves)
#'
#' ## Show data frame
#' head(smcurves.df)
#'
#' ## Generate an smpoints object that contains basic evaluation measures
#' smpoints <- evalmod(mdat, mode = "basic")
#'
#' ## Convert smpoints to a data frame
#' smpoints.df <- as.data.frame(smpoints)
#'
#' ## Show data frame
#' head(smpoints.df)
#'
#'
#' ##################################################
#' ### Multiple models & multiple test datasets
#' ###
#'
#' ## Create sample datasets with 100 positives and 100 negatives
#' samps <- create_sim_samples(10, 100, 100, "all")
#' mdat <- mmdata(samps[["scores"]], samps[["labels"]],
#'   modnames = samps[["modnames"]],
#'   dsids = samps[["dsids"]]
#' )
#'
#' ## Generate an mscurve object that contains ROC and Precision-Recall curves
#' mmcurves <- evalmod(mdat, raw_curves = TRUE)
#'
#' ## Convert mmcurves to a data frame
#' mmcurves.df <- as.data.frame(mmcurves)
#'
#' ## Show data frame
#' head(mmcurves.df)
#'
#' ## Generate an mmpoints object that contains basic evaluation measures
#' mmpoints <- evalmod(mdat, mode = "basic")
#'
#' ## Convert mmpoints to a data frame
#' mmpoints.df <- as.data.frame(mmpoints)
#'
#' ## Show data frame
#' head(mmpoints.df)
#'
#'
#' ##################################################
#' ### N-fold cross validation datasets
#' ###
#'
#' ## Load test data
#' data(M2N50F5)
#'
#' ## Speficy nessesary columns to create mdat
#' cvdat <- mmdata(
#'   nfold_df = M2N50F5, score_cols = c(1, 2),
#'   lab_col = 3, fold_col = 4,
#'   modnames = c("m1", "m2"), dsids = 1:5
#' )
#'
#' ## Generate an mmcurve object that contains ROC and Precision-Recall curves
#' cvcurves <- evalmod(cvdat)
#'
#' ## Convert mmcurves to a data frame
#' cvcurves.df <- as.data.frame(cvcurves)
#'
#' ## Show data frame
#' head(cvcurves.df)
#'
#' ## Generate an mmpoints object that contains basic evaluation measures
#' cvpoints <- evalmod(cvdat, mode = "basic")
#'
#' ## Convert mmpoints to a data frame
#' cvpoints.df <- as.data.frame(cvpoints)
#'
#' ## Show data frame
#' head(cvpoints.df)
#'
#'
#' ##################################################
#' ### AUC with the U statistic
#' ###
#'
#' ## mode = "aucroc"
#' data(P10N10)
#' uauc1 <- evalmod(
#'   scores = P10N10$scores, labels = P10N10$labels,
#'   mode = "aucroc"
#' )
#'
#' # as.data.frame 'aucroc'
#' as.data.frame(uauc1)
#'
#' ## 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")
#'
#' # as.data.frame 'aucroc'
#' head(as.data.frame(uauc2))
#' }
#'
#' @name as.data.frame
NULL

#
# Make a dataframe for plotting
#
.dataframe_common <- function(obj, mode = "rocprc", raw_curves = TRUE,
                              reduce_points = FALSE, check_ggplot = FALSE,
                              ...) {
  # === Check package availability  ===
  if (check_ggplot) {
    .load_ggplot2()
  }

  # === Validate input arguments ===
  .validate(obj)
  new_mode <- .pmatch_mode(mode)
  .check_mode(new_mode, obj)
  .check_raw_curves(raw_curves, obj)

  arguments <- list(...)
  if ("use_rcpp" %in% names(arguments)) {
    use_rcpp <- arguments[["use_rcpp"]]
  } else {
    use_rcpp <- TRUE
  }

  # Prepare variables
  uniq_modnames <- attr(obj, "uniq_modnames")
  uniq_dsids <- attr(obj, "uniq_dsids")
  modnames <- attr(obj, "data_info")[["modnames"]]
  dsids <- attr(obj, "data_info")[["dsids"]]

  if (new_mode == "rocprc") {
    curvetype_names <- list(ROC = "rocs", PRC = "prcs")
    if (reduce_points) {
      x_bins <- attr(obj, "args")$x_bins
    } 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"
    )
    x_bins <- 0
  }

  # Make dsis-modname pairs
  dsid_modnames <- paste(attr(obj, "data_info")$modnames,
    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
      )
      .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
      )
      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
      )
      .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
      )
      warning("R version of .dataframe_common is used")
    }
  }

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

  curve_df
}

#
# Make a dataframe for plotting with regular curves
#
.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]]]]
    for (i in seq_along(curves)) {
      x <- curves[[i]][["x"]]
      y <- curves[[i]][["y"]]

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

  curve_df
}

#
# Make a dataframe for plotting with average curves
#
.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)) {
    avgcurves <- grp_avg[[curvetype_names[[curvetype]]]]

    for (i in seq_along(avgcurves)) {
      x <- avgcurves[[i]][["x"]]
      y <- avgcurves[[i]][["y_avg"]]
      ymin <- avgcurves[[i]][["y_ci_l"]]
      ymax <- avgcurves[[i]][["y_ci_h"]]

      modname <- factor(rep(uniq_modnames[i], length(x)),
        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
      ))
    }
  }

  curve_df
}

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

  if (is.null(arglist[["raw_curves"]])) {
    if (!is.null(def_raw_curves)) {
      arglist[["raw_curves"]] <- def_raw_curves
    } else if (!is.null(evalmod_args[["raw_curves"]])) {
      arglist[["raw_curves"]] <- evalmod_args[["raw_curves"]]
    } else {
      arglist[["raw_curves"]] <- FALSE
    }
  }

  arglist
}