R/tool_zzz.R

In prcbench: Testing Workbench for Precision-Recall Curves

# .onLoad <- function(libname, pkgname) {
#   jarpath = system.file("java", "auc2.jar", package = "prcbench")
#   .jpackage(pkgname, lib.loc = libname, morePaths = jarpath)
# }

#' ToolIFBase
#'
#' @description
#' Base class of performance evaluation tools.
#'
#' @details
#' \code{ToolIFBase} is an abstract class to provide a uniform interface for
#' performance evaluation tools.
#'
#' @seealso \code{\link{ToolROCR}}, \code{\link{ToolAUCCalculator}},
#'   \code{\link{ToolPerfMeas}}, \code{\link{ToolPRROC}},
#'   and \code{\link{Toolprecrec}} are derived from this class.
#'   \code{\link{create_toolset}} for creating a list of tools.
#'
#' @docType class
#' @format An \code{R6} class object
#' @export
ToolIFBase <- R6::R6Class(
  "ToolIFBase",
  public = list(
    #' @description
    #' Default class initialization method.
    #' @param ... set value for \code{setname}, \code{calc_auc},
    #' \code{store_res}, \code{x}, \code{y}.
    initialize = function(...) {
      private$set_def_params(...)
    },

    #' @description
    #' It calls the tool to calculate precision-recall curves.
    #' @param testset \code{R6} object generated by the \code{create_testset}
    #'   function.
    #' @param calc_auc A Boolean value to specify whether the AUC score should
    #'   be calculated.
    #' @param store_res A Boolean value to specify whether the calculated curve
    #'   is retrieved and stored.
    call = function(testset, calc_auc, store_res) {
      if (missing(calc_auc)) {
        calc_auc <- private$def_calc_auc
      }
      if (missing(store_res)) {
        store_res <- private$def_store_res
      }
      if (is.function(private$f_wrapper)) {
        result <- private$f_wrapper(testset, calc_auc, store_res)
        if (store_res && !is.null(result)) {
          private$set_result(result)
        } else if (calc_auc && !is.null(result$auc)) {
          private$set_auc(result$auc)
        }
      }
      private$called <- TRUE
      self
    },

    #' @description
    #' Get the name of the tool.
    get_toolname = function() {
      private$toolname
    },

    #' @description
    #' Set the name of the tool.
    #' @param toolname Name of the tool.
    set_toolname = function(toolname) {
      private$toolname <- toolname
    },

    #' @description
    #' Get the name of the tool set.
    get_setname = function() {
      private$setname
    },

    #' @description
    #' Set the name of the tool set.
    #' @param setname Name of the tool set.
    set_setname = function(setname) {
      private$setname <- setname
    },

    #' @description
    #' Get a list with curve values and the AUC score.
    get_result = function() {
      private$result
    },

    #' @description
    #' Get calculated recall values.
    get_x = function() {
      private$result[["x"]]
    },

    #' @description
    #' Get calculated precision values.
    get_y = function() {
      private$result[["y"]]
    },

    #' @description
    #' Get tne AUC score.
    get_auc = function() {
      private$result[["auc"]]
    },

    #' @description
    #' Pretty print of the tool interface
    #' @param ... Not used.
    print = function(...) {
      cat("\n")
      cat("    === Tool interface ===\n")
      cat("\n")

      cat("    Tool name:           ", self$get_toolname(), "\n")
      cat("    Calculate AUC score: ")
      if (private$def_calc_auc) {
        cat(" Yes\n")
      } else {
        cat(" No\n")
      }
      cat("    Store results:       ")
      if (private$def_store_res) {
        cat(" Yes\n")
      } else {
        cat(" No\n")
      }
      cat("    Prediction performed:")
      if (private$called) {
        cat(" Yes\n")
      } else {
        cat(" No\n")
      }
      cat("    Available methods:    call(testset, calc_auc, store_res)\n")
      cat("                          get_toolname()\n")
      cat("                          set_toolname(toolname)\n")
      cat("                          get_setname()\n")
      cat("                          set_setname(setname)\n")
      cat("                          get_result()\n")
      cat("                          get_x()\n")
      cat("                          get_y()\n")
      cat("                          get_auc()\n")
      private$print_methods()
      if (private$helpfile) {
        cat(
          "    Help file:           ",
          paste0("help(\"", class(self)[1], "\")")
        )
      }
      cat("\n")
      invisible(self)
    }
  ),
  private = list(
    set_def_params = function(...) {
      arglist <- list(...)
      if (length(arglist) > 0) {
        if ("setname" %in% names(arglist)) {
          private$setname <- arglist[["setname"]]
        }
        if ("calc_auc" %in% names(arglist)) {
          private$def_calc_auc <- arglist[["calc_auc"]]
        }
        if ("store_res" %in% names(arglist)) {
          private$def_store_res <- arglist[["store_res"]]
        }
        if ("x" %in% names(arglist)) {
          private$result$x <- arglist[["x"]]
        }
        if ("y" %in% names(arglist)) {
          private$result$y <- arglist[["y"]]
        }
      }
    },
    toolname = NA,
    setname = NA,
    called = FALSE,
    def_calc_auc = TRUE,
    def_store_res = TRUE,
    print_methods = function() {
      invisible(NULL)
    },
    set_result = function(val) {
      private$result <- val
    },
    set_auc = function(val) {
      private$result[["auc"]] <- val
    },
    result = list(x = NA, y = NA, auc = NA),
    f_wrapper = function(testset, calc_auc, store_res) {
      NULL
    },
    helpfile = TRUE
  )
)

