1 2#' Set and get vector CRS 3#' 4#' The wk package doesn't operate on CRS objects, but does propagate them 5#' through subsetting and concatenation. A CRS object can be any R object, 6#' and x can be any object whose 'crs' attribute carries a CRS. These functions 7#' are S3 generics to keep them from being used 8#' on objects that do not use this system of CRS propagation. 9#' 10#' @param x,... Objects whose "crs" attribute is used to carry a CRS. 11#' @param crs,value An object that can be interpreted as a CRS 12#' 13#' @export 14#' 15wk_crs <- function(x) { 16 UseMethod("wk_crs") 17} 18 19#' @rdname wk_crs 20#' @export 21wk_crs.wk_vctr <- function(x) { 22 attr(x, "crs", exact = TRUE) 23} 24 25#' @rdname wk_crs 26#' @export 27wk_crs.wk_rcrd <- function(x) { 28 attr(x, "crs", exact = TRUE) 29} 30 31#' @rdname wk_crs 32#' @export 33`wk_crs<-` <- function(x, value) { 34 wk_set_crs(x, value) 35} 36 37#' @rdname wk_crs 38#' @export 39wk_set_crs <- function(x, crs) { 40 UseMethod("wk_set_crs") 41} 42 43#' @export 44wk_set_crs.wk_vctr <- function(x, crs) { 45 attr(x, "crs") <- crs 46 x 47} 48 49#' @export 50wk_set_crs.wk_rcrd <- function(x, crs) { 51 attr(x, "crs") <- crs 52 x 53} 54 55#' @rdname wk_crs 56#' @export 57wk_crs_output <- function(...) { 58 dots <- list(...) 59 crs <- lapply(dots, wk_crs) 60 Reduce(wk_crs2, crs) 61} 62 63wk_crs2 <- function(x, y) { 64 if (inherits(y, "wk_crs_inherit")) { 65 x 66 } else if (inherits(x, "wk_crs_inherit")) { 67 y 68 } else if (wk_crs_equal(x, y)) { 69 x 70 } else { 71 stop(sprintf("CRS objects '%s' and '%s' are not equal.", format(x), format(y)), call. = FALSE) 72 } 73} 74 75#' Compare CRS objects 76#' 77#' The [wk_crs_equal()] function uses special S3 dispatch on [wk_crs_equal_generic()] 78#' to evaluate whether or not two CRS values can be considered equal. When implementing 79#' [wk_crs_equal_generic()], every attempt should be made to make `wk_crs_equal(x, y)` 80#' and `wk_crs_equal(y, x)` return identically. 81#' 82#' @param x,y Objects stored in the `crs` attribute of a vector. 83#' @param ... Unused 84#' 85#' @return `TRUE` if `x` and `y` can be considered equal, `FALSE` otherwise. 86#' @export 87#' 88wk_crs_equal <- function(x, y) { 89 if (is.object(y)) { 90 wk_crs_equal_generic(y, x) 91 } else { 92 wk_crs_equal_generic(x, y) 93 } 94} 95 96#' @rdname wk_crs_equal 97#' @export 98wk_crs_equal_generic <- function(x, y, ...) { 99 UseMethod("wk_crs_equal_generic") 100} 101 102#' @export 103wk_crs_equal_generic.default <- function(x, y, ...) { 104 identical(x, y) 105} 106 107#' @export 108wk_crs_equal_generic.integer <- function(x, y, ...) { 109 isTRUE(x == y) 110} 111 112#' @export 113wk_crs_equal_generic.double <- function(x, y, ...) { 114 isTRUE(x == y) 115} 116 117#' Special CRS values 118#' 119#' The CRS handling in the wk package requires two sentinel CRS values. 120#' The first, [wk_crs_inherit()], signals that the vector should inherit 121#' a CRS of another vector if combined. This is useful for empty, `NULL`, 122#' and/or zero-length geometries. The second, [wk_crs_auto()], is used 123#' as the default argument of `crs` for constructors so that zero-length 124#' geometries are assigned a CRS of `wk_crs_inherit()` by default. 125#' 126#' @param x A raw input to a construuctor whose length and crs attributte 127#' is used to determine the default CRS returned by [wk_crs_auto()]. 128#' @param crs A value for the coordinate reference system supplied by 129#' the user. 130#' 131#' @export 132#' 133#' @examples 134#' wk_crs_auto_value(list(), wk_crs_auto()) 135#' wk_crs_auto_value(list(), 1234) 136#' wk_crs_auto_value(list(NULL), wk_crs_auto()) 137#' 138wk_crs_inherit <- function() { 139 structure(list(), class = "wk_crs_inherit") 140} 141 142#' @rdname wk_crs_inherit 143#' @export 144wk_crs_auto <- function() { 145 structure(list(), class = "wk_crs_auto") 146} 147 148#' @rdname wk_crs_inherit 149#' @export 150wk_crs_auto_value <- function(x, crs) { 151 if (inherits(crs, "wk_crs_auto")) { 152 if (length(x) == 0) wk_crs_inherit() else attr(x, "crs", exact = TRUE) 153 } else { 154 crs 155 } 156} 157 158#' @export 159format.wk_crs_inherit <- function(x, ...) { 160 format("wk_crs_inherit()", ...) 161} 162 163#' @export 164print.wk_crs_inherit <- function(x, ...) { 165 cat("<wk_crs_inherit>\n") 166} 167