-
Notifications
You must be signed in to change notification settings - Fork 503
/
layers.R
1653 lines (1518 loc) · 54.5 KB
/
layers.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
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#' Evaluate list members that are formulae, using the map data as the environment
#'
#' Evaluates if provided. Otherwise, the formula environment is evaluated.
#' @param list with members as formulae
#' @param data map data
#' @keywords internal
#' @export
evalFormula <- function(list, data) {
evalAll <- function(x) {
if (is.list(x)) {
# Use `x[] <-` so attributes on x are preserved
x[] <- lapply(x, evalAll)
x
} else {
resolveFormula(x, data)
}
}
evalAll(list)
}
# jcheng 12/10/2014: The limits/bbox handling was pretty rushed, unfortunately
# we have ended up with too many concepts. expandLimits just takes random
# lat/lng vectors, the sp package's Spatial objects can use `bbox()`, and our
# polygon lists (returned from polygonData()) use `attr(x, "bbox")` (though at
# least they are the same shape as the Spatial bounding boxes).
#' Notifies the map of new latitude/longitude of items of interest on the map
# So that we can expand the limits (i.e. bounding box). We will use this as the
# initial view if the user doesn't explicitly specify bounds using fitBounds.
#' @param map map object
#' @param lat vector of latitudes
#' @param lng vector of longitudes
#' @export
expandLimits <- function(map, lat, lng) {
if (is.null(map$x$limits)) map$x$limits <- list()
# We remove NA's and check the lengths so we never call range() with an empty
# set of arguments (or all NA's), which will cause a warning.
lat <- lat[is.finite(lat)]
lng <- lng[is.finite(lng)]
if (length(lat) > 0) map$x$limits$lat <- range(map$x$limits$lat, lat)
if (length(lng) > 0) map$x$limits$lng <- range(map$x$limits$lng, lng)
map
}
#' Notifies the map of polygons of interest on the map
#'
#' Same as `expandLimits()`, but takes a polygon (that presumably has a bbox attr)
#' rather than lat/lng.
#' @param map map object
#' @param poly A spatial object representing a polygon.
#' @export
expandLimitsBbox <- function(map, poly) {
bbox <- attr(poly, "bbox", exact = TRUE)
if (is.null(bbox)) stop("Polygon data had no bbox")
expandLimits(map, bbox[2, ], bbox[1, ])
}
# Represents an initial bbox; if combined with any other bbox value using
# bboxAdd, the other bbox will be the result.
bboxNull <- cbind(min = c(x = Inf, y = Inf), max = c(x = -Inf, y = -Inf))
# Combine two bboxes; the result will use the mins of the mins and the maxes of
# the maxes.
bboxAdd <- function(a, b) {
cbind(
min = pmin(a[, 1], b[, 1]),
max = pmax(a[, 2], b[, 2])
)
}
#' @param group the name of the group whose members should be removed
#' @rdname remove
#' @export
clearGroup <- function(map, group) {
invokeMethod(map, getMapData(map), "clearGroup", group);
}
#' Show or hide layer groups
#'
#' Hide groups of layers without removing them from the map entirely. Groups are
#' created using the `group` parameter that is included on most layer
#' adding functions.
#'
#' @param map the map to modify
#' @param group character vector of one or more group names to show or hide
#'
#' @seealso [addLayersControl()] to allow users to show/hide layer
#' groups interactively
#'
#' @export
showGroup <- function(map, group) {
invokeMethod(map, getMapData(map), "showGroup", group)
}
#' @rdname showGroup
#' @export
hideGroup <- function(map, group) {
invokeMethod(map, getMapData(map), "hideGroup", group)
}
#' Set options on layer groups
#'
#' Change options on layer groups. Currently the only option is to control what
#' zoom levels a layer group will be displayed at. The `zoomLevels` option
#' is not compatible with [layers control][addLayersControl()]; do not both
#' assign a group to zoom levels and use it with `addLayersControl()`.
#'
#' @param map the map to modify
#' @param group character vector of one or more group names to set options on
#' @param zoomLevels numeric vector of zoom levels at which group(s) should be
#' visible, or `TRUE` to display at all zoom levels
#'
#' @examples
#' pal <- colorQuantile("YlOrRd", quakes$mag)
#'
#' leaflet() %>%
#' # Basic markers
#' addTiles(group = "basic") %>%
#' addMarkers(data = quakes, group = "basic") %>%
#' # When zoomed in, we'll show circles at the base of each marker whose
#' # radius and color reflect the magnitude
#' addProviderTiles(providers$Esri.WorldTopoMap, group = "detail") %>%
#' addCircleMarkers(data = quakes, group = "detail", fillOpacity = 0.5,
#' radius = ~mag * 5, color = ~pal(mag), stroke = FALSE) %>%
#' # Set the detail group to only appear when zoomed in
#' groupOptions("detail", zoomLevels = 7:18)
#'
#' @export
groupOptions <- function(map, group, zoomLevels = NULL) {
if (is.null(zoomLevels)) # Default to TRUE if nothing specified.
zoomLevels <- TRUE
invokeMethod(map, getMapData(map), "setGroupOptions", group,
list(zoomLevels = zoomLevels)
)
}
#' Graphics elements and layers
#'
#' Add graphics elements and layers to the map widget.
#' @inheritParams setView
#' @param urlTemplate a character string as the URL template
#' @param attribution the attribution text of the tile layer (HTML)
#' @param options a list of extra options for tile layers, popups, paths
#' (circles, rectangles, polygons, ...), or other map elements
#' @return the new `map` object
#' @seealso [tileOptions()], [WMSTileOptions()],
#' [popupOptions()], [markerOptions()],
#' [pathOptions()]
#' @references The Leaflet API documentation:
#' <https://web.archive.org/web/20220702182250/https://leafletjs.com/reference-1.3.4.html>
#' @describeIn map-layers Add a tile layer to the map
#' @export
addTiles <- function(
map,
urlTemplate = "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png",
attribution = NULL,
layerId = NULL,
group = NULL,
options = tileOptions(),
data = getMapData(map)
) {
options$attribution <- attribution
if (missing(urlTemplate) && is.null(options$attribution))
options$attribution <- paste(
"© <a href=\"https://openstreetmap.org/copyright/\">OpenStreetMap</a>, ",
"<a href=\"https://opendatacommons.org/licenses/odbl/\">ODbL</a>"
)
invokeMethod(map, data, "addTiles", urlTemplate, layerId, group,
options)
}
epsg4326 <- "+proj=longlat +datum=WGS84 +no_defs"
epsg3857 <- "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext +no_defs" # nolint
#' Add a raster image as a layer
#'
#' Create an image overlay from a `RasterLayer` or a `SpatRaster`
#' object. *This is only suitable for small to medium sized rasters*,
#' as the entire image will be embedded into the HTML page (or passed over
#' the websocket in a Shiny context).
#'
#' The `maxBytes` parameter serves to prevent you from accidentally
#' embedding an excessively large amount of data into your htmlwidget. This
#' value is compared to the size of the final compressed image (after the raster
#' has been projected, colored, and PNG encoded, but before base64 encoding is
#' applied). Set `maxBytes` to `Inf` to disable this check, but be
#' aware that very large rasters may not only make your map a large download but
#' also may cause the browser to become slow or unresponsive.
#'
#' To reduce the size of a SpatRaster, you can use [terra::spatSample()]
#' as in `x = spatSample(x, 100000, method="regular", as.raster=TRUE)`. With
#' a `RasterLayer` you can use [raster::sampleRegular()] as in
#' `sampleRegular(x, 100000, asRaster=TRUE)`.
#'
#' By default, `addRasterImage()` will project the raster data
#' `x` to the Pseudo-Mercator projection (EPSG:3857). This can be a
#' time-consuming operation for even moderately sized rasters; although it is much
#' faster for SpatRasters than for RasterLayers.
#' If you are repeatedly adding a particular raster to your Leaflet
#' maps, you can perform the projection ahead of time using
#' `projectRasterForLeaflet()`, and call `addRasterImage()` with
#' `project = FALSE`.
#'
#' @param map a map widget object
#' @param x a [terra::SpatRaster()] or a `RasterLayer` object--see [raster::raster()]
#' @param colors the color palette (see [colorNumeric()]) or function
#' to use to color the raster values (hint: if providing a function, set
#' `na.color` to `"#00000000"` to make `NA` areas transparent).
#' The palette is ignored if `x` is a SpatRaster with a color table or if
#' it has RGB channels.
#' @param opacity the base opacity of the raster, expressed from 0 to 1
#' @param attribution the HTML string to show as the attribution for this layer
#' @param layerId the layer id
#' @param group the name of the group this raster image should belong to (see
#' the same parameter under [addTiles()])
#' @param project if `TRUE`, automatically project `x` to the map
#' projection expected by Leaflet (`EPSG:3857`); if `FALSE`, it's
#' the caller's responsibility to ensure that `x` is already projected,
#' and that `extent(x)` is expressed in WGS84 latitude/longitude
#' coordinates
#' @param method the method used for computing values of the new, projected raster image.
#' `"bilinear"` (the default) is appropriate for continuous data,
#' `"ngb"` - nearest neighbor - is appropriate for categorical data.
#' Ignored if `project = FALSE`. See [projectRaster()] for details.
#' @param maxBytes the maximum number of bytes to allow for the projected image
#' (before base64 encoding); defaults to 4MB.
#' @param options a list of additional options, intended to be provided by
#' a call to [gridOptions()]
#' @template data-getMapData
#'
#' @seealso [addRasterLegend()] for an easy way to add a legend for a
#' SpatRaster with a color table.
#'
#' @examples
#' \donttest{library(raster)
#'
#' r <- raster(xmn = -2.8, xmx = -2.79, ymn = 54.04, ymx = 54.05, nrows = 30, ncols = 30)
#' values(r) <- matrix(1:900, nrow(r), ncol(r), byrow = TRUE)
#' crs(r) <- CRS("+init=epsg:4326")
#'
#' pal <- colorNumeric("Spectral", domain = c(0, 1000))
#' leaflet() %>% addTiles() %>%
#' addRasterImage(r, colors = pal, opacity = 0.8) %>%
#' addLegend(pal = pal, values = c(0, 1000))
#' }
#' @export
addRasterImage <- function(
map,
x,
colors = if (is.factor(x)[1]) "Set1" else "Spectral",
opacity = 1,
attribution = NULL,
layerId = NULL,
group = NULL,
project = TRUE,
method = c("auto", "bilinear", "ngb"),
maxBytes = 4 * 1024 * 1024,
options = gridOptions(),
data = getMapData(map)
) {
if (inherits(x, "SpatRaster")) {
addRasterImage_SpatRaster(
map=map,
x=x,
colors = colors,
opacity = opacity,
attribution = attribution,
layerId = layerId,
group = group,
project = project,
method = method,
maxBytes = maxBytes,
options = options,
data = data
)
} else if (inherits(x, "RasterLayer")) {
addRasterImage_RasterLayer(
map=map,
x=x,
colors = colors,
opacity = opacity,
attribution = attribution,
layerId = layerId,
group = group,
project = project,
method = method,
maxBytes = maxBytes,
options = options,
data = data
)
} else {
stop("Don't know how to get path data from object of class ", class(x)[[1]])
}
}
#' Add a color legend for a SpatRaster to a map
#'
#' A function for adding a [legend][addLegend()] that is specifically designed
#' for [terra::SpatRaster] objects, with categorical values, that carry their
#' own [color table][terra::coltab()].
#'
#' @param map a map widget object
#' @param x a [SpatRaster][terra::SpatRaster] object with a color table
#' @param layer the layer of the raster to target
#' @param ... additional arguments to pass through to [addLegend()]
#' @seealso [addRasterImage()]
#' @examplesIf interactive()
#'
#' library(terra)
#'
#' r <- rast("/vsicurl/https://geodata.ucdavis.edu/test/pr_nlcd.tif")
#' leaflet() %>%
#' addTiles() %>%
#' addRasterImage(r, opacity = 0.75) %>%
#' addRasterLegend(r, opacity = 0.75)
#'
#' plot.new() # pause in interactive mode
#'
#' rr <- r
#' levels(rr) <- NULL
#' leaflet() %>%
#' addTiles() %>%
#' addRasterImage(rr, opacity = 0.75) %>%
#' addRasterLegend(rr, opacity = 0.75)
#'
#' @md
#' @export
addRasterLegend <- function(map, x, layer = 1, ...) {
stopifnot(inherits(x, "SpatRaster"))
stopifnot(length(layer) == 1 && layer > 0 && layer <= terra::nlyr(x))
# might as well do this here and only once. Subsetting would otherwise have
# been necessary in
# color_info <- base::subset(color_info, value %in% terra::values(x))
x <- x[[layer]]
# Retrieve the color table from the layer. If one doesn't exist, that means
# the raster was colored some other way, like using colorFactor or something,
# and the regular addLegend() is designed for those cases.
ct <- terra::coltab(x)[[1]]
if (is.null(ct)) {
stop("addRasterLegend() can only be used on layers with color tables (see ?terra::coltab). Otherwise, use addLegend().")
}
# Create a data frame that has value and color columns
# Extract the colors in #RRGGBBAA format
color_info <- data.frame(
value = ct[[1]],
color = grDevices::rgb(ct$red / 255, ct$green / 255, ct$blue / 255, ct$alpha / 255)
)
lvls <- terra::levels(x)[[1]]
# Drop values that aren't part of the layer unlike "values", "unique" is
# memory-safe; it does not load all values into memory if the raster is large.
# So instead of:
#
# color_info <- base::subset(color_info, value %in% terra::values(x))
#
# remove the levels to get the raw cell values
levels(x) <- NULL
value_in_layer <- color_info$value %in% terra::unique(x)[[1]]
color_info <- color_info[value_in_layer & !is.na(value_in_layer), ]
res <- if (is.data.frame(lvls)) {
# Use the labels from levels(x), and look up the matching colors.
# The levels data frame can have varying colnames, just normalize them
colnames(lvls) <- c("value", "label")
base::merge(color_info, lvls, by.x = "value", by.y = 1)
} else {
# No level labels provided; use the values as labels
cbind(color_info, label = color_info$value)
}
# At this point, res is a data frame with `value`, `color`, and `label` cols,
# and values/colors not present in the raster layer have been dropped
addLegend(map, colors = res[["color"]], labels = res[["label"]], ...)
}
addRasterImage_RasterLayer <- function(
map,
x,
colors = if (is.factor(x)[1]) "Set1" else "Spectral",
opacity = 1,
attribution = NULL,
layerId = NULL,
group = NULL,
project = TRUE,
method = c("auto", "bilinear", "ngb"),
maxBytes = 4 * 1024 * 1024,
options = gridOptions(),
data = getMapData(map)
) {
options$opacity <- opacity
options$attribution <- attribution
raster_is_factor <- raster::is.factor(x)
method <- match.arg(method)
if (method == "auto") {
if (raster_is_factor) {
method <- "ngb"
} else {
method <- "bilinear"
}
}
if (project) {
# if we should project the data
projected <- projectRasterForLeaflet(x, method)
} else {
# do not project data
projected <- x
}
bounds <- raster::extent(
raster::projectExtent(
raster::projectExtent(x, crs = sp::CRS(epsg3857)),
crs = sp::CRS(epsg4326)
)
)
if (!is.function(colors)) {
if (method == "ngb") {
# 'factors'
colors <- colorFactor(colors, domain = NULL, na.color = "#00000000", alpha = TRUE)
} else {
# 'numeric'
colors <- colorNumeric(colors, domain = NULL, na.color = "#00000000", alpha = TRUE)
}
}
tileData <- raster::values(projected) %>% colors() %>% col2rgb(alpha = TRUE) %>% as.raw()
dim(tileData) <- c(4, ncol(projected), nrow(projected))
pngData <- png::writePNG(tileData)
if (length(pngData) > maxBytes) {
stop(
"Raster image too large; ", length(pngData), " bytes is greater than maximum ",
maxBytes, " bytes"
)
}
uri <- xfun::base64_uri(pngData, "image/png")
latlng <- list(
list(raster::ymax(bounds), raster::xmin(bounds)),
list(raster::ymin(bounds), raster::xmax(bounds))
)
invokeMethod(map, data, "addRasterImage", uri, latlng, layerId, group, options) %>%
expandLimits(
c(raster::ymin(bounds), raster::ymax(bounds)),
c(raster::xmin(bounds), raster::xmax(bounds))
)
}
addRasterImage_SpatRaster <- function(
map,
x,
colors = if (terra::is.factor(x)[1]) "Set1" else "Spectral",
opacity = 1,
attribution = NULL,
layerId = NULL,
group = NULL,
project = TRUE,
method = c("auto", "bilinear", "ngb"),
maxBytes = 4 * 1024 * 1024,
options = gridOptions(),
data = getMapData(map)
) {
if (!is_installed("terra", "1.6-3")) { # for terra::has.RGB()
stop(
"`addRasterImage()` for SpatRaster objects requires {terra} 1.6-3 or higher",
call. = FALSE
)
}
options$opacity <- opacity
options$attribution <- attribution
if (terra::has.RGB(x)) {
# RGB(A) channels to color table
x <- terra::colorize(x, "col")
} else if (terra::nlyr(x) > 1) {
x <- x[[1]]
warning("using the first layer in 'x'", call. = FALSE)
}
raster_is_factor <- terra::is.factor(x)
# there 1.5-50 has terra::has.colors(x)
ctab <- terra::coltab(x)[[1]]
has_colors <- !is.null(ctab)
method <- match.arg(method)
if (method == "ngb") method = "near"
if (method == "auto") {
if (raster_is_factor || has_colors) {
method <- "near"
} else {
method <- "bilinear"
}
}
bounds <- terra::ext(
terra::project(
terra::project(
terra::as.points(terra::ext(x), crs=terra::crs(x)),
epsg3857),
epsg4326)
)
## can't the above be simplified to this?
# bounds <- terra::ext(
# terra::project(
# terra::as.points(terra::ext(x), crs=terra::crs(x)),
# epsg4326)
# )
if (project) {
# if we should project the data
x <- projectRasterForLeaflet(x, method)
if (method=="bilinear") {
has_colors <- FALSE
}
}
if (!is.function(colors)) {
if (method == "near" || has_colors) {
# 'factors'
domain <- NULL
if (has_colors) {
colors <- rgb(ctab[,2], ctab[,3], ctab[,4], ctab[,5], maxColorValue=255)
domain <- ctab[,1]
}
colors <- colorFactor(colors, domain = domain, na.color = "#00000000", alpha = TRUE)
} else {
# 'numeric'
colors <- colorNumeric(colors, domain = NULL, na.color = "#00000000", alpha = TRUE)
}
}
tileData <- terra::values(x) %>% as.vector() %>% colors() %>% col2rgb(alpha = TRUE) %>% as.raw()
dim(tileData) <- c(4, ncol(x), nrow(x))
pngData <- png::writePNG(tileData)
if (length(pngData) > maxBytes) {
stop(
"Raster image too large; ", length(pngData), " bytes is greater than maximum ",
maxBytes, " bytes"
)
}
uri <- xfun::base64_uri(pngData, "image/png")
latlng <- list(
list(terra::ymax(bounds), terra::xmin(bounds)),
list(terra::ymin(bounds), terra::xmax(bounds))
)
invokeMethod(map, data, "addRasterImage", uri, latlng, layerId, group, options) %>%
expandLimits(
c(terra::ymin(bounds), terra::ymax(bounds)),
c(terra::xmin(bounds), terra::xmax(bounds))
)
}
#' @rdname addRasterImage
#' @export
projectRasterForLeaflet <- function(x, method) {
if (inherits(x, "SpatRaster")) {
if (method=="ngb") {
method = "near"
}
terra::project(
x,
y=epsg3857,
method=method
)
} else {
raster_is_factor <- raster::is.factor(x);
projected <- raster::projectRaster(
x,
raster::projectExtent(x, crs = sp::CRS(epsg3857)),
method = method
)
# if data is factor data, make the result factors as well.
# only meaningful if ngb was used
if ((raster_is_factor) && (method == "ngb")) {
raster::as.factor(projected)
} else {
projected
}
}
}
#' @rdname remove
#' @export
removeImage <- function(map, layerId) {
invokeMethod(map, NULL, "removeImage", layerId)
}
#' @rdname remove
#' @export
clearImages <- function(map) {
invokeMethod(map, NULL, "clearImages")
}
#' Extra options for map elements and layers
#'
#' The rest of all possible options for map elements and layers that are not
#' listed in the layer functions.
#' @param
#' minZoom,maxZoom,maxNativeZoom,tileSize,subdomains,errorTileUrl,tms,noWrap,zoomOffset,zoomReverse,zIndex,unloadInvisibleTiles,updateWhenIdle,detectRetina
#' the tile layer options; see
#' <https://web.archive.org/web/20220702182250/https://leafletjs.com/reference-1.3.4.html#tilelayer>
#' @param ... extra options passed to underlying Javascript object constructor.
#' @describeIn map-options Options for tile layers
#' @export
tileOptions <- function(
minZoom = 0,
maxZoom = 18,
maxNativeZoom = NULL,
tileSize = 256,
subdomains = "abc",
errorTileUrl = "",
tms = FALSE,
noWrap = FALSE,
zoomOffset = 0,
zoomReverse = FALSE,
opacity = 1.0,
zIndex = 1,
unloadInvisibleTiles = NULL,
updateWhenIdle = NULL,
detectRetina = FALSE,
...
) {
filterNULL(list(
minZoom = minZoom, maxZoom = maxZoom, maxNativeZoom = maxNativeZoom,
tileSize = tileSize, subdomains = subdomains, errorTileUrl = errorTileUrl,
tms = tms, noWrap = noWrap,
zoomOffset = zoomOffset, zoomReverse = zoomReverse, opacity = opacity,
zIndex = zIndex, unloadInvisibleTiles = unloadInvisibleTiles,
updateWhenIdle = updateWhenIdle, detectRetina = detectRetina,
...
))
}
#' @describeIn map-options Options for grid layers
#' @export
gridOptions <- function(
tileSize = 256,
updateWhenIdle = NULL,
zIndex = 1,
minZoom = 0,
maxZoom = NULL,
...
) {
filterNULL(list(
tileSize = tileSize, updateWhenIdle = updateWhenIdle, zIndex = zIndex,
minZoom = minZoom, maxZoom = maxZoom,
...
))
}
#' Remove elements from a map
#'
#' Remove one or more features from a map, identified by `layerId`; or,
#' clear all features of the given type or group.
#'
#' @note When used with a [leaflet][leaflet()] map object, these functions
#' don't actually remove the features from the map object, but simply add an
#' operation that will cause those features to be removed after they are
#' added. In other words, if you add a polygon `"foo"` and the call
#' `removeShape("foo")`, it's not smart enough to prevent the polygon
#' from being added in the first place; instead, when the map is rendered, the
#' polygon will be added and then removed.
#'
#' For that reason, these functions aren't that useful with `leaflet` map
#' objects and are really intended to be used with [leafletProxy()]
#' instead.
#'
#' WMS tile layers are extensions of tile layers, so they can also be removed
#' or cleared via `removeTiles()` or `clearTiles()`.
#' @param map a map widget object, possibly created from [leaflet()]
#' but more likely from [leafletProxy()]
#' @param layerId character vector; the layer id(s) of the item to remove
#' @return the new `map` object
#'
#' @name remove
#' @export
removeTiles <- function(map, layerId) {
invokeMethod(map, getMapData(map), "removeTiles", layerId)
}
#' @rdname remove
#' @export
clearTiles <- function(map) {
invokeMethod(map, NULL, "clearTiles")
}
#' @param baseUrl a base URL of the WMS service
#' @param layers comma-separated list of WMS layers to show
#' @describeIn map-layers Add a WMS tile layer to the map
#' @export
addWMSTiles <- function(
map, baseUrl, layerId = NULL, group = NULL,
options = WMSTileOptions(), attribution = NULL, layers = "",
data = getMapData(map)
) {
if (identical(layers, "")) {
stop("layers is a required argument with comma-separated list of WMS layers to show")
}
options$attribution <- attribution
options$layers <- layers
invokeMethod(map, data, "addWMSTiles", baseUrl, layerId, group, options)
}
#' @param styles comma-separated list of WMS styles
#' @param format WMS image format (use `"image/png"` for layers with
#' transparency)
#' @param transparent if `TRUE`, the WMS service will return images with
#' transparency
#' @param version version of the WMS service to use
#' @param crs Coordinate Reference System to use for the WMS requests, defaults.
#' @seealso [leafletCRS()]
#' to map CRS (don't change this if you're not sure what it means)
#' @describeIn map-options Options for WMS tile layers
#' @export
WMSTileOptions <- function(
styles = "", format = "image/jpeg", transparent = FALSE, version = "1.1.1",
crs = NULL, ...
) {
filterNULL(list(
styles = styles, format = format, transparent = transparent,
version = version, crs = crs, ...
))
}
#' @param lng a numeric vector of longitudes, or a one-sided formula of the form
#' `~x` where `x` is a variable in `data`; by default (if not
#' explicitly provided), it will be automatically inferred from `data` by
#' looking for a column named `lng`, `long`, or `longitude`
#' (case-insensitively)
#' @param lat a vector of latitudes or a formula (similar to the `lng`
#' argument; the names `lat` and `latitude` are used when guessing
#' the latitude column from `data`)
#' @param popup a character vector of the HTML content for the popups (you are
#' recommended to escape the text using [htmltools::htmlEscape()]
#' for security reasons)
#' @param popupOptions A Vector of [popupOptions()] to provide popups
#' @param layerId the layer id
#' @param group the name of the group the newly created layers should belong to
#' (for [clearGroup()] and [addLayersControl()] purposes).
#' Human-friendly group names are permitted--they need not be short,
#' identifier-style names. Any number of layers and even different types of
#' layers (e.g. markers and polygons) can share the same group name.
#' @template data-getMapData
#' @describeIn map-layers Add popups to the map
#' @export
addPopups <- function(
map, lng = NULL, lat = NULL, popup, layerId = NULL, group = NULL,
options = popupOptions(),
data = getMapData(map)
) {
pts <- derivePoints(data, lng, lat, missing(lng), missing(lat), "addPopups")
invokeMethod(map, data, "addPopups", pts$lat, pts$lng, popup, layerId, group, options) %>%
expandLimits(pts$lat, pts$lng)
}
#' @param className a CSS class name set on an element
#' @param
#' maxWidth,minWidth,maxHeight,autoPan,keepInView,closeButton,closeOnClick
#' popup options; see <https://web.archive.org/web/20220702182250/https://leafletjs.com/reference-1.3.4.html#popup-option>
#' @describeIn map-options Options for popups
#' @export
popupOptions <- function(
maxWidth = 300,
minWidth = 50,
maxHeight = NULL,
autoPan = TRUE,
keepInView = FALSE,
closeButton = TRUE,
zoomAnimation = NULL,
closeOnClick = NULL,
className = "",
...
) {
if (!missing(zoomAnimation)) {
zoomAnimationWarning()
}
filterNULL(list(
maxWidth = maxWidth, minWidth = minWidth, maxHeight = maxHeight,
autoPan = autoPan, keepInView = keepInView, closeButton = closeButton,
closeOnClick = closeOnClick, className = className, ...
))
}
#' @rdname remove
#' @export
removePopup <- function(map, layerId) {
invokeMethod(map, getMapData(map), "removePopup", layerId)
}
#' @rdname remove
#' @export
clearPopups <- function(map) {
invokeMethod(map, NULL, "clearPopups")
}
#' Sanitize textual labels
#'
#' This is a helper function used internally to HTML-escape user-provided
#' labels. It prevents strings from unintentionally being treated as HTML when
#' they are intended to be plaintext.
#'
#' @param label A vector or list of plain characters or HTML (marked by
#' [htmltools::HTML()]), or a formula that resolves to such a value.
#' @param data A data frame over which the formula is evaluated.
#'
#' @keywords internal
#' @export
safeLabel <- function(label, data) {
if (is.null(label)) {
return(label)
}
label <- evalFormula(label, data)
if (
! (
inherits(label, "html") ||
sum(sapply(label, function(x) {!inherits(x, "html")})) == 0 # nolint
)
) {
label <- htmltools::htmlEscape(label)
}
label
}
#' @param
#' noHide,direction,offset,permanent
#' label options; see <https://web.archive.org/web/20220702182250/https://leafletjs.com/reference-1.3.4.html#tooltip-option>
#' @param opacity Tooltip container opacity. Ranges from 0 to 1. Default value is `1` (different from leaflet.js `0.9`); see <https://web.archive.org/web/20220702182250/https://leafletjs.com/reference-1.3.4.html#tooltip-opacity>
#' @param textsize Change the text size of a single tooltip
#' @param textOnly Display only the text, no regular surrounding box.
#' @param style list of css style to be added to the tooltip
#' @param zoomAnimation deprecated. See <https://github.com/Leaflet/Leaflet/blob/master/CHANGELOG.md#api-changes-5>
#' @param sticky If true, the tooltip will follow the mouse instead of being fixed at the feature center. Default value is `TRUE` (different from leaflet.js `FALSE`); see <https://web.archive.org/web/20220702182250/https://leafletjs.com/reference-1.3.4.html#tooltip-sticky>
#' @describeIn map-options Options for labels
#' @export
labelOptions <- function(
interactive = FALSE,
clickable = NULL,
noHide = NULL,
permanent = FALSE,
className = "",
direction = "auto",
offset = c(0, 0),
opacity = 1,
textsize = "10px",
textOnly = FALSE,
style = NULL,
zoomAnimation = NULL,
sticky = TRUE,
...
) {
# use old (Leaflet 0.7.x) clickable if provided
if (!is.null(clickable) && interactive != clickable) interactive <- clickable
# use old noHide if provided
if (!is.null(noHide) && permanent != noHide) permanent <- noHide
if (!missing(zoomAnimation)) {
zoomAnimationWarning()
}
filterNULL(list(
interactive = interactive, permanent = permanent, direction = direction,
opacity = opacity, offset = offset,
textsize = textsize, textOnly = textOnly, style = style,
className = className, sticky = sticky, ...
))
}
#' @param icon the icon(s) for markers; an icon is represented by an R list of
#' the form `list(iconUrl = "?", iconSize = c(x, y))`, and you can use
#' [icons()] to create multiple icons; note when you use an R list
#' that contains images as local files, these local image files will be base64
#' encoded into the HTML page so the icon images will still be available even
#' when you publish the map elsewhere
#' @param label a character vector of the HTML content for the labels
#' @param labelOptions A Vector of [labelOptions()] to provide label
#' options for each label. Default `NULL`
#' @param clusterOptions if not `NULL`, markers will be clustered using
#' [Leaflet.markercluster](https://github.com/Leaflet/Leaflet.markercluster);
#' you can use [markerClusterOptions()] to specify marker cluster
#' options
#' @param clusterId the id for the marker cluster layer
#' @describeIn map-layers Add markers to the map
#' @export
addMarkers <- function(
map, lng = NULL, lat = NULL, layerId = NULL, group = NULL,
icon = NULL,
popup = NULL,
popupOptions = NULL,
label = NULL,
labelOptions = NULL,
options = markerOptions(),
clusterOptions = NULL,
clusterId = NULL,
data = getMapData(map)
) {
if (missing(labelOptions)) labelOptions <- labelOptions()
if (!is.null(icon)) {
# If custom icons are specified, we need to 1) deduplicate any URLs/files,
# so we can efficiently send e.g. 1000 markers that all use the same 2
# icons; and 2) do base64 encoding on any local icon files (as opposed to
# URLs [absolute or relative] which will be left alone).
# If formulas are present, they must be evaluated first so we can pack the
# resulting values
icon <- evalFormula(list(icon), data)[[1]]
if (inherits(icon, "leaflet_icon_set")) {
icon <- iconSetToIcons(icon)
}
# Pack and encode each URL vector; this will be reversed on the client
icon$iconUrl <- b64EncodePackedIcons(packStrings(icon$iconUrl))
icon$iconRetinaUrl <- b64EncodePackedIcons(packStrings(icon$iconRetinaUrl))
icon$shadowUrl <- b64EncodePackedIcons(packStrings(icon$shadowUrl))
icon$shadowRetinaUrl <- b64EncodePackedIcons(packStrings(icon$shadowRetinaUrl))
# if iconSize is of length 2 and there is one icon url, wrap the icon size in a list
if (length(icon$iconSize) == 2) {
if (is.numeric(icon$iconSize[[1]]) && is.numeric(icon$iconSize[[2]])) {
icon$iconSize <- list(icon$iconSize)
}
}
icon <- filterNULL(icon)
}
if (!is.null(clusterOptions))
map$dependencies <- c(map$dependencies, markerClusterDependencies())
pts <- derivePoints(data, lng, lat, missing(lng), missing(lat), "addMarkers")
invokeMethod(
map, data, "addMarkers", pts$lat, pts$lng, icon, layerId, group, options,
popup, popupOptions, clusterOptions, clusterId,
safeLabel(label, data), labelOptions,
getCrosstalkOptions(data)
) %>% expandLimits(pts$lat, pts$lng)
}
getCrosstalkOptions <- function(data) {
if (is.SharedData(data)) {
list(ctKey = data$key(), ctGroup = data$groupName())
} else {
NULL
}
}
#' @describeIn map-layers Add Label only markers to the map
#' @export
addLabelOnlyMarkers <- function(
map, lng = NULL, lat = NULL, layerId = NULL, group = NULL,
icon = NULL,
label = NULL,
labelOptions = NULL,
options = markerOptions(),
clusterOptions = NULL,
clusterId = NULL,
data = getMapData(map)
) {
if (missing(labelOptions)) labelOptions <- labelOptions()
do.call(addMarkers, filterNULL(list(
map = map, lng = lng, lat = lat, layerId = layerId,
group = group,
icon = makeIcon(
iconUrl = system_file("htmlwidgets/lib/rstudio_leaflet/images/1px.png", package = "leaflet"),
iconWidth = 1, iconHeight = 1),
label = label,
labelOptions = labelOptions,
options = options,
clusterOptions = clusterOptions,
clusterId = clusterId,
data = data