R/old/class-meta.R

In jeanmathieupotvin/scr: Spatial scoring algorithms :: scorer

#' @name class-meta
#' @aliases meta
#'
#' @title Class "meta" for layers metadata
#'
#' @description A simple and flexible S3 class to safely store information on
#' layers used within features of \pkg{glr}.
#'
#' @usage
#' ## The constructor function
#' new_meta(output, format, layer, bands, provider, version, location,
#'          ..., strict.length = FALSE, .subclass = NULL)
#'
#' @param output A character.
#'
#' @param format A character.
#'
#' @param layer A character.
#'
#' @param bands Any kind of vector (numeric, integer, character).
#'
#' @param provider A character.
#'
#' @param version A character.
#'
#' @param location A character.
#'
#' @param strict.length A logical. Should equal lengths be expected for the
#' arguments supplied to \code{\link[glr:class-meta]{meta}}? Else, unequal
#' lengths are accepted. Defaults to \code{FALSE}.
#'
#' @param .subclass A character. \bold{Expert only!} Subclass name when
#' constructing subclasses inheriting from class
#' \code{\link[glr:class-meta]{meta}}. By default, \code{.subclass} is set
#' equal to \code{model}. See Details.
#'
#' @param x Any \R object for function \code{\link{is.meta}}. Else, an object
#' of class \code{\link[glr:class-meta]{meta}}.
#'
#' @param ... Further objects. They can be other objects of class
#' \code{\link[glr:class-meta]{meta}} or lists containing such objects. These
#' lists can have any kind of nesting structure.
#'
#' For function \code{new_meta}, additional objects. \bold{Expert only!}
#' Additional slots to use when constructing subclasses inheriting from class
#' \code{\link[glr:class-meta]{meta}}. They must be named and use the
#' \code{name = value} format.
#'
#' @return Function \code{\link{new_meta}} is a constructor function: it returns
#' an object of class \code{\link{meta}} from its arguments. Function
#' \code{\link{is.meta}} checks if \code{x} is of class
#' \code{\link[glr:class-meta]{meta}} and returns a logical. For the associated
#' methods, the usual outputs should be expected.
#'
#' @details Further subclasses can be derived from class \code{\link{meta}}.
#' Creating a subclass allows the user to include additional information in
#' the object through the \code{...} argument.
#'
#' @section Components (slots):
#'
#' \describe{
#' \item{\code{output}:}{
#' Simple description of the actual output. Can be equal to \code{NA}.
#' }
#' \item{\code{format}:}{
#' File format of the layer. Typically (but not limited to), \code{"shapefile"},
#' \code{"raster"}, etc.
#' }
#' \item{\code{layer}:}{
#' Name of the layer used. Generally speaking, a layer is a spatial dataset. It
#' can also be viewed as a database in some cases.
#' }
#' \item{\code{bands}:}{
#' The "fields" contained in \code{layer} that were used.
#' }
#' \item{\code{provide}:}{
#' The creator and/or provider of the layer.
#' }
#' \item{\code{version}:}{
#' The version of the layer, if any. Can be equal to \code{NA}.
#' }
#' \item{\code{location}:}{
#' The location of the layer. Typically, a file path, a directory or an object
#' name given as a character string. If it is the latter, it begins by the
#' namespace in which it can be found (\code{"glr::"}).
#' }
#' }
#'
#' @section S3 methods for objects of class \code{meta}:
#' \describe{
#' \item{\code{format}}{
#' Pretty printing of a \code{\link[glr:class-meta]{meta}} object. Most of the
#' time, only the \code{print} method should be used.
#' }
#' \item{\code{print}}{
#' Print the object in the console.
#' }
#' \item{\code{c} (combine)}{
#' Combine multiple objects of class \code{\link[glr:class-meta]{meta}}
#' together in a list.
#' }
#' }
#'
#' An object of class \code{\link[glr:class-meta]{meta}} is internally 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 meta class
#' @family glr classes
#'
#' @note This note is intended for developpers.
#'
#' For now, combining objects of class \code{\link[glr:class-meta]{meta}}
#' stored in lists is rather tricky, because R's S3 system cannot dispatch
#' methods based on combinations of classes (the so-called classes'
#' \emph{signatures} in the S4 system). Therefore, when concatenating a
#' \code{\link[glr:class-meta]{meta}} object with a list of other
#' \code{\link[glr:class-meta]{meta}} objects, you must first supply a
#' \code{\link[glr:class-meta]{meta}} object to \code{\link{c}} and
#' then, other lists. If order matters, you can use functions such as
#' \code{\link{rev}} on the output to obtain the appropriate order. For an
#' example, you can consult the source code of function \code{\link{apply_defs}}.
#'
#' @examples
#' # Create an object of class 'meta'.
#' info <- new_meta("useless values", NA, NA, NA, NA, NA, NA)
#'
#' # Create another object of class 'meta'.
#' info2 <- new_meta("useless values 2", "vector, points", "field 1",
#'                   NA, "coop", "v1", NA)
#'
#' # You can concatenate two objects of class 'meta' together. The result is
#' # a 'list' of objects of class 'meta'.
#' res <- c(info, info2)
#'
#' # Beware! The resulting list cannot be named.
#'
#' @export
new_meta <- function(output, format, layer, bands, provider, version, location,
                     ..., strict.length = FALSE, .subclass = NULL)
{
  out <- list(output, format, layer, bands, provider, version, location)
  nms <- c("output", "format", "layer", "bands",
           "provider", "version", "location")

  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)

  }

  if (strict.length) {

    len <- length(unique(lengths(out)))

    if (len > 1L) {
      stop("arguments do not have same length.", call. = FALSE)
    }

  }

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

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

#' @rdname class-meta
#' @export
format.meta <- function(x, ...)
{
  tol   <- 60L
  pd    <- 8L
  nms   <- names(x)
  nms   <- sapply(nms, .pad, pd)
  lenms <- seq_along(nms)

  for (i in lenms) {

    xi <- x[[i]]
    nmsxi <- names(xi)

    w <- nchar(xi) > tol
    xi[w] <- paste0(strtrim(xi[w], tol), " ...")

    cat("", nms[i], " : ")

    if (!is.null(nmsxi)) {

      lenxi <- seq_along(xi)

      for (j in lenxi) {
        cat(nmsxi[j], ": ", xi[j],
            if (j < max(lenxi)) ", ", sep = "")
      }

    } else {

      cat(xi, sep = ", ")

    }

    cat("\n")
  }

  invisible()
}

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

#' @rdname class-meta
#' @export
c.meta <- function(x, ...)
{
  objs <- flatten_list(list(x, ...))
  ok   <- all(sapply(objs, is.meta))

  if (!ok) {
    stop("some objects are not of class 'meta'.", call. = FALSE)
  }

  objs
}