R/class_geocontainer.R

In jeanmathieupotvin/cargo: Data containers, schemas and prototypes

# class_geocontainer.R


#' @include globals.R
#' @include internals.R
#' @include class_prototype.R
#' @include class_schema.R
#' @include class_container.R


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


#' @rdname class_geocontainer
#' @template class_geocontainer
#' @template class_container_slots
#' @template class_geocontainer_slots
methods::setClass("GeoContainer",
    contains = "Container",
    slots = c(
        xcol = "character",
        ycol = "character",
        crs  = "CRS"
    ),
    prototype = list(
        xcol = character(),
        ycol = character(),
        crs  = sp::CRS()
    )
)


# Constructors -----------------------------------------------------------------


#' @rdname class_geocontainer
#' @template class_geocontainer_constructor
#' @aliases GeoContainer
#' @export
methods::setGeneric("GeoContainer", function(x, ...)
{
    standardGeneric("GeoContainer")
})


#' @rdname class_geocontainer
#' @export
methods::setMethod("GeoContainer",
    signature  = signature(x = "missing"),
    definition = function(
        x,
        schema = Schema(),
        xcol   = character(),
        ycol   = character(),
        crs    = sp::CRS(),
        ...)
{
    return(.new_geocontainer(data.table::data.table(), schema, xcol, ycol, crs))
})


#' @rdname class_geocontainer
#' @export
methods::setMethod("GeoContainer",
    signature  = signature(x = "character"),
    definition = function(
        x,
        schema = Schema(),
        xcol   = character(),
        ycol   = character(),
        crs    = sp::CRS(),
        ...)
{
    return(.new_geocontainer(safe_read_csv(x, ...), schema, xcol, ycol, crs))
})


#' @rdname class_geocontainer
#' @export
methods::setMethod("GeoContainer",
    signature  = signature(x = "data.frame"),
    definition = function(
        x,
        schema = Schema(),
        xcol   = character(),
        ycol   = character(),
        crs    = sp::CRS(),
        ...)
{
    return(
        .new_geocontainer(
            data.table::as.data.table(x, ...), schema, xcol, ycol, crs
        )
    )
})


#' @rdname class_geocontainer
#' @export
methods::setMethod("GeoContainer",
    signature  = signature(x = "data.table"),
    definition = function(
        x,
        schema = Schema(),
        xcol   = character(),
        ycol   = character(),
        crs    = sp::CRS(),
        ...)
{
    return(.new_geocontainer(x, schema, xcol, ycol, crs))
})


#' @rdname class_geocontainer
#' @export
methods::setMethod("GeoContainer",
    signature  = signature(x = "Schema"),
    definition = function(
        x,
        schema = Schema(),
        xcol   = character(),
        ycol   = character(),
        crs    = sp::CRS(),
        ...)
{
    if (!missing(schema)) {
        warning("Schema objects passed to both 'x' and 'schema'.",
                " The latter was ignored.", call. = FALSE)
    }
    return(
        .new_geocontainer(data.table::as.data.table(x, ...), x, xcol, ycol, crs)
    )
})


.new_geocontainer <- function(table, schema, xcol, ycol, crs)
{
    if (is.numeric(crs) && is.character(crs <- .parse_epsg(crs[[1L]]))) {
        stop(crs, call. = FALSE)
    }

    return(
        methods::new("GeoContainer",
            table  = table,
            schema = schema,
            xcol   = xcol[[1L]],
            ycol   = ycol[[1L]],
            crs    = crs
        )
    )
}


# Validators -------------------------------------------------------------------


#' @rdname class_geocontainer_validators
#' @template class_geocontainer_validators
#' @aliases valid_geocontainer
#' @export
valid_geocontainer <- function(x)
{
    if (!is_geocontainer(x)) {
        stop("'x' is not a GeoContainer object.", call. = FALSE)
    }

    return(methods::validObject(x))
}


#' @rdname class_geocontainer_validators
#' @export
.valid_geocontainer <- function(object)
{
    nt <- names(object@table)
    ns <- object@schema@inputs

    txt1 <- if (is.na(match(object@xcol, nt)) ||
                is.na(match(object@xcol, ns))) {
        "@xcol must be an element of both @table and @schema."
    }
    txt2 <- if (is.na(match(object@ycol, nt)) ||
                is.na(match(object@ycol, ns))) {
        "@ycol must be an element of both @table and @schema."
    }
    txt3 <- if (!.valid_crs(object@crs)) {
        "@crs must be a recognized CRS by PROJ.4 projection system."
    }

    return(c(txt1, txt2, txt3))
}


methods::setValidity("GeoContainer", method = function(object)
{
    txt <- .valid_geocontainer(object)
    return(if (is.null(txt)) TRUE else txt)
})


# Accessors --------------------------------------------------------------------


