R/internals.R

In jeanmathieupotvin/cargo: Data containers, schemas and prototypes

# internals.R


#' @include globals.R


# Connections ------------------------------------------------------------------


# Source: tools::file_ext(). Redefined here to avoid importing this package.
.file_ext <- function (path)
{
    pos <- regexpr("\\.([[:alnum:]]+)$", path)
    return(if (pos > -1L) substring(path, pos + 1L) else NULL)
}


# Strings ----------------------------------------------------------------------


.collapse <- function(..., collapse = "\n")
{
    return(paste0(..., collapse = collapse))
}


.strpad <- function(x, pad = " ")
{
    return(sprintf("%s%s", x, strrep(pad, max(nchar(x)) - nchar(x))))
}


# Introspectors ----------------------------------------------------------------


.is_scalar <- function(x)
{
    if (length(x) != 1L || is.recursive(x) || is.null(x) || is.nan(x)) {
        return(FALSE)
    } else {
        return(TRUE)
    }
}


.is_not_unique <- function(x)
{
    return(length(x) != 0L && any(x != x[[1L]]))
}


# Shortcuts --------------------------------------------------------------------


.vapply1c <- function (x, fun, ..., use.names = FALSE)
{
    return(
        vapply(X = x, FUN = fun, ...,
               FUN.VALUE = NA_character_,
               USE.NAMES = use.names)
    )
}


.vapply1b <- function (x, fun, ..., use.names = FALSE)
{
    return(
        vapply(X = x, FUN = fun, ...,
               FUN.VALUE = NA,
               USE.NAMES = use.names)
    )
}


# Vectorized functions ---------------------------------------------------------


.vclass <- function(x)
{
    .local <- function(x) class(x)[[1L]]

    if (isS4(x) || is.atomic(x)) {
        return(.local(x))
    } else {
        return(.vapply1c(x, .local))
    }
}


# Coercions --------------------------------------------------------------------


.chr_to_ns <- function(x, s = "enclosure")
{
    if (requireNamespace(x, quietly = TRUE)) {
        return(getNamespace(x))
    } else {
        stop(sprintf("@%s is a non-existent package.", s),
             call. = FALSE)
    }
}


# Metaprogrammation  -----------------------------------------------------------


.as_ptype_call <- function(env, fun, ...)
{
    if (is.null(.local <- get0(fun, env, "function", FALSE, NULL))) {
        stop("@constructor cannot be found in @enclosure.",
             call. = FALSE)
    }

    out <- tryCatch(
        expr    = do.call(.local, list(...)),
        error   = function(cond) return(cond),
        warning = function(cond) return(cond)
    )

    if (inherits(out, "error")) {
        stop("@constructor could not be evaluated and returned ",
             " error(s) instead:\n  -> ",
             .collapse(conditionMessage(out), collapse = "\n  -> "),
             call. = FALSE)
    }
    if (isNamespace(env)) {
        op   <- "::"
        envn <- getNamespaceName(env)
    } else {
        op   <- "$"
        envn <- deparse(substitute(env))
    }

    return(as.call(list(str2lang(sprintf("%s%s%s", envn, op, fun)), ...)))
}


.str2call <- function(s)
{
    return(as.call(str2lang(s)))
}


# Spatial ----------------------------------------------------------------------


.parse_epsg <- function(x)
{
    if (is.null(x)) return(NULL)

    x <- suppressWarnings(as.integer(x[[1L]]))

    if (length(x) && is.integer(x) && !is.na(x)) {
        uprojargs <- sprintf("+init=epsg:%i", x)
        projargs  <- rgdal::checkCRSArgs(uprojargs)

        if (projargs[[1L]]) {
            methods::new("CRS", projargs = projargs[[2L]])
        } else {
            return("@crs is not a recognized epsg code by PROJ.4 projection system.")
        }
    } else {
        return("@crs cannot be coerced to an object of class sp::CRS.")
    }
}


.valid_crs <- function(x)
{
    if (!inherits(x, "CRS")) {
        return(FALSE)
    } else {
        return(rgdal::checkCRSArgs(x@projargs)[[1L]])
    }
}