Nothing
#' Mark lists of raw vectors as well-known binary
#'
#' @param x A [list()] of [raw()] vectors or `NULL`.
#' @inheritParams new_wk_wkb
#' @param ... Unused
#'
#' @return A [new_wk_wkb()]
#' @export
#'
#' @examples
#' as_wkb("POINT (20 10)")
#'
wkb <- function(x = list(), crs = wk_crs_auto(), geodesic = FALSE) {
crs <- wk_crs_auto_value(x, crs)
attributes(x) <- NULL
wkb <- new_wk_wkb(x, crs = crs, geodesic = geodesic_attr(geodesic))
validate_wk_wkb(wkb)
wkb
}
#' @rdname wkb
#' @export
parse_wkb <- function(x, crs = wk_crs_auto(), geodesic = FALSE) {
crs <- wk_crs_auto_value(x, crs)
attributes(x) <- NULL
wkb <- new_wk_wkb(x, crs = crs, geodesic = geodesic_attr(geodesic))
parse_base(wkb, wk_problems(wkb))
}
#' @rdname wkb
#' @export
wk_platform_endian <- function() {
match(.Platform$endian, c("big", "little")) - 1L
}
#' @rdname wkb
#' @export
as_wkb <- function(x, ...) {
UseMethod("as_wkb")
}
#' @rdname wkb
#' @export
as_wkb.default <- function(x, ...) {
wk_translate(
x,
new_wk_wkb(crs = wk_crs_inherit(), geodesic = wk_geodesic_inherit()),
...
)
}
#' @rdname wkb
#' @export
as_wkb.character <- function(x, ..., crs = NULL, geodesic = FALSE) {
as_wkb(wkt(x, crs = crs, geodesic = geodesic), ...)
}
#' @rdname wkb
#' @export
as_wkb.wk_wkb <- function(x, ...) {
x
}
#' @rdname wkb
#' @export
as_wkb.blob <- function(x, ..., crs = NULL, geodesic = FALSE) {
as_wkb(wkb(x, crs = crs, geodesic = geodesic), ...)
}
#' @rdname wkb
#' @export
as_wkb.WKB <- function(x, ..., crs = NULL, geodesic = FALSE) {
as_wkb(wkb(x, crs = crs, geodesic = geodesic), ...)
}
#' S3 Details for wk_wkb
#'
#' @param x A (possibly) [wkb()] vector
#' @param crs A value to be propagated as the CRS for this vector.
#' @inheritParams wk_is_geodesic
#'
#' @export
#'
new_wk_wkb <- function(x = list(), crs = NULL, geodesic = NULL) {
if (typeof(x) != "list" || !is.null(attributes(x))) {
stop("wkb input must be a list without attributes", call. = FALSE)
}
structure(x, class = c("wk_wkb", "wk_vctr"), crs = crs, geodesic = geodesic)
}
#' @rdname new_wk_wkb
#' @export
validate_wk_wkb <- function(x) {
if (typeof(x) != "list") {
stop("wkb() must be of type list()", call. = FALSE)
}
good_types <- .Call(wk_c_wkb_is_raw_or_null, x)
if (!all(good_types)) {
stop("items in wkb input must be raw() or NULL", call. = FALSE)
}
if (!inherits(x, "wk_wkb") || !inherits(x, "wk_vctr")) {
attributes(x) <- NULL
problems <- wk_problems(new_wk_wkb(x))
} else {
problems <- wk_problems(x)
}
stop_for_problems(problems)
invisible(x)
}
#' @rdname new_wk_wkb
#' @export
is_wk_wkb <- function(x) {
inherits(x, "wk_wkb")
}
#' @export
`[<-.wk_wkb` <- function(x, i, value) {
replacement <- as_wkb(value)
crs_out <- wk_crs_output(x, replacement)
geodesic_out <- wk_is_geodesic_output(x, replacement)
x <- unclass(x)
x[i] <- replacement
attr(x, "crs") <- NULL
attr(x, "geodesic") <- NULL
new_wk_wkb(x, crs = crs_out, geodesic = geodesic_attr(geodesic_out))
}
#' @export
is.na.wk_wkb <- function(x) {
.Call(wk_c_wkb_is_na, x)
}
#' @export
format.wk_wkb <- function(x, ...) {
paste0("<", wk_format(x), ">")
}
# as far as I can tell, this is the only way to change
# how the object appears in the viewer
#' @export
as.character.wk_wkb <- function(x, ...) {
format(x, ...)
}
#' Convert well-known binary to hex
#'
#' @param x A [wkb()] vector
#'
#' @return A hex encoded [wkb()] vector
#' @export
#'
#' @examples
#' x <- as_wkb(xyz(1:5, 6:10, 11:15))
#' wkb_to_hex(x)
#'
wkb_to_hex <- function(x) {
.Call(wk_c_wkb_to_hex, as_wkb(x))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.