R/class_crs_methods.R

In jeanmathieupotvin/cargo: Data containers, schemas and prototypes

# class_s4_crs_methods.R


#' @include internals.R


#' @rdname class_crs_methods
#' @template class_crs_methods
#' @aliases identical_crs
#' @export
methods::setGeneric("identical_crs", function(x, y, ...)
{
    standardGeneric("identical_crs")
})


#' @rdname class_crs_methods
#' @export
format.CRS <- function(x, ...)
{
    if (inherits(x, "CRS", TRUE) != 1L) {
        stop("'x' is not of class CRS.", call. = FALSE)
    }

    if (is.na(x@projargs)) {
        return("Empty")
    } else {
        projargs_split <- data.table::tstrsplit(
            data.table::tstrsplit(x@projargs, split = " "),
            split = "="
        )

        projargs_list <- as.list(projargs_split[[2L]])
        names(projargs_list) <- substring(projargs_split[[1L]], 2L)

        return(
            sprintf("%s  %s", .strpad(names(projargs_list)), projargs_list)
        )
    }
}


#' @rdname class_crs_methods
#' @export
methods::setMethod("show",
    signature  = signature(object = "CRS"),
    definition = function(object)
{
    cat(sprintf("An object of S4 class %s.\n", class(object)[[1L]]),
        sprintf("> %s\n", format(object)), sep = "")
    return(invisible())
})


#' @rdname class_crs_methods
#' @export
methods::setMethod("identical_crs",
    signature  = signature(x = "CRS", y = "CRS"),
    definition = function (x, y, ...)
{
    argsx <- strsplit(x@projargs, " +")[[1L]]
    argsy <- strsplit(y@projargs, " +")[[1L]]
    return(as.logical(data.table::chmatch(argsx, argsy, 0L)))
})