1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
#' @name st_m_range
#' @param x object of class \code{m_range}
#' @export
is.na.m_range = function(x) identical(x, NA_m_range_)
mb_wrap = function(mb) {
stopifnot(is.numeric(mb) && length(mb) == 2)
structure(mb, names = c("mmin", "mmax"), class = "m_range")
}
m_range.Set = function(obj, ...) {
sel = vapply(obj, function(x) { length(x) && !all(is.na(x)) }, TRUE)
if (! any(sel))
NA_m_range_
else
mb_wrap(CPL_get_m_range(unclass(obj)[sel], 0))
}
m_range.Mtrx = function(obj, ...) {
if (length(obj) == 0)
NA_m_range_
else
mb_wrap(CPL_get_m_range(list(obj), 1)) # note the list()
}
m_range.MtrxSet = function(obj, ...) {
if (length(obj) == 0)
NA_m_range_
else
mb_wrap(CPL_get_m_range(obj, 1))
}
m_range.MtrxSetSet = function(obj, ...) {
if (length(obj) == 0)
NA_m_range_
else
mb_wrap(CPL_get_m_range(obj, 2))
}
m_range.MtrxSetSetSet = function(obj, ...) {
if (length(obj) == 0)
NA_m_range_
else
mb_wrap(CPL_get_m_range(obj, 3))
}
#' Return 'm' range of a simple feature or simple feature set
#'
#' Return 'm' range of a simple feature or simple feature set
#' @param obj object to compute the m range from
#' @param ... ignored
#' @export
#' @return a numeric vector of length two, with \code{mmin} and \code{mmax} values;
#' if \code{obj} is of class \code{sf} or \code{sfc} the object
#' if \code{obj} is of class \code{sf} or \code{sfc} the object
#' returned has a class \code{m_range}
#' @name st_m_range
#' @examples
#' a = st_sf(a = 1:2, geom = st_sfc(st_point(0:3), st_point(1:4)), crs = 4326)
#' st_m_range(a)
st_m_range = function(obj, ...) UseMethod("st_m_range")
#' @export
#' @name st_m_range
st_m_range.POINT = function(obj, ...) mb_wrap(c(obj[3L], obj[3L]))
#' @export
#' @name st_m_range
st_m_range.MULTIPOINT = m_range.Mtrx
#' @export
#' @name st_m_range
st_m_range.LINESTRING = m_range.Mtrx
#' @export
#' @name st_m_range
st_m_range.POLYGON = m_range.MtrxSet
#' @export
#' @name st_m_range
st_m_range.MULTILINESTRING = m_range.MtrxSet
#' @export
#' @name st_m_range
st_m_range.MULTIPOLYGON = m_range.MtrxSetSet
m_range_list = function(obj, ...) {
s = vapply(obj, st_m_range, c(0.,0.)) # dispatch on class
if (length(s) == 0 || all(is.na(s[1L,])))
NA_m_range_
else
mb_wrap(c(min(s[1L,], na.rm = TRUE), max(s[2L,], na.rm = TRUE)))
}
#' @name st_m_range
#' @export
st_m_range.GEOMETRYCOLLECTION = m_range_list
#' @name st_m_range
#' @export
st_m_range.MULTISURFACE = m_range_list
#' @name st_m_range
#' @export
st_m_range.MULTICURVE = m_range_list
#' @name st_m_range
#' @export
st_m_range.CURVEPOLYGON = m_range_list
#' @name st_m_range
#' @export
st_m_range.COMPOUNDCURVE = m_range_list
#' @name st_m_range
#' @export
st_m_range.POLYHEDRALSURFACE = m_range.MtrxSetSet
#' @name st_m_range
#' @export
st_m_range.TIN = m_range.MtrxSetSet
#' @name st_m_range
#' @export
st_m_range.TRIANGLE = m_range.MtrxSet
#' @name st_m_range
#' @export
st_m_range.CIRCULARSTRING = function(obj, ...) {
# this is of course wrong:
st_m_range(st_cast(obj, "LINESTRING")) # nocov
}
#' @export
print.m_range = function(x, ...) {
x = structure(x, crs = NULL, class = NULL) # nocov
print(set_units(x, attr(x, "units"), mode = "standard")) # nocov
}
compute_m_range = function(obj) {
switch(class(obj)[1],
sfc_POINT = mb_wrap(m_range.Set(obj)),
sfc_MULTIPOINT = mb_wrap(m_range.MtrxSet(obj)),
sfc_LINESTRING = mb_wrap(m_range.MtrxSet(obj)),
sfc_POLYGON = mb_wrap(m_range.MtrxSetSet(obj)),
sfc_MULTILINESTRING = mb_wrap(m_range.MtrxSetSet(obj)),
sfc_MULTIPOLYGON = mb_wrap(m_range.MtrxSetSetSet(obj)),
m_range_list(obj)
)
}
#' @name st_m_range
#' @export
st_m_range.sfc = function(obj, ...) {
a = attr(obj, "m_range")
if(is.null(a)) return( NULL ) ## TODO return null?
structure(a, crs = st_crs(obj))
}
#' @name st_m_range
#' @export
st_m_range.sf = function(obj, ...) st_m_range(st_geometry(obj))
#' @name st_m_range
#' @param crs object of class \code{crs}, or argument to \link{st_crs}, specifying the CRS of this bounding box.
#' @examples
#' st_m_range(c(mmin = 16.1, mmax = 16.6), crs = st_crs(4326))
#' @export
st_m_range.numeric = function(obj, ..., crs = NA_crs_) {
structure(mb_wrap(obj[c("mmin", "mmax")]), crs = st_crs(crs)) # nocov
}
#' @export
st_m_range.m_range = function(obj, ...) obj # nocov
#' @export
"$.m_range" = function(x, name) { # nocov start
switch(name,
mmin = x["mmin"],
mmax = x["mmax"],
stop("unsupported name")
)
} # nocov end
#' @name st_m_range
#' @details \code{NA_m_range_} represents the missing value for a \code{m_range} object
#' @export
NA_m_range_ = structure(rep(NA_real_, 2),
names = c("mmin", "mmax"),
crs = NA_crs_,
class = "m_range")
|