#' ToolROCR
#'
#' @description
#' \code{R6} class of the ROCR tool
#'
#' @details
#' \code{ToolROCR} is a wrapper class for
#' the \href{https://ipa-tys.github.io/ROCR/}{ROCR} tool, which is an R
#' library that provides calculations of various performance evaluation
#' measures.
#'
#' @seealso This class is derived from \code{\link{ToolIFBase}}.
#'    \code{\link{create_toolset}} for creating a list of tools.
#'
#' @examples
#' ## Initialization
#' toolrocr <- ToolROCR$new()
#'
#' ## Show object info
#' toolrocr
#'
#' ## create_toolset should be used for benchmarking and curve evaluation
#' toolrocr2 <- create_toolset("ROCR")
#'
#' @docType class
#' @format An \code{R6} class object.
#' @export
ToolROCR <- R6::R6Class(
  "ToolROCR",
  inherit = ToolIFBase,
  private = list(toolname = "ROCR", f_wrapper = .rocr_wrapper)
)

#' ToolAUCCalculator
#'
#' @description
#' \code{R6} class of the AUCCalculator tool
#'
#' @details
#' \code{ToolAUCCalculator} is a wrapper class for
#' the \href{http://mark.goadrich.com/programs/AUC/}{AUCCalculator} tool, which
#' is a Java library that provides calculations of ROC and Precision-Recall
#' curves.
#'
#' @seealso This class is derived from \code{\link{ToolIFBase}}.
#'    \code{\link{create_toolset}} for creating a list of tools.
#'
#' @examples
#' ## Initialization
#' toolauccalc <- ToolAUCCalculator$new()
#'
#' ## Show object info
#' toolauccalc
#'
#' ## create_toolset should be used for benchmarking and curve evaluation
#' toolauccalc2 <- create_toolset("AUCCalculator")
#'
#' @docType class
#' @format An \code{R6} class object.
#' @export
ToolAUCCalculator <- R6::R6Class(
  "ToolAUCCalculator",
  inherit = ToolIFBase,
  public = list(
    #' @description
    #' Default class initialization method.
    #' @param ... set value for \code{jarpath}.
    initialize = function(...) {
      private$set_def_params(...)

      arglist <- list(...)
      if (length(arglist) > 0) {
        if ("jarpath" %in% names(arglist)) {
          private$jarpath <- arglist[["jarpath"]]
        }
      }
      if (private$available && !requireNamespace("rJava", quietly = TRUE)) {
        print("rJava is not available.")
        private$available <- FALSE
      }
      private$f_setjar()
    },

    #' @description
    #' It sets an AUCCalculator jar file.
    #' @param jarpath File path of the AUCCalculator jar file,
    #' e.g. \code{"/path1/path2/auc2.jar"}.
    set_jarpath = function(jarpath = NULL) {
      private$jarpath <- jarpath
      private$f_setjar()
    },

    #' @description
    #' It sets the type of curve.
    #' @param curvetype "SPR", "PR", or "ROC"
    set_curvetype = function(curvetype = "SPR") {
      if (assertthat::assert_that(assertthat::is.string(curvetype)) &&
        (toupper(curvetype) %in% c("SPR", "PR", "ROC"))) {
        private$curvetype <- toupper(curvetype)
        private$f_setjar()
      }
    },

    #' @description
    #' It sets the type of calculation method
    #' @param auctype "java" or "r"
    set_auctype = function(auctype) {
      if (assertthat::assert_that(assertthat::is.string(auctype)) &&
        (tolower(auctype) %in% c("java", "r"))) {
        private$auctype <- tolower(auctype)
      }
    }
  ),
  private = list(
    toolname = "AUCCalculator",
    available = TRUE,
    curvetype = "SPR",
    auctype = "java",
    print_methods = function() {
      cat("                          set_jarpath(jarpath)\n")
      cat("                          set_curvetype(curvetype)\n")
      cat("                          set_auctype(auctype)\n")
    },
    auc2 = NA,
    jarpath = NA,
    f_setjar = function() {
      if (is.na(private$jarpath)) {
        jarpath <- system.file("java", "auc2.jar", package = "prcbench")
      } else {
        jarpath <- private$jarpath
      }
      if (private$available) {
        private$auc2 <- .get_java_obj("auc2", jarpath, private$curvetype)
      } else {
        private$auc2 <- NA
      }
    },
    f_wrapper = function(testset, calc_auc, store_res) {
      if (private$available) {
        .auccalc_wrapper(
          testset, private$auc2, calc_auc, store_res,
          private$auctype
        )
      } else {
        if (store_res) {
          x <- seq(0.0, 1.0, 0.1)
          y <- rep(0.5, length(x))
          list(x = x, y = y, auc = 0.5)
        } else {
          NULL
        }
      }
    }
  )
)

