R/check-fns.R

In osmplotr: Bespoke Images of 'OpenStreetMap' Data

check_map_arg <- function (map) {

    if (missing (map))
        stop ("a non-null map must be provided", call. = FALSE)
    if (!is (map, "ggplot"))
        stop ("map must be a ggplot2 object", call. = FALSE)
}

#' get type of geometry object from either sf or sp objects
#'
#' @note \code{sf} objects return singular nouns ('polygon', 'point'), while
#' \code{sp} return plurals ('polygons', 'points')
#'
#' @noRd
get_obj_type <- function (obj) {

    if (is (obj, "sf")) {

        if (!inherits(obj$geometry, "sfc"))
            warning("object class is sf, but the geometry column class is '",
                    toString(class(obj$geometry)),
                    "' instead of 'sfc'.\n",
                    "This can occur e.g. after subsetting sf objects ",
                    "without the sf package loaded.")
        i <- which (grepl ("sfc_", class (obj$geometry)))
        obj_type <- tolower (strsplit (class (obj$geometry) [i],
                                       "sfc_") [[1]] [2])
    } else {

        obj_type <- tolower (strsplit (strsplit (class (obj),
                                                 "Spatial") [[1]] [2],
                                       "DataFrame") [[1]] [1])
    }

    return (obj_type)
}


#' capitalise first letter of word
#'
#' @note does same as stringi::stri_trans_totitle
#'
#' @noRd
cap_first <- function (x) {

    paste0 (toupper (substring (x, 1, 1)), substring (x, 2, nchar (x)))
}

check_obj_arg <- function (obj) {

    if (missing (obj))
        stop ("obj must be provided", call. = FALSE)
    if (!(is (obj, "Spatial") | is (obj, "sf")))
        stop ("obj must be a spatial object", call. = FALSE)
}

check_col_arg <- function (col) {

    if (missing (col))
        stop ("a non-null col must be provided")

    # Note col2rbg (NA) = white
    tryCatch (
              col2rgb (col),
              error = function (e) {

                  e$message <-  paste0 ("Invalid colour: ", col)
                  stop (e)
              })
}

check_bbox_arg <- function (bbox) {

    if (missing (bbox))
        stop ("bbox must be provided")
    if (is (bbox, "sf")) { # sf obj submitted to osm_basemap

        if (is (bbox$geometry, "sfc_LINESTRING") |
            is (bbox$geometry, "sfc_POINT"))
            xy <- do.call (rbind, bbox$geometry)
        else if (is (bbox$geometry, "sfc_POLYGON"))
            xy <- do.call (rbind, lapply (bbox$geometry, function (i) i [[1]]))
        else if (is (bbox$geometry, "sfc_MULTIPOLYGON") |
                 is (bbox$geometry, "sfc_MULTILINESTRING"))
            xy <- do.call (rbind, lapply (bbox$geometry,
                                          function (i) i [[1]] [[1]]))
        bbox <- t (apply (xy, 2, range))
        rownames (bbox) <- c ("x", "y")
        colnames (bbox) <- c ("min", "max")
    }
    if (!is.numeric (bbox))
        stop ("bbox is not numeric")
    if (length (bbox) < 4)
        stop ("bbox must have length = 4")
    if (length (bbox) > 4) {

        warning ("bbox has length > 4; only first 4 elements will be used")
        bbox <- matrix (bbox [1:4], 2, 2)
    }

    return (bbox)
}

check_structures_arg <- function (structures) {

    if (!missing (structures)) {

        if (!is.data.frame (structures))
            stop ("structures must be a data frame")
        ns <- c ("structure", "key", "value", "suffix", "cols")
        if (!all (names (structures) == ns))
            stop ("structures not in recognised format")
    }
}

#' generic function to check argument conversion to given function type
#'
#' @noRd
check_arg <- function (arg, arg_name, fn_type, na_okay = FALSE) {

    if (missing (arg))
        stop (paste (arg_name, "must be provided"))
    else if (length (arg) == 0)
        stop (paste (arg_name, "can not be NULL"))
    else if (!na_okay & is.na (arg))
        stop (paste (arg_name, "can not be NA"))

    adj <- tryCatch (
                     do.call (paste0 ("as.", fn_type), list (arg)),
                     warning = function (w) {

                         w$message <- paste (arg_name,
                                              "can not be coerced to",
                                              fn_type)
                     })

    invisible (adj)
}