R/Geocodes-class.R

In jeanmathieupotvin/scr: Spatial scoring algorithms :: scorer

# Class Geocodes: store and manipulate spatial coordinates ---------------------

# Virtual class NullNumChar ----------------------------------------------------
# Used to allow flexibility in slot keys of class Geocodes.

setClassUnion("NullNumChar", c("NULL", "numeric", "character"))

# Definition -------------------------------------------------------------------

setClass("Geocodes",
         slots = list(
             coords = "data.table",
             keys   = "NullNumChar",
             crs    = "CRS"),
         prototype = list(
             coords = data.table(x = numeric(),
                                 y = numeric()),
             keys   = NULL,
             crs    = new("CRS", projargs = NA_character_)))

# Validator --------------------------------------------------------------------

.validGeocodes.coords <- function(coords)
{
    txt <- character(2L)

    if (ncol(coords) > 2L) {
        txt[1L] <- "@coords must contain two fields only."
    }

    if (!identical(names(coords)[1L], "x") ||
        !identical(names(coords)[2L], "y")) {
        txt[2L] <- "@coords names must be c('x', 'y')."
    }

    txt
}

.validGeocodes.keys <- function(keys, n.coords)
{
    txt <- character(2L)

    if (!is.null(keys)) {
        if (!identical(n.coords, length(keys))) {
            txt[1L] <- "@keys length must be equal to @coords rows."
        }

        if (!identical(length(unique(keys)),
                       length(keys))) {
            txt[2L] <- "@keys elements must be unique."
        }
    }

    txt
}

.validGeocodes.crs <- function(crs)
{
    .validCRS(crs)
}

.validGeocodes <- function(object)
{
    txt <- c(.validGeocodes.coords(object@coords),
             .validGeocodes.keys(object@keys,
                                 NROW(object@coords)),
             .validGeocodes.crs(object@crs))

    txt <- txt[nchar(txt) > 0L]

    if (length(txt)) {
        res <- txt
    } else {
        res <- TRUE
    }

    res
}

setValidity("Geocodes", .validGeocodes)

# Constructor ------------------------------------------------------------------

Geocodes <- function(coords, keys, crs)
{
    if (!is.data.table(coords)) {
        coords <- as.data.table(coords)
    }

    methods::new("Geocodes", coords, keys, crs)
}

# Helpers and lambda functions -------------------------------------------------

.validCRS <- function(crs)
{
    if (!is.na(crs@projargs) &&
        !checkCRSArgs(crs@projargs)[[1L]]) {
        txt <- "@crs must contain a PROJ.4 recognizable CRS. See ?sp::CRS-class."
    } else {
        txt <- ""
    }

    txt
}

# Tests ------------------------------------------------------------------------

getClass("Geocodes")
new("Geocodes", coords = data.table(a = 1, y = 2, z = 3),
    keys = c("lol", "lol"), crs = CRS("+init=epsg:4", FALSE))
new("Geocodes", coords = data.table(x = c(1, 2), y = c(3, 4)),
    keys = c("R1", "R2"), crs = CRS("+init=epsg:4326"))