#' ToolPerfMeas
#'
#' @description
#' \code{R6} class of the PerfMeas tool
#'
#' @details
#' \code{ToolPerfMeas} is a wrapper class for
#' the \href{https://cran.r-project.org/package=PerfMeas}{PerfMeas} tool,
#' which is an R library that provides several performance measures.
#'
#' @seealso This class is derived from \code{\link{ToolIFBase}}.
#'    \code{\link{create_toolset}} for creating a list of tools.
#'
#' @examples
#' ## Initialization
#' toolperf <- ToolPerfMeas$new()
#'
#' ## Show object info
#' toolperf
#'
#' ## create_toolset should be used for benchmarking and curve evaluation
#' toolperf2 <- create_toolset("PerfMeas")
#'
#' @docType class
#' @format An \code{R6} class object.
#' @export
ToolPerfMeas <- R6::R6Class(
  "ToolPerfMeas",
  inherit = ToolIFBase,
  private = list(
    toolname = "PerfMeas",
    f_wrapper = function(testset, calc_auc, store_res) {
      .pm_wrapper(testset, calc_auc, store_res)
    }
  )
)

#' ToolPRROC
#'
#' @description
#' \code{R6} class of the PRROC tool
#'
#' @details
#' \code{ToolPRROC} is a wrapper class for
#' the \href{https://cran.r-project.org/package=PRROC}{PRROC} tool, which
#' is an R library that provides calculations of ROC and Precision-Recall
#' curves.
#'
#' @seealso This class is derived from \code{\link{ToolIFBase}}.
#'    \code{\link{create_toolset}} for creating a list of tools.
#'
#' @examples
#' ## Initialization
#' toolprroc <- ToolPRROC$new()
#'
#' ## Show object info
#' toolprroc
#'
#' ## create_toolset should be used for benchmarking and curve evaluation
#' toolprroc2 <- create_toolset("PRROC")
#'
#' @docType class
#' @format An \code{R6} class object.
#' @export
ToolPRROC <- R6::R6Class(
  "ToolPRROC",
  inherit = ToolIFBase,
  public = list(
    #' @description
    #' Default class initialization method.
    #' @param ... set value for \code{curve}, \code{minStepSize},
    #'   \code{aucType}.
    initialize = function(...) {
      private$set_def_params(...)

      arglist <- list(...)
      if (length(arglist) > 0) {
        if ("curve" %in% names(arglist)) {
          private$curve <- arglist[["curve"]]
        }
        if ("minStepSize" %in% names(arglist)) {
          private$minStepSize <- arglist[["minStepSize"]]
        }
        if ("aucType" %in% names(arglist)) {
          private$aucType <- arglist[["aucType"]]
        }
      }
    },

    #' @description
    #' A Boolean value to specify whether precision-recall curve is calculated.
    #' @param val TRUE: calculate, FALSE: not calculate.
    set_curve = function(val) {
      private$curve <- val
    },

    #' @description
    #' A numeric value to specify the minimum step size
    #'  between two intermediate points.
    #' @param val Step size between two  points.
    set_minStepSize = function(val) {
      private$minStepSize <- val
    },

    #' @description
    #' Set the AUC calculation method
    #' @param val 1: integral, 2: Davis Goadrich
    set_aucType = function(val) {
      private$aucType <- val
    }
  ),
  private = list(
    toolname = "PRROC",
    print_methods = function() {
      cat("                          set_curve(val)\n")
      cat("                          set_minStepSize(val)\n")
      cat("                          set_aucType(val)\n")
    },
    f_wrapper = function(testset, calc_auc, store_res) {
      .prroc_wrapper(
        testset, calc_auc, store_res, private$curve,
        private$minStepSize, private$aucType
      )
    },
    curve = TRUE,
    minStepSize = 0.01,
    aucType = 1
  )
)

