R/1geom.R

In EhrmannS/geometr: Generate and Modify Interoperable Geometric Objects

#' Geometry class (S4) and methods
#'
#' A \code{geom} stores a table of points, a table of feature to which the
#' points are associated and a table of groups, to which features are
#' associated. A \code{geom} can be spatial (if it has a coordinate reference
#' system assigned to it), but is not by default.
#'
#' A \code{geom} has one of three geometry types: \itemize{ \item
#' \code{"point"}, when none of the points are connected to other points, \item
#' \code{"line"}, where points with the same \code{fid} are connected following
#' the sequence of their order, without the line closing in itself and \item
#' \code{"polygon"}, where points with the same \code{fid} are connected
#' following the sequence of their order and the line closes in on itself due to
#' first and last point being the same. Moreover, \code{polygon} objects can
#' contain holes.}
#'
#' The data model for storing points follows the spaghetti model. Points are
#' stored as a sequence of x and y values, associated to a feature ID. The
#' feature ID relates coordinates to features and thus common attributes. Points
#' and Lines are implemented straightforward in this model, but polygons, which
#' may contain holes, are a bit trickier. In \code{geometr} they are implemented
#' as follows: \enumerate{ \item All points with the same \code{fid} make up one
#' polygon, irrespective of it containing holes or not. \item The outer
#' path/ring of a polygon is composed of all points until a duplicated of its
#' first point occurs. This signals that all following points are part of
#' another path/ring, which must be inside the outer path and which consists of
#' all points until a duplicate of it's first point occurs. \item This repeats
#' until all points of the feature are processed.}
#'
#' Moreover, a \code{geom} has a \emph{reference window}, which is sort of a
#' second extent that may be bigger (or smaller) than the extent and which
#' determines the relative position of the points when plotting.
#'
#' @slot type [character(1)][character]\cr the type of feature, either
#'   \code{"point"}, \code{"line"}, \code{"polygon"} or \code{"grid"}.
#' @slot geometry [data.frame(3)][data.frame]\cr the \code{fid} (feature ID),
#'   \code{x} and \code{y} coordinates per point and optional arbitrary point
#'   attributes.
#' @slot data [named list][list]\cr A list with the layer name and list elements
#'   \code{$features} and \code{$groups} containing the features and groups of
#'   that layer. \itemize{
#'     \item features: \code{fid} (feature ID), \code{gid} (group ID) and optional
#'       arbitrary feature attributes.
#'     \item groups: \code{gid} (group ID) and optional arbitrary group attributes.
#'   }
#' @param window [data.frame(2)][data.frame]\cr in case the reference window
#'   deviates from the bounding box of \code{crds}, specify here the minimum and
#'   maximum values in columns \code{x} and \code{y}.
#' @slot crs [character(1)][character]\cr the coordinate reference system in
#'   proj4 notation.
#' @slot provenance [list(.)][list]\cr a list of steps taken to derive the
#'   \code{geom} in focus.

geom <- setClass(Class = "geom",
                 slots = c(type = "character",
                           label = "character",
                           geometry = "data.frame",
                           data = "list",
                           window = "data.frame",
                           crs = "character",
                           provenance = "list"
                 )
)

setValidity("geom", function(object){

  errors = character()

  if(!.hasSlot(object = object, name = "type")){
    errors = c(errors, "the geom does not have a 'type' slot.")
  } else {
    if(!any(object@type %in% c("point", "line", "polygon", "grid"))){
      errors = c(errors, "the geom must either be of type 'point', 'line', 'polygon' or 'grid'.")
    } else if(object@type == "line"){
      if(dim(object@geometry)[1] < 2){
        errors = c(errors, "a geom of type 'line' must have at least 2 points.")
      }
    } else if(object@type == "polygon"){
      if(dim(object@geometry)[1] < 3){
        errors = c(errors, "a geom of type 'polygon' must have at least 3 points.")
      }
    } else if(object@type == "grid"){
      if(dim(object@geometry)[1] != 3){
        errors = c(errors, "a geom of type 'grid' must have three rows ('origin' and 'cell number' extent and 'cell size').")
      }
    }
  }

  if(!.hasSlot(object = object, name = "label")){
    errors = c(errors, "the geom does not have a 'label' slot.")
  } else {
    if(!is.character(object@label)){
      errors = c(errors, "the slot 'label' is not a character.")
    }
  }

  if(!.hasSlot(object = object, name = "geometry")){
    errors = c(errors, "the geom does not have a 'geometry' slot.")
  } else {
    if(!is.data.frame(object@geometry)){
      errors = c(errors, "the slot 'geometry' is not a data.frame.")
    }
    if(object@type == "grid"){
      if(!all(c("x" ,"y") %in% names(object@geometry))){
        errors = c(errors, "the geom must have a grid table with the columns 'x' and 'y'.")
      }
    } else {
      if(!all(c("fid", "x" ,"y") %in% names(object@geometry))){
        errors = c(errors, "the geom must have a geometry table with the columns 'x', 'y' and 'fid'.")
      }
    }
  }

  if(!.hasSlot(object = object, name = "data")){
    errors = c(errors, "the geom does not have a 'data' slot.")
  } else {
    if(!is.list(object@data)){
      errors = c(errors, "the slot 'data' is not a list.")
    }

  }

  if(!.hasSlot(object = object, name = "window")){
    errors = c(errors, "the geom does not have a 'window' slot.")
  } else {
    if(!is.data.frame(object@window)){
      errors = c(errors, "the slot 'window' is not a data.frame.")
    }
    if(!all(c("x" ,"y") %in% names(object@window))){
      errors = c(errors, "the geom must have a window table with columns 'x' and 'y'.")
    }
  }

  if(!.hasSlot(object = object, name = "crs")){
    errors = c(errors, "the geom does not have a 'crs' slot.")
  } else {
    if(!is.character(object@crs)){
      errors = c(errors, "the slot 'crs' is not a character vector.")
    }
  }

  if(!.hasSlot(object = object, name = "provenance")){
    errors = c(errors, "the geom does not have a 'provenance' slot.")
  } else {
    if(!is.list(object@provenance)){
      errors = c(errors, "the slot 'provenance' is not a list.")
    }
  }

  if(length(errors) == 0){
    return(TRUE)
  } else {
    return(errors)
  }

})