#' @rdname class_geocontainer_accessors
#' @template class_geocontainer_accessors
#' @aliases crs
#' @export
methods::setGeneric("crs", function(x)
{
    standardGeneric("crs")
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setGeneric("xcol", function(x)
{
    standardGeneric("xcol")
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setGeneric("ycol", function(x)
{
    standardGeneric("ycol")
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setGeneric("xy", function(x, ...)
{
    standardGeneric("xy")
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setGeneric("crs<-", function(x, value)
{
    standardGeneric("crs<-")
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setGeneric("xcol<-", function(x, value)
{
    standardGeneric("xcol<-")
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setGeneric("ycol<-", function(x, value)
{
    standardGeneric("ycol<-")
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("crs",
    signature  = signature(x = "GeoContainer"),
    definition = function(x) return(x@crs)
)


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("xcol",
    signature  = signature(x = "GeoContainer"),
    definition = function(x) return(x@xcol)
)


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("ycol",
    signature  = signature(x = "GeoContainer"),
    definition = function(x) return(x@ycol)
)


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("xy",
    signature  = signature(x = "GeoContainer"),
    definition = function(x, simplify = TRUE)
{
    if (!is.logical(simplify)) {
        stop("'simplify' must be a logical.", call. = FALSE)
    }
    if (simplify) {
        vals <- c(x[[x@xcol]], x[[x@ycol]])
        return(matrix(vals, nrow(x), 2L, FALSE, list(NULL, c(x@xcol, x@ycol))))
    } else {
        return(x@table[, c(x@xcol, x@ycol), with = FALSE])
    }
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("crs<-",
    signature = signature(
        x     = "GeoContainer",
        value = "CRS"),
    definition = function(x, value)
{
    x@crs <- value
    methods::validObject(x)
    return(invisible(x))
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("crs<-",
    signature = signature(
        x     = "GeoContainer",
        value = "numeric"),
    definition = function(x, value)
{
    if (is.character(value <- .parse_epsg(value))) {
        stop(value, call. = FALSE)
    }

    x@crs <- value
    methods::validObject(x)
    return(invisible(x))
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("xcol<-",
    signature = signature(
        x     = "GeoContainer",
        value = "character"),
    definition = function(x, value)
{
    value <- value[[1L]]
    ipos  <- match(x@xcol, x@schema@inputs, 0L)
    tpos  <- match(x@xcol, names(x@table), 0L)

    if (ipos > 0L && tpos > 0L) {
        data.table::setnames(x@table, tpos, value, FALSE)
        x@schema@inputs[[ipos]] <- value
        x@xcol <- value
    } else if (ipos == 0L) {
        stop("@xcol was not found in @schema inputs.", call. = FALSE)
    } else if (tpos == 0L) {
        stop("@xcol was not found in @table column names.", call. = FALSE)
    }

    methods::validObject(x)
    return(invisible(x))
})


#' @rdname class_geocontainer_accessors
#' @export
methods::setMethod("ycol<-",
    signature = signature(
        x     = "GeoContainer",
        value = "character"),
    definition = function(x, value)
{
    value <- value[[1L]]
    ipos  <- match(x@ycol, x@schema@inputs, 0L)
    tpos  <- match(x@ycol, names(x@table), 0L)

    if (ipos > 0L && tpos > 0L) {
        data.table::setnames(x@table, tpos, value, FALSE)
        x@schema@inputs[[ipos]] <- value
        x@ycol <- value
    } else if (ipos == 0L) {
        stop("@ycol was not found in @schema inputs.", call. = FALSE)
    } else if (tpos == 0L) {
        stop("@ycol was not found in @table column names.", call. = FALSE)
    }

    methods::validObject(x)
    return(invisible(x))
})


# Introspector -----------------------------------------------------------------


#' @rdname class_geocontainer_is
#' @template class_geocontainer_is
#' @export
is_geocontainer <- function(x)
{
    return(methods::is(x, "GeoContainer"))
}


# Show -------------------------------------------------------------------------


#' @rdname class_geocontainer
#' @template class_geocontainer_show
#' @aliases show,GeoContainer-method
#' @export
methods::setMethod("show",
    signature  = signature(object = "GeoContainer"),
    definition = function(object)
{
    cat(sprintf("An object of S4 class %s.\n", class(object)[[1L]]),
        "--- CRS ---------------------------\n",
        sprintf("> %s\n", format(object@crs)),
        "--- Coordinates -------------------\n",
        sprintf("> xcol  %s\n", object@xcol),
        sprintf("> ycol  %s\n", object@ycol),
        "--- Schema ------------------------\n", format(object@schema),
        "--- Table (head only) -------------\n",
        sep = ""
    )
    print(utils::head(object@table),
          class      = TRUE,
          row.names  = FALSE,
          col.names  = "top",
          print.keys = FALSE)

    return(invisible())
})