-
Notifications
You must be signed in to change notification settings - Fork 297
/
tidyverse.R
724 lines (644 loc) · 24.3 KB
/
tidyverse.R
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
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
## dplyr methods: ------
#group_map.sf <- function(.tbl, .f, ...) {
# st_as_sf(NextMethod()) # nocov
#}
# This is currently only used in `bind_rows()` and `bind_cols()`
# because sf overrides all default implementations
dplyr_reconstruct.sf = function(data, template) {
sfc_name = attr(template, "sf_column")
if (inherits(template, "tbl_df"))
data = dplyr::as_tibble(data)
# Return a bare data frame is the geometry column is no longer there
if (!sfc_name %in% names(data))
return(data)
prec = st_precision(template)
crs = st_crs(template)
st_as_sf(
data,
sf_column_name = sfc_name,
crs = crs,
precision = prec
)
}
#' Tidyverse methods for sf objects
#'
#' Tidyverse methods for sf objects. Geometries are sticky, use \link{as.data.frame} to let \code{dplyr}'s own methods drop them.
#' Use these methods after loading the tidyverse package with the generic (or after loading package tidyverse).
#' @param .data data object of class \link{sf}
#' @param .dots see corresponding function in package \code{dplyr}
#' @param ... other arguments
#' @name tidyverse
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc = read_sf(system.file("shape/nc.shp", package="sf"))
#' nc %>% filter(AREA > .1) %>% plot()
#' # plot 10 smallest counties in grey:
#' st_geometry(nc) %>% plot()
#' nc %>% select(AREA) %>% arrange(AREA) %>% slice(1:10) %>% plot(add = TRUE, col = 'grey')
#' title("the ten counties with smallest area")
#' nc2 <- nc %>% mutate(area10 = AREA/10)
#' nc %>% slice(1:2)
#' }
filter.sf <- function(.data, ..., .dots) {
agr = st_agr(.data)
class(.data) <- setdiff(class(.data), "sf")
.re_sf(NextMethod(), sf_column_name = attr(.data, "sf_column"), agr)
}
#' @name tidyverse
#' @examples
#' # plot 10 smallest counties in grey:
#' if (require(dplyr, quietly = TRUE)) {
#' st_geometry(nc) %>% plot()
#' nc %>% select(AREA) %>% arrange(AREA) %>% slice(1:10) %>% plot(add = TRUE, col = 'grey')
#' title("the ten counties with smallest area")
#' }
arrange.sf <- function(.data, ..., .dots) {
sf_column_name = attr(.data, "sf_column")
class(.data) = setdiff(class(.data), "sf")
st_as_sf(NextMethod(), sf_column_name = sf_column_name)
}
#' @name tidyverse
#' @param add see corresponding function in dplyr
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc$area_cl = cut(nc$AREA, c(0, .1, .12, .15, .25))
#' nc %>% group_by(area_cl) %>% class()
#' }
group_by.sf <- function(.data, ..., add = FALSE) {
sf_column_name = attr(.data, "sf_column")
class(.data) <- setdiff(class(.data), "sf")
st_as_sf(NextMethod(), sf_column_name = sf_column_name)
}
#' @name tidyverse
ungroup.sf <- function(x, ...) {
sf_column_name = attr(x, "sf_column")
class(x) <- setdiff(class(x), "sf")
st_as_sf(NextMethod(), sf_column_name = sf_column_name)
}
#' @name tidyverse
rowwise.sf <- function(x, ...) {
sf_column_name = attr(x, "sf_column")
class(x) <- setdiff(class(x), "sf")
st_as_sf(NextMethod(), sf_column_name = sf_column_name)
}
.re_sf = function(x, sf_column_name, agr, geom = NULL) {
stopifnot(!inherits(x, "sf"), !missing(sf_column_name), !missing(agr))
# non-geom attribute names
att = names(x)[!sapply(x, inherits, what = "sfc")]
agr = setNames(agr[att], att) # NA's new columns
if (!is.null(geom)) {
stopifnot(length(geom) == nrow(x))
x[[ sf_column_name ]] = geom
}
structure(x,
sf_column = sf_column_name,
agr = agr,
class = c("sf", class(x)))
}
#' @name tidyverse
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc2 <- nc %>% mutate(area10 = AREA/10)
#' }
mutate.sf <- function(.data, ..., .dots) {
#st_as_sf(NextMethod(), sf_column_name = attr(.data, "sf_column"))
agr = st_agr(.data)
sf_column_name = attr(.data, "sf_column")
class(.data) <- setdiff(class(.data), "sf")
.re_sf(NextMethod(), sf_column_name = sf_column_name, agr)
}
#' @name tidyverse
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc %>% transmute(AREA = AREA/10) %>% class()
#' }
transmute.sf <- function(.data, ..., .dots) {
sf_column_name = attr(.data, "sf_column")
agr = st_agr(.data)
geom = st_geometry(.data)
class(.data) = setdiff(class(.data), "sf")
.re_sf(NextMethod(), sf_column_name = sf_column_name, agr, geom)
}
#' @name tidyverse
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc %>% select(SID74, SID79) %>% names()
#' nc %>% select(SID74, SID79) %>% class()
#' }
#' @details \code{select} keeps the geometry regardless whether it is selected or not; to deselect it, first pipe through \code{as.data.frame} to let dplyr's own \code{select} drop it.
select.sf <- function(.data, ...) {
if (!requireNamespace("tidyselect", quietly = TRUE))
stop("tidyselect required: install that first") # nocov
loc = tidyselect::eval_select(quote(c(...)), .data)
sf_column = attr(.data, "sf_column")
sf_column_loc = match(sf_column, names(.data))
if (length(sf_column_loc) != 1 || is.na(sf_column_loc))
stop("internal error: can't find sf column") # nocov
agr = st_agr(.data)
#vars = names(.data)[setdiff(loc, sf_column_loc)] # see #1886, change into:
lloc = loc
if (sf_column_loc %in% loc)
lloc = lloc[loc != sf_column_loc]
vars = names(.data)[lloc]
sf_column_loc_loc = match(sf_column_loc, loc)
if (is.na(sf_column_loc_loc)) {
# The sf column was subsetted out, select it back in
new_agr = setNames(agr[vars], names(loc))
loc = c(loc, sf_column_loc)
names(loc)[[length(loc)]] = sf_column
} else {
# The sf column was not subsetted out but it might have been renamed
sf_column = names(loc[sf_column_loc_loc])
new_agr = setNames(agr[vars], setdiff(names(loc), sf_column))
}
ret = .data
class(ret) = setdiff(class(ret), "sf")
ret = ret[loc]
names(ret) = names(loc)
st_set_agr(st_as_sf(ret, sf_column_name = sf_column), new_agr)
}
#' @name tidyverse
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc2 <- nc %>% rename(area = AREA)
#' }
rename.sf <- function(.data, ...) {
if (!requireNamespace("tidyselect", quietly = TRUE))
stop("tidyselect required: install that first") # nocov
loc = tidyselect::eval_rename(quote(c(...)), .data)
sf_column = attr(.data, "sf_column")
sf_column_loc = match(sf_column, names(.data))
if (length(sf_column_loc) != 1 || is.na(sf_column_loc))
stop("internal error: can't find sf column") # nocov
agr = st_agr(.data)
agr_loc = match(names(agr), setdiff(names(.data), sf_column))
if (anyNA(agr_loc))
stop("internal error: can't find `agr` columns") # nocov
vars_loc = loc[loc %in% agr_loc]
# https://github.com/r-spatial/sf/issues/1472
# but only fixes for the single sfc column case
sfcs = which(sapply(.data, inherits, "sfc"))
if (length(vars_loc) == 1 && any(vars_loc > sfcs[1])) {
w = which(vars_loc > sfcs)
vars_loc[w] = vars_loc[w] - 1
}
names(agr)[vars_loc] = names(vars_loc)
sf_column_loc_loc = match(sf_column_loc, loc)
if (!is.na(sf_column_loc_loc))
sf_column = names(loc[sf_column_loc_loc])
ret = .data
class(ret) = setdiff(class(ret), "sf")
names(ret)[loc] = names(loc)
st_set_agr(st_as_sf(ret, sf_column_name = sf_column), agr)
}
#' @name tidyverse
#' @param .fn,.cols see original docs
rename_with.sf = function(.data, .fn, .cols, ...) {
if (!requireNamespace("rlang", quietly = TRUE))
stop("rlang required: install that first") # nocov
.fn = rlang::as_function(.fn)
is_tibble = inherits(.data, "tbl")
sf_column = attr(.data, "sf_column")
sf_column_loc = match(sf_column, names(.data))
if (length(sf_column_loc) != 1 || is.na(sf_column_loc))
stop("internal error: can't find sf column") # nocov
agr = st_agr(.data)
.data = as.data.frame(.data)
ret = if (missing(.cols)) {
if (!requireNamespace("tidyselect", quietly = TRUE)) {
stop("tidyselect required: install that first") # nocov
}
dplyr::rename_with(
.data = .data,
.fn = .fn,
.cols = tidyselect::everything(),
...
)
} else {
dplyr::rename_with(
.data = .data,
.fn = .fn,
.cols = {{ .cols }},
...
)
}
if (is_tibble)
ret = dplyr::as_tibble(ret)
ret = st_as_sf(ret, sf_column_name = names(ret)[sf_column_loc])
names(agr) = .fn(names(agr), ...)
st_agr(ret) = agr
ret
}
#' @name tidyverse
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc %>% slice(1:2)
#' }
slice.sf <- function(.data, ..., .dots) {
class(.data) <- setdiff(class(.data), "sf")
sf_column <- attr(.data, "sf_column")
st_as_sf(NextMethod(), sf_column_name = sf_column)
}
#' @name tidyverse
#' @aliases summarise
#' @param do_union logical; in case \code{summary} does not create a geometry column, should geometries be created by unioning using \link{st_union}, or simply by combining using \link{st_combine}? Using \link{st_union} resolves internal boundaries, but in case of unioning points, this will likely change the order of the points; see Details.
#' @param is_coverage logical; if \code{do_union} is \code{TRUE}, use an optimized algorithm for features that form a polygonal coverage (have no overlaps)
#' @return an object of class \link{sf}
#' @details
#' In case one or more of the arguments (expressions) in the \code{summarise} call creates a geometry list-column, the first of these will be the (active) geometry of the returned object. If this is not the case, a geometry column is created, depending on the value of \code{do_union}.
#'
#' In case \code{do_union} is \code{FALSE}, \code{summarise} will simply combine geometries using \link{c.sfg}. When polygons sharing a boundary are combined, this leads to geometries that are invalid; see for instance \url{https://github.com/r-spatial/sf/issues/681}.
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc$area_cl = cut(nc$AREA, c(0, .1, .12, .15, .25))
#' nc.g <- nc %>% group_by(area_cl)
#' nc.g %>% summarise(mean(AREA))
#' nc.g %>% summarise(mean(AREA)) %>% plot(col = grey(3:6 / 7))
#' nc %>% as.data.frame %>% summarise(mean(AREA))
#' }
summarise.sf <- function(.data, ..., .dots, do_union = TRUE, is_coverage = FALSE) {
sf_column = attr(.data, "sf_column")
precision = st_precision(.data)
crs = st_crs(.data)
geom = st_geometry(.data)
class(.data) = setdiff(class(.data), "sf")
ret = NextMethod()
if (!missing(do_union))
ret$do_union = NULL
if (!missing(is_coverage))
ret$is_coverage = NULL
if (! any(sapply(ret, inherits, what = "sfc"))) {
geom = if (inherits(.data, "grouped_df") || inherits(.data, "grouped_dt")) {
if (!requireNamespace("dplyr", quietly = TRUE))
stop("dplyr required: install that first") # nocov
i = dplyr::group_indices(.data)
# geom = st_geometry(.data)
geom = if (do_union)
lapply(sort(unique(i)), function(x) {
if (x == 1)
st_union(geom[i == x], is_coverage = is_coverage)
else
suppressMessages(st_union(geom[i == x], is_coverage = is_coverage))
})
else
lapply(sort(unique(i)), function(x) st_combine(geom[i == x]))
geom = unlist(geom, recursive = FALSE)
if (is.null(geom))
geom = list() #676 #nocov
do.call(st_sfc, c(geom, crs = list(crs), precision = precision))
} else { # single group:
if (nrow(ret) > 1)
stop(paste0("when using .by, also add across(", sf_column, ", st_union) as argument")) # https://github.com/r-spatial/sf/issues/2207
if (do_union)
st_union(geom, is_coverage = is_coverage)
else
st_combine(geom)
}
ret[[ sf_column ]] = geom
}
# need to re-sort out the geometry column class now:
st_as_sf(structure(ret, sf_column = NULL))
}
#' @name tidyverse
#' @param .keep_all see corresponding function in dplyr
#' @examples
#' if (require(dplyr, quietly = TRUE)) {
#' nc[c(1:100, 1:10), ] %>% distinct() %>% nrow()
#' }
#' @details \code{distinct} gives distinct records for which all attributes and geometries are distinct; \link{st_equals} is used to find out which geometries are distinct.
distinct.sf <- function(.data, ..., .keep_all = FALSE) {
sf_column = attr(.data, "sf_column")
geom = st_geometry(.data)
eq = sapply(st_equals(.data), head, n = 1)
if (is.list(eq) && length(eq) == 0) # empty list: geometry was empty set
eq = integer(0)
empties = which(lengths(eq) == 0)
eq[ empties ] = empties[1] # first empty record
.data[[ sf_column ]] = unlist(eq)
class(.data) = setdiff(class(.data), "sf")
if (!requireNamespace("dplyr", quietly = TRUE))
stop("dplyr required: install that first") # nocov
if (!requireNamespace("rlang", quietly = TRUE))
stop("rlang required: install first?")
.data = dplyr::distinct(.data, ..., .keep_all = .keep_all)
if (is.null(.data[[ sf_column ]]))
.data
else {
.data[[ sf_column ]] = geom[ .data[[ sf_column ]] ]
st_as_sf(.data, sf_column_name = sf_column)
}
}
## tidyr methods: --------
#' @name tidyverse
#' @param data see original function docs
#' @param key see original function docs
#' @param value see original function docs
#' @param na.rm see original function docs
#' @param factor_key see original function docs
#' @examples
#' if (require(tidyr, quietly = TRUE) && require(dplyr, quietly = TRUE) && "geometry" %in% names(nc)) {
#' nc %>% select(SID74, SID79) %>% gather("VAR", "SID", -geometry) %>% summary()
#' }
gather.sf <- function(data, key, value, ..., na.rm = FALSE, convert = FALSE, factor_key = FALSE) {
if (! requireNamespace("rlang", quietly = TRUE))
stop("rlang required: install first?")
key = rlang::enquo(key)
value = rlang::enquo(value)
if (!requireNamespace("tidyr", quietly = TRUE))
stop("tidyr required: install first?")
class(data) <- setdiff(class(data), "sf")
st_as_sf(tidyr::gather(data, !!key, !!value, ...,
na.rm = na.rm, convert = convert, factor_key = factor_key),
sf_column_name = attr(data, "sf_column"))
}
#' @name tidyverse
#' @param data see original function docs
#' @param cols see original function docs
#' @param names_to,names_pattern,names_ptypes,names_transform see [tidyr::pivot_longer()]
#' @param values_to,values_drop_na,values_ptypes,values_transform See [tidyr::pivot_longer()]
pivot_longer.sf <- function (data, cols, names_to = "name", names_prefix = NULL,
names_sep = NULL, names_pattern = NULL, names_ptypes = NULL,
names_transform = NULL, names_repair = "check_unique",
values_to = "value", values_drop_na = FALSE, values_ptypes = NULL,
values_transform = NULL, ...) {
sf_column_name = attr(data, "sf_column")
data = as.data.frame(data)
# instead of:
# st_as_sf(NextMethod(), sf_column_name = sf_column_name)
# we avoid NextMethod(); for the reason
# see https://github.com/tidyverse/tidyr/issues/1171:
if (!requireNamespace("tidyr", quietly = TRUE))
stop("tidyr required: install first?")
out <- tidyr::pivot_longer(
data = data,
cols = {{ cols }},
names_to = names_to,
names_prefix = names_prefix,
names_sep = names_sep,
names_pattern = names_pattern,
names_ptypes = names_ptypes,
names_transform = names_transform,
names_repair = names_repair,
values_to = values_to,
values_drop_na = values_drop_na,
values_ptypes = values_ptypes,
values_transform = values_transform,
...
)
st_as_sf(out, sf_column_name = sf_column_name)
}
globalVariables(c("name", "value"))
# https://github.com/r-spatial/sf/issues/1915
#' @name tidyverse
#' @param id_cols,id_expand,names_from,names_sort,names_glue,names_vary,names_expand see [tidyr::pivot_wider()]
# names_prefix,names_sep and names_repair are shared between pivot_longer() and pivot_wider()
#' @param names_prefix,names_sep,names_repair see original function docs.
#' @param values_from,values_fill,values_fn,unused_fn see [tidyr::pivot_wider()]
pivot_wider.sf = function(data,
...,
id_cols = NULL,
id_expand = FALSE,
names_from = name,
names_prefix = "",
names_sep = "_",
names_glue = NULL,
names_sort = FALSE,
names_vary = "fastest",
names_expand = FALSE,
names_repair = "check_unique",
values_from = value,
values_fill = NULL,
values_fn = NULL,
unused_fn = NULL) {
agr = st_agr(data)
sf_column_name = attr(data, "sf_column")
data = as.data.frame(data)
if (!requireNamespace("tidyr", quietly = TRUE))
stop("tidyr required: install first?")
ret = tidyr::pivot_wider(
data = data,
...,
id_cols = {{ id_cols }},
id_expand = id_expand,
names_from = {{ names_from }},
names_prefix = names_prefix,
names_sep = names_sep,
names_glue = names_glue,
names_sort = names_sort,
names_vary = names_vary,
names_expand = names_expand,
names_repair = names_repair,
values_from = {{ values_from }},
values_fill = values_fill,
values_fn = values_fn,
unused_fn = unused_fn
)
st_as_sf(ret, sf_column_name = sf_column_name, agr = agr)
}
#' @name tidyverse
#' @param fill see original function docs
#' @param drop see original function docs
#' @examples
#' if (require(tidyr, quietly = TRUE) && require(dplyr, quietly = TRUE) && "geometry" %in% names(nc)) {
#' nc$row = 1:100 # needed for spread to work
#' nc %>% select(SID74, SID79, geometry, row) %>%
#' gather("VAR", "SID", -geometry, -row) %>%
#' spread(VAR, SID) %>% head()
#' }
spread.sf <- function(data, key, value, fill = NA, convert = FALSE, drop = TRUE,
sep = NULL) {
if (!requireNamespace("rlang", quietly = TRUE))
stop("rlang required: install first?")
key = rlang::enquo(key)
value = rlang::enquo(value)
class(data) <- setdiff(class(data), "sf")
st_as_sf(tidyr::spread(data, !!key, !!value, fill = fill, convert = convert,
drop = drop, sep = sep), sf_column_name = attr(data, "sf_column"))
}
#' @name tidyverse
#' @param tbl see original function docs
#' @param size see original function docs
#' @param replace see original function docs
#' @param weight see original function docs
#' @param .env see original function docs
sample_n.sf <- function(tbl, size, replace = FALSE, weight = NULL, .env = parent.frame()) {
st_sf(NextMethod(), sf_column_name = attr(tbl, "sf_column"))
}
#' @name tidyverse
sample_frac.sf <- function(tbl, size = 1, replace = FALSE, weight = NULL, .env = parent.frame()) {
st_sf(NextMethod(), sf_column_name = attr(tbl, "sf_column"))
}
#' @name tidyverse
#' @param .tbl see original function docs
#' @param .keep see original function docs
group_split.sf <- function(.tbl, ..., .keep = TRUE) {
class(.tbl) = setdiff(class(.tbl), "sf")
if (inherits(.tbl, "rowwise_df")) {
lapply(dplyr::group_split(.tbl, ...), st_as_sf)
} else {
lapply(dplyr::group_split(.tbl, ..., .keep = .keep), st_as_sf)
}
}
#' @name tidyverse
#' @examples
#' if (require(tidyr, quietly = TRUE) && require(dplyr, quietly = TRUE)) {
#' storms.sf = st_as_sf(storms, coords = c("long", "lat"), crs = 4326)
#' x <- storms.sf %>% group_by(name, year) %>% nest
#' trs = lapply(x$data, function(tr) st_cast(st_combine(tr), "LINESTRING")[[1]]) %>%
#' st_sfc(crs = 4326)
#' trs.sf = st_sf(x[,1:2], trs)
#' plot(trs.sf["year"], axes = TRUE)
#' }
#' @details \code{nest} assumes that a simple feature geometry list-column was among the columns that were nested.
nest.sf = function(.data, ...) {
if (!requireNamespace("rlang", quietly = TRUE))
stop("rlang required: install first?")
if (!requireNamespace("tidyr", quietly = TRUE))
stop("tidyr required: install first?")
class(.data) <- setdiff(class(.data), "sf")
ret = tidyr::nest(.data, ...)
lst = which(sapply(ret, inherits, "list"))[1]
# re-sf:
ret[[lst]] = lapply(ret[[lst]], st_as_sf, sf_column_name = attr(.data, "sf_column"))
ret
}
#' @name tidyverse
#' @param col see \link[tidyr]{separate}
#' @param into see \link[tidyr]{separate}
#' @param remove see \link[tidyr]{separate}
#' @param extra see \link[tidyr]{separate}
separate.sf = function(data, col, into, sep = "[^[:alnum:]]+", remove = TRUE,
convert = FALSE, extra = "warn", fill = "warn", ...) {
if (!requireNamespace("rlang", quietly = TRUE))
stop("rlang required: install first?")
col = rlang::enquo(col)
if (!requireNamespace("tidyr", quietly = TRUE))
stop("tidyr required: install first?")
class(data) <- setdiff(class(data), "sf")
st_as_sf(tidyr::separate(data, !!col, into = into,
sep = sep, remove = remove, convert = convert, extra = extra, fill = fill, ...),
sf_column_name = attr(data, "sf_column"))
}
#' @name tidyverse
#' @param sep see \link[tidyr]{separate_rows}
#' @param convert see \link[tidyr]{separate_rows}
separate_rows.sf <- function(data, ..., sep = "[^[:alnum:]]+", convert = FALSE) {
if (!requireNamespace("tidyr", quietly = TRUE))
stop("tidyr required: install first?")
class(data) <- setdiff(class(data), "sf")
ret = tidyr::separate_rows(data, ..., sep = sep, convert = convert)
st_as_sf(ret, sf_column_name = attr(data, "sf_column"))
}
#' @name tidyverse
unite.sf <- function(data, col, ..., sep = "_", remove = TRUE) {
class(data) <- setdiff(class(data), "sf")
if (!requireNamespace("rlang", quietly = TRUE))
stop("rlang required: install first?")
col = rlang::enquo(col)
st_as_sf(tidyr::unite(data, !!col, ..., sep = sep, remove = remove),
sf_column_name = attr(data, "sf_column"))
}
#' @name tidyverse
#' @param .preserve see \link[tidyr:nest]{unnest}
unnest.sf = function(data, ..., .preserve = NULL) {
# nocov start
sf_column_name = attr(data, "sf_column", exact = TRUE)
if (!requireNamespace("tidyr", quietly = TRUE))
stop("unnest requires tidyr; install that first")
class(data) = setdiff(class(data), "sf")
st_sf(NextMethod(), sf_column_name = sf_column_name)
# nocov end
}
#' @name tidyverse
drop_na.sf <- function(x, ...) {
sf_column_name = attr(x, "sf_column")
class(x) <- setdiff(class(x), "sf")
st_as_sf(NextMethod(), sf_column_name = sf_column_name)
}
## tibble methods: -------
#' Summarize simple feature type for tibble
#'
#' Summarize simple feature type / item for tibble
#' @param x object of class `sfc`
#' @param ... ignored
#' @name tibble
#' @details see \link[pillar]{type_sum}
type_sum.sfc <- function(x, ...) {
cls = substring(class(x)[1], 5)
u = st_crs(x)$ud_unit
if (!is.null(u)) # add [units]:
cls = paste0(cls, " [", enc2utf8(as.character(units(u))), "]")
cls
}
#' @rdname tibble
obj_sum.sfc <- function(x) {
vapply(x, function(sfg) format(sfg, width = 15L), "")
}
#' @rdname tibble
pillar_shaft.sfc <- function(x, ...) {
digits = options("pillar.sigfig")$pillar.sigfig
if (is.null(digits))
digits = options("digits")$digits
out <- format(x, width = 100, digits = digits, ...)
if (!inherits(x, "sfc_GEOMETRY") && !inherits(x, "sfc_GEOMETRYCOLLECTION"))
out <- sub("[A-Z]+ ", "", out)
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 25)
}
#nocov start
register_all_s3_methods = function() {
s3_register("dplyr::dplyr_reconstruct", "sf")
s3_register("dplyr::anti_join", "sf")
s3_register("dplyr::arrange", "sf")
s3_register("dplyr::distinct", "sf")
s3_register("dplyr::filter", "sf")
s3_register("dplyr::full_join", "sf")
s3_register("dplyr::group_by", "sf")
# s3_register("dplyr::group_map", "sf")
s3_register("dplyr::group_split", "sf")
s3_register("dplyr::inner_join", "sf")
s3_register("dplyr::left_join", "sf")
s3_register("dplyr::mutate", "sf")
s3_register("dplyr::rename", "sf")
s3_register("dplyr::rename_with", "sf")
s3_register("dplyr::right_join", "sf")
s3_register("dplyr::rowwise", "sf")
s3_register("dplyr::sample_frac", "sf")
s3_register("dplyr::sample_n", "sf")
s3_register("dplyr::select", "sf")
s3_register("dplyr::semi_join", "sf")
s3_register("dplyr::slice", "sf")
s3_register("dplyr::summarise", "sf")
s3_register("dplyr::transmute", "sf")
s3_register("dplyr::ungroup", "sf")
s3_register("tidyr::drop_na", "sf")
s3_register("tidyr::gather", "sf")
s3_register("tidyr::pivot_longer", "sf")
s3_register("tidyr::pivot_wider", "sf")
s3_register("tidyr::spread", "sf")
s3_register("tidyr::nest", "sf")
s3_register("tidyr::separate", "sf")
s3_register("tidyr::separate_rows", "sf")
s3_register("tidyr::unite", "sf")
s3_register("tidyr::unnest", "sf")
s3_register("pillar::obj_sum", "sfc")
s3_register("pillar::type_sum", "sfc")
s3_register("pillar::pillar_shaft", "sfc")
s3_register("spatstat.geom::as.ppp", "sfc")
s3_register("spatstat.geom::as.ppp", "sf")
s3_register("spatstat.geom::as.owin", "POLYGON")
s3_register("spatstat.geom::as.owin", "MULTIPOLYGON")
s3_register("spatstat.geom::as.owin", "sfc_POLYGON")
s3_register("spatstat.geom::as.owin", "sfc_MULTIPOLYGON")
s3_register("spatstat.geom::as.owin", "sfc")
s3_register("spatstat.geom::as.owin", "sf")
s3_register("spatstat.geom::as.psp", "LINESTRING")
s3_register("spatstat.geom::as.psp", "MULTILINESTRING")
s3_register("spatstat.geom::as.psp", "sfc_MULTILINESTRING")
s3_register("spatstat.geom::as.psp", "sfc")
s3_register("spatstat.geom::as.psp", "sf")
s3_register("s2::as_s2_geography", "sfg")
s3_register("s2::as_s2_geography", "sfc")
s3_register("s2::as_s2_geography", "sf")
register_vctrs_methods()
}
# nocov end