R/chkArgs.R

In ChemoSpecUtils: Functions Supporting Packages ChemoSpec and ChemoSpec2D

#'
#' Check spectra and pca Arguments of Functions That Require Them
#'
#' *Internal* function.
#' 
#' @param mode  Integer code giving the type of check to be run.
#' @return None.  Stops if there is a problem with the arguments.
#'
#' @author `r .writeDoc_Authors("BH")`
#' @export
#' @keywords internal
#'
#' @tests tinytest
#' # Get some pca data for testing
#' pca1 <- prcomp(USArrests) # class prcomp
#' pca2 <- princomp(USArrests) # class princomp
#'
#' # Simple test function; ALWAYS call with ALL arguments
#' tf <- function(spectra, pca, mode) {
#'   .chkArgs(mode)	
#' }
#'
#' ## ChemoSpec Instances
#'
#' if (requireNamespace("ChemoSpec", quietly = TRUE)) {
#'   library("ChemoSpec")
#' 	 data(metMUD1)
#' 
#'   # Mode 0
#'   # 1st arg is garbage
#'   expect_error(tf(12, 12, 0), "did not have class Spectra or Spectra2D")
#'
#'   # Mode 11
#'   # 1st arg is garbage
#'   expect_error(tf(12, 12, 11), "was not found or not a Spectra object")
#'   # Wrong arg in 1st position
#'   expect_error(tf(pca1, 12, 11), "was not found or not a Spectra object")
#'
#'   # Mode 12
#'   # 1st arg is garbage
#'   expect_error(tf(12, 12, 12), "was not found or not a Spectra object")
#'   # 2nd arg is garbage
#'   expect_error(tf(metMUD1, 12, 12), "was not found or did not have class prcomp")
#'   # 1st and 2nd arg reversed
#'   expect_error(tf(pca1, metMUD1, 12), "was not found or not a Spectra object")
#'   # 2nd arg wrong class
#'   expect_error(tf(metMUD1, pca2, 12), "was not found or did not have class prcomp")
#' } # end of ChemoSpec chkArgs tests
#'
#' ## ChemoSpec2D Instances
#' 
#' if (requireNamespace("ChemoSpec2D", quietly = TRUE)) {
#'   library("ChemoSpec2D")
#'   data(MUD1)
#'   set.seed(123)
#'   pfac <- pfacSpectra2D(MUD1, parallel = FALSE, nfac = 1)
#'   mia <- miaSpectra2D(MUD1)
#'   pop <- popSpectra2D(MUD1)
#'
#'   # Mode 0 (same as mode 0 above, no need to check)
#'
#'   # Mode 21
#'   # 1st arg is garbage
#'   expect_error(tf(12, 12, 21), "was not found or not a Spectra2D object")
#'   # Wrong arg in 1st position
#'   expect_error(tf(pca1, 12, 21), "was not found or not a Spectra2D object")
#'
#'   # Mode 22
#'   # 2nd arg is garbage
#'   expect_error(tf(MUD1, 12, 22), "was not found or did not have class mia/pfac/pop")
#'   # 1st and 2nd arg reversed
#'   expect_error(tf(pca1, MUD1, 22), "was not found or not a Spectra2D object")
#'   # 2nd arg wrong class
#'   expect_error(tf(MUD1, pca1, 22), "was not found or did not have class mia/pfac/pop")
#' } # end of ChemoSpec2D chkArgs tests
#'
#' ## Crossover checks
#' 
#' if (requireNamespace("ChemoSpec2D", quietly = TRUE)) {
#'   if (requireNamespace("ChemoSpec", quietly = TRUE)) {
#'     library("ChemoSpec2D")
#'     data(MUD1)
#'     library("ChemoSpec")
#'     data(metMUD1)
#'     # Spectra object passed to ChemoSpec2D
#'     expect_error(tf(metMUD1, 12, 21), "was not found or not a Spectra2D object")
#'     # Spectra2D object passed to ChemoSpec
#'     expect_error(tf(MUD1, 12, 11), "was not found or not a Spectra object")
#'   }
#' } # end of crossover checks
#' 
.chkArgs <- function(mode = 11L) {

  # The following is from stackoverflow.com/a/53137483/633251
  fargs <- function(n) {
    mget(names(formals(sys.function(n))), sys.frame(n), inherits = TRUE)
  }
  args <- fargs(-2) # 2 because the helper function fargs is yet another level down

  # print(data.frame(cls = unlist(lapply(args, class)))) # SAVE for debugging

  if (mode == 0L) {
    specOK <- FALSE
    specOK <- any(inherits(args$spectra, "Spectra"), inherits(args$spectra, "Spectra2D"))
    if (!specOK) stop("Argument 'spectra' was not found or did not have class Spectra or Spectra2D")
  }

  if (mode == 11L) {
    if (!inherits(args$spectra, "Spectra")) {
      stop("Argument 'spectra' was not found or not a Spectra object")
    }
  }

  if (mode == 21L) {
    if (!inherits(args$spectra, "Spectra2D")) {
      stop("Argument 'spectra' was not found or not a Spectra2D object")
    }
  }

  if (mode == 12L) {
    if (!inherits(args$spectra, "Spectra")) {
      stop("Argument 'spectra' was not found or not a Spectra object")
    }
    # PCA methods for Spectra objects all have prcomp as the return class
    pcaOK <- FALSE
    pcaOK <- any(inherits(args$pca, "prcomp"), inherits(args$so, "prcomp"))
    if (!pcaOK) stop("Argument 'pca' was not found or did not have class prcomp")
  }

  if (mode == 22L) {
    if (!inherits(args$spectra, "Spectra2D")) {
      stop("Argument 'spectra' was not found or not a Spectra2D object")
    }
    # PCA methods for Spectra2D objects have varying classes for return value
    pcaOK <- FALSE
    pcaOK <- any(
      inherits(args$so, "mia"),
      inherits(args$so, "pfac"),
      inherits(args$so, "pop"),
      inherits(args$pca, "mia"), # last 3 needed for unit tests
      inherits(args$pca, "pfac"),
      inherits(args$pca, "pop")
    )
    if (!pcaOK) stop("Argument 'so' was not found or did not have class mia/pfac/pop")
  }
} # end of chkArgs