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