#' Toolprecrec
#'
#' @description
#' \code{R6} class of the precrec tool
#'
#' @details
#' \code{Toolprecrec} is a wrapper class for
#' the \href{https://cran.r-project.org/package=precrec}{precrec} tool,
#' which is an R library that provides calculations of ROC and Precision-Recall
#' curves.
#'
#' @seealso This class is derived from \code{\link{ToolIFBase}}.
#'    \code{\link{create_toolset}} for creating a list of tools.
#'
#' @examples
#' ## Initialization
#' toolprecrec <- Toolprecrec$new()
#'
#' ## Show object info
#' toolprecrec
#'
#' ## create_toolset should be used for benchmarking and curve evaluation
#' toolprecrec2 <- create_toolset("precrec")
#'
#' @docType class
#' @format An \code{R6} class object.
#' @export
Toolprecrec <- R6::R6Class(
  "Toolprecrec",
  inherit = ToolIFBase,
  public = list(
    #' @description
    #' Default class initialization method.
    #' @param ... set value for \code{x_bins}.
    initialize = function(...) {
      private$set_def_params(...)

      arglist <- list(...)
      if (length(arglist) > 0) {
        if ("x_bins" %in% names(arglist)) {
          private$x_bins <- arglist[["x_bins"]]
        }
      }
    },

    #' @description
    #' Set the number of supporting points as the number of bins.
    #' @param x_bins set value for \code{x_bins}.
    set_x_bins = function(x_bins) {
      private$x_bins <- x_bins
    }
  ),
  private = list(
    toolname = "precrec",
    print_methods = function() {
      cat("                          set_x_bins(x_bins)\n")
    },
    f_wrapper = function(testset, calc_auc, store_res) {
      .precrec_wrapper(testset, calc_auc, store_res, private$x_bins)
    },
    x_bins = 1000
  )
)