#' Print geom in the console
#'
#' @param object [gridded(1)][geom]\cr object to \code{show}.
#' @importFrom geomio getPoints getFeatures getGroups getRes getExtent
#' @importFrom utils head
#' @importFrom crayon yellow red cyan

setMethod(f = "show",
          signature = "geom",
          definition = function(object){

            theType <- object@type
            thePoints <- getPoints(x = object)
            theFeatures <- getFeatures(x = object)
            theGroups <- getGroups(x = object)

            vertAttribs <- length(thePoints)
            featureAttribs <- names(theFeatures)[!names(theFeatures) %in% c("fid")]
            groupAttribs <- names(theGroups)[!names(theGroups) %in% c("gid")]

            myAttributes <- NULL
            points <- feats <- groups <- FALSE

            if(is.na(object@crs)){
              myCrs <- "cartesian"
            } else {
              myCrs <- object@crs
            }

            if(theType == "grid"){
              theFeats <- featureAttribs
              theLayer <- theGroups
              if(!is.null(theLayer)){
                if(!all(names(thePoints) %in% c("gid"))){
                  myAttributes <- c(myAttributes, paste0(" ", ifelse(length(groupAttribs) == 0,
                                                                     paste0("--\n"),
                                                                     ifelse(length(groupAttribs) <= 9,
                                                                            paste0(paste0(groupAttribs, collapse = ", "), "\n"),
                                                                            paste0(paste0(c(head(groupAttribs, 9), "..."), collapse = ", "), "\n"))
                  )))
                }
              }

              if(length(unique(groupAttribs)) == 1){
                myFeat <- "layer"
              } else {
                myFeat <- "layers"
              }
              myUnits <- "cells"
              geomGroups <- ""

            } else {
              theGrps <- theGroups$gid
              if(length(unique(theGrps)) == 1){
                myGrp <- "group"
              } else {
                myGrp <- "groups"
              }
              theFeats <- theFeatures$fid
              featureAttribs <- featureAttribs[-which(featureAttribs == "gid")]
              if(length(unique(theFeats)) == 1){
                myFeat <- "feature"
              } else {
                myFeat <- "features"
              }
              myUnits <- "points"
              geomGroups <- paste0(length(unique(theGrps)), " ", myGrp, " | ")

              if(!all(names(thePoints) %in% c("x", "y", "fid"))){
                myAttributes <- c(myAttributes, paste0(" (points) ",
                                                       ifelse(vertAttribs <= 9,
                                                              paste0(paste0(names(thePoints)[!names(thePoints) %in% c("x", "y", "fid")], collapse = ", "), "\n"),
                                                              paste0(paste0(c(head(names(thePoints)[!names(thePoints) %in% c("x", "y", "fid")], 9), "..."), collapse = ", "), "\n")
                                                       )))
                points <- TRUE
              }
              if(!all(names(theFeatures) %in% c("fid", "gid"))){
                if(points){
                  featureString <- "           (features) "
                } else {
                  featureString <- " (features) "
                }
                myAttributes <- c(myAttributes, paste0(featureString,
                                                       ifelse(length(featureAttribs) <= 9,
                                                              paste0(paste0(featureAttribs, collapse = ", "), "\n"),
                                                              paste0(paste0(c(head(featureAttribs, 9), "..."), collapse = ", "), "\n")
                                                       )))
                feats <- TRUE
              }
              if(!all(names(theGroups) %in% c("gid"))){
                if(feats | points){
                  groupString <- "            (groups) "
                } else {
                  groupString <- " (groups) "
                }
                myAttributes <- c(myAttributes, paste0(groupString,
                                                       ifelse(length(groupAttribs) <= 9,
                                                              paste0(paste0(names(theGroups)[!names(theGroups) %in% c("gid")], collapse = ", "), "\n"),
                                                              paste0(paste0(c(head(names(theGroups)[!names(theGroups) %in% c("gid")], 9), "..."), collapse = ", "), "\n")
                                                       )))
              }
            }
            if(is.null(myAttributes)){
              myAttributes <- " --\n"
            }


            cat(yellow(class(object)), "        ", object@type, "\n", sep = "")
            cat("            ", geomGroups, length(unique(theFeats)), " ", myFeat, " | ", length(thePoints$fid), " ", myUnits, "\n", sep = "")
            cat(yellow("crs         "), myCrs, "\n", sep = "")
            cat(yellow("layers     "), myAttributes, sep = "")
            if(!theType == "grid"){
              # make a tiny map
              tinyMap <- .makeTinyMap(geom = object)
              cat(yellow("tiny map  "), tinyMap)
            } else {
              theRes <- getRes(object)
              theExt <- getExtent(object)
              cat(yellow("resolution "), as.numeric(theRes), "(x, y)\n")
              cat(yellow("extent     "), c(theExt$x, theExt$y), "(xmin, xmax, ymin, ymax)")
            }
          }
)