R/old/class-extract.R

In jeanmathieupotvin/scr: Spatial scoring algorithms :: scorer

#' @name class-extract
#' @aliases extract
#'
#' @title Class "extract" for spatial data extraction
#'
#' @description An abstract S3 class to store outputs stemming from any kind of
#' extraction from spatial data layers.
#'
#' @usage
#' ## The constructor function
#' new_extract(meta, output, ..., .subclass = NULL)
#'
#' @param meta An object of class \code{\link[glr:class-meta]{meta}}.
#'
#' @param output An array or a \code{\link{vector}}. Typically, a
#' \code{\link[data.table]{data.table}}, a \code{\link{data.frame}},
#' a \code{\link{list}} or a \code{\link{matrix}}. If a \code{\link{vector}},
#' classes \code{\link{complex}} and \code{\link{raw}} are not supported.
#'
#' @param ... Further arguments passed to or from other methods.
#'
#' For function \code{new_extract}, additional objects. \bold{Expert only!}
#' Additional slots to use when constructing subclasses inheriting from class
#' \code{\link[glr:class-extract]{extract}}. They must be named and use the
#' \code{name = value} format.
#'
#' @param .subclass A character. \bold{Expert only!} Subclass name when
#' constructing subclasses inheriting from class
#' \code{\link[glr:class-extract]{extract}}.
#'
#' @param x Any \R object.
#'
#' @details Class \code{\link[glr:class-extract]{extract}} is an abstract
#' class from which other subclasses are derived through \emph{inheritance}. In
#' \pkg{glr}, classes \code{\link[glr:class-raster.extract]{raster.extract}}
#' and \code{\link[glr:class-vector.extract]{vector.extract}} \emph{inherits}
#' from class \code{\link[glr:class-extract]{extract}}. For more information
#' on S3 inheritance mechanism, see \code{\link[base:class]{class}}.
#'
#' For consistency, always use the constructor function \code{new_extract} to
#' generate subclasses inheriting from class
#' \code{\link[glr:class-extract]{extract}}. This function will also evolve
#' over time. By using it, your subclasses will always benefit from the latest
#' improvements on class \code{\link[glr:class-extract]{extract}}.
#'
#' @return Function \code{\link{new_extract}} is a constructor function: it
#' returns an object of class \code{\link[glr:class-extract]{extract}} from its
#' arguments. Function \code{\link{is.extract}} checks if \code{x} is of class
#' \code{\link[glr:class-extract]{extract}} and returns a logical. For the
#' associated methods, the usual outputs should be expected.
#'
#' @section Components (slots):
#'
#' \describe{
#' \item{\code{meta}:}{
#' Information on the layers that were used for the extraction. See
#' \code{\link[glr:class-meta]{meta}}.
#' }
#' \item{\code{output}:}{
#' The extracted values from the layers.
#' }
#' }
#'
#' @section S3 methods for objects of class \code{extract}:
#' \describe{
#' \item{\code{format}}{
#' Pretty printing of an \code{\link[glr:class-extract]{extract}} object. Most
#' of the time, only the \code{print} method should be used.
#' }
#' \item{\code{print}}{
#' Print the object in the console.
#' }
#' }
#'
#' An object of class \code{\link[glr:class-extract]{extract}} is stored as a
#' list. Therefore, usual methods for lists such as
#' \code{\link[base:Extract]{[}}, \code{\link[base:Extract]{[[}},
#' \code{\link[base:Extract]{$}}, etc. will all work.
#'
#' @family extract classes
#' @family glr classes
#'
#' @examples
#' # Create an object of class 'meta'.
#' info <- new_meta("useless values", NA, NA, NA, NA, NA, NA)
#'
#' # Gather some values.
#' out <- c("apples", "oranges", "blueberries")
#'
#' # Create an object of class "extract".
#' obj <- new_extract(info, out)
#'
#' # Create an object of class "fruit.extract" inheriting from class "extract"
#' # by using the constructor function. This subclass possesses an additional
#' # slot "which.I.like".
#' obj2 <- new_extract(info, out, which.I.like = c("Yes", "No", "Yes"),
#'                     .subclass = "fruit.extract")
#'
#' # Compare classes of obj and obj2.
#' class(obj)
#' class(obj2)
#'
#' # Print both objects in the console.
#' obj
#' obj2
#'
#' # As you can see, both objects are printed (almost) exactly in the same
#' # way. This is because objects of class "fruit.extract" inherit all relevent
#' # methods from class "extract". This is a consequence of the S3 OOP system
#' # of R.
#'
#' @export
new_extract <- function(meta, output, ..., .subclass = NULL)
{
  vals <- c("data.table", "data.frame", "list", "matrix",
            "logical", "integer", "numeric", "character")
  clo  <- match(class(output)[1L], vals)

  if (is.na(clo)) {
    stop("'output' must be a 'data.table', a 'data.frame', ",
         "a 'list', a 'matrix' or a 'vector'.", call. = FALSE)
  }

  if (!is.meta(meta)) {

    if (is.list(meta)) {

      meta <- c(meta)
      ok1 <- all(sapply(meta, is.meta))

      if (!ok1) {
        stop("'meta' must only contain objects of class 'meta'.",
             call. = FALSE)
      }

    } else {

      stop("'meta' must be an object of class 'meta' or ",
           "a 'list' of such objects.",
           call. = FALSE)

    }

  }

  out <- list(meta, output)
  nms <- c("meta", "output")

  if (...length()) {

    if (is.null(.subclass)) {
      stop("additional components detected but no subclass.", call. = FALSE)
    }

    dots <- list(...)
    nmsd <- names(dots)
    ok2  <- all(nchar(nmsd) != 0L)

    if (!ok2) {
      stop("additional components in '...' must have distinct names.",
           call. = FALSE)
    }

    out <- c(out, dots)
    nms <- c(nms, nmsd)

  }

  structure(out, names = nms, class = c(.subclass, "extract"))
}

#' @rdname class-extract
#' @export
is.extract <- function(x)
{
  inherits(x, "extract")
}

#' @rdname class-extract
#' @export
format.extract <- function(x, ...)
{
  tol <- 60L
  clx <- rev(class(x))
  nms <- names(x)[-match(c("meta", "output"), names(x))]
  pad <- max(nchar(nms), 5L, 8L)

  cat("", .pad("class", pad), " :", clx[1L], "\n")

  if (length(clx) > 1L) {
    cat("", .pad("subclass", pad), " :", clx[2L], "\n")
  }

  for (j in nms) {
    cat("", .pad(j, pad), " : ")
    .format.output(x[[j]])
  }

  cat("", .pad("output", pad), " : ")
  .format.output(x$output)

  cat(strrep("-", tol), "\n")

  if (is.meta(x$meta)) {

    cat("Layer used 1", "\n")
    cat(format(x$meta))

  } else {

    lenm <- seq_along(x$meta)
    m <- max(lenm) + 1L

    for (j in lenm) {

      cat("Layer used", m - j, "\n")
      cat(format(x$meta[[j]]))
      cat(strrep("-", tol), "\n")

    }

  }

  invisible()
}

#' @rdname class-extract
#' @export
print.extract <- function(x, ...)
{
  cat(format(x, ...))
}