/
utils.R
313 lines (282 loc) · 10.5 KB
/
utils.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
# @staticimports pkg:staticimports
# is_installed system_file get_package_version
# Given a local and/or remote operation and a map, execute one or the other
# depending on the type of the map object (regular or map proxy). If code was
# not provided for the appropriate mode, an error will be raised.
#' Extension points for plugins
#'
#' @param map a map object, as returned from [leaflet()] or [leafletProxy()]
#' @param funcName the name of the function that the user called that caused
#' this `dispatch` call; for error message purposes
#' @param leaflet an action to be performed if the map is from [leaflet()]
#' @param leaflet_proxy an action to be performed if the map is from [leafletProxy()].
#'
#' @return `dispatch()` returns the value of `leaflet` or
#' `leaflet_proxy()`, or an error. `invokeMethod()` returns the
#' `map` object that was passed in, possibly modified.
#'
#' @export
dispatch <- function(map,
funcName,
leaflet = stop(paste(funcName, "requires a map proxy object")),
leaflet_proxy = stop(paste(funcName, "does not support map proxy objects"))
) {
if (inherits(map, "leaflet"))
return(leaflet)
else if (inherits(map, "leaflet_proxy"))
return(leaflet_proxy)
else
stop("Invalid map parameter")
}
#' Remove NULL elements from a list
#' @param x A list.
#' @export
#' @returns A list with `NULL` elements filtered out.
#' @keywords internal
filterNULL <- function(x) {
if (length(x) == 0 || !is.list(x)) return(x)
x[!unlist(lapply(x, is.null))]
}
#' @param data a data object that will be used when evaluating formulas in `...`
#' @param method the name of the JavaScript method to invoke
#' @param ... unnamed arguments to be passed to the JavaScript method
#' @rdname dispatch
#' @import crosstalk
#' @export
invokeMethod <- function(map, data, method, ...) {
if (crosstalk::is.SharedData(data)) {
map$dependencies <- c(map$dependencies, crosstalk::crosstalkLibs())
data <- data$data()
} else {
NULL
}
args <- evalFormula(list(...), data)
dispatch(map,
method,
leaflet = {
x <- map$x$calls
if (is.null(x)) x <- list()
n <- length(x)
x[[n + 1]] <- list(method = method, args = args)
map$x$calls <- x
map
},
leaflet_proxy = {
invokeRemote(map, method, args)
map
}
)
}
#' Send commands to a Leaflet instance in a Shiny app
#'
#' Creates a map-like object that can be used to customize and control a map
#' that has already been rendered. For use in Shiny apps and Shiny docs only.
#'
#' Normally, you create a Leaflet map using [leaflet()].
#' This creates an in-memory representation of a map that you can customize
#' using functions like [addPolygons()] and [setView()].
#' Such a map can be printed at the R console, included in an R Markdown
#' document, or rendered as a Shiny output.
#'
#' In the case of Shiny, you may want to further customize a map, even after it
#' is rendered to an output. At this point, the in-memory representation of the
#' map is long gone, and the user's web browser has already realized the Leaflet
#' map instance.
#'
#' This is where `leafletProxy()` comes in. It returns an object that can
#' stand in for the usual Leaflet map object. The usual map functions like
#' [addPolygons()] and [setView()] can be called, and
#' instead of customizing an in-memory representation, these commands will
#' execute on the live Leaflet map instance.
#'
#' @param mapId single-element character vector indicating the output ID of the
#' map to modify (if invoked from a Shiny module, the namespace will be added
#' automatically)
#' @param session the Shiny session object to which the map belongs; usually the
#' default value will suffice
#' @param data a data object; see Details under the [leaflet()] help
#' topic
#' @param deferUntilFlush indicates whether actions performed against this
#' instance should be carried out right away, or whether they should be held
#' until after the next time all of the outputs are updated; defaults to
#' `TRUE`
#'
#' @examples
#' library(shiny)
#'
#' ui <- fluidPage(
#' leafletOutput("map1")
#' )
#'
#' map <- leaflet() %>% addCircleMarkers(
#' lng = runif(10),
#' lat = runif(10),
#' layerId = paste0("marker", 1:10))
#' server <- function(input, output, session) {
#' output$map1 <- renderLeaflet(map)
#'
#' observeEvent(input$map1_marker_click, {
#' leafletProxy("map1", session) %>%
#' removeMarker(input$map1_marker_click$id)
#' })
#' }
#'
#' app <- shinyApp(ui, server)
#' \donttest{if (interactive()) app}
#'
#' @export
leafletProxy <- function(mapId, session = shiny::getDefaultReactiveDomain(),
data = NULL, deferUntilFlush = TRUE) {
if (is.null(session)) {
stop("leafletProxy must be called from the server function of a Shiny app")
}
# If this is a new enough version of Shiny that it supports modules, and
# we're in a module (nzchar(session$ns(NULL))), and the mapId doesn't begin
# with the current namespace, then add the namespace.
#
# We could also have unconditionally done `mapId <- session$ns(mapId)`, but
# older versions of Leaflet would have broken unless the user did session$ns
# themselves, and we hate to break their code unnecessarily.
#
# This won't be necessary in future versions of Shiny, as session$ns (and
# other forms of ns()) will be smart enough to only namespace un-namespaced
# IDs.
if (
!is.null(session$ns) &&
nzchar(session$ns(NULL)) &&
substring(mapId, 1, nchar(session$ns(""))) != session$ns("")
) {
mapId <- session$ns(mapId)
}
structure(
list(
session = session,
id = mapId,
x = structure(
list(),
leafletData = data
),
deferUntilFlush = deferUntilFlush,
dependencies = NULL
),
class = "leaflet_proxy"
)
}
# Shiny versions <= 0.12.0.9001 can't guarantee that onFlushed
# callbacks are called in the order they were registered. Rather
# than wait for this to be fixed in Shiny and released to CRAN,
# work around this for older versions by maintaining our own
# queue of work items. The names in this environment are session
# tokens, and the values are lists of invokeRemote msg objects.
# During the course of execution, leafletProxy() should cause
# deferred messages to be appended to the appropriate value in
# sessionFlushQueue. It's the responsibility of invokeRemote to
# ensure that the sessionFlushQueue values are properly reaped
# as soon as possible, to prevent session objects from being
# leaked.
#
# When Shiny >0.12.0 goes to CRAN, we should update our version
# dependency and remove this entire mechanism.
sessionFlushQueue <- new.env(parent = emptyenv())
invokeRemote <- function(map, method, args = list()) {
if (!inherits(map, "leaflet_proxy"))
stop("Invalid map parameter; map proxy object was expected")
deps <- htmltools::resolveDependencies(map$dependencies)
msg <- list(
id = map$id,
calls = list(
list(
dependencies = lapply(deps, shiny::createWebDependency),
method = method,
args = args,
evals = htmlwidgets::JSEvals(args)
)
)
)
sess <- map$session
if (map$deferUntilFlush) {
if (is_installed("shiny", "0.12.1.9000")) {
# See comment on sessionFlushQueue.
if (is.null(sessionFlushQueue[[sess$token]])) {
# If the current session doesn't have an entry in the sessionFlushQueue,
# initialize it with a blank list.
sessionFlushQueue[[sess$token]] <- list()
# If the session ends before the next onFlushed call, remove the entry
# for this session from the sessionFlushQueue.
endedUnreg <- sess$onSessionEnded(function() {
rm(list = sess$token, envir = sessionFlushQueue)
})
# On the next flush, pass all the messages to the client, and remove the
# entry from sessionFlushQueue.
sess$onFlushed(function() {
on.exit(rm(list = sess$token, envir = sessionFlushQueue), add = TRUE)
endedUnreg()
for (msg in sessionFlushQueue[[sess$token]]) {
sess$sendCustomMessage("leaflet-calls", msg)
}
}, once = TRUE) # nolint
}
# Append the current value to the apporpriate sessionFlushQueue entry,
# which is now guaranteed to exist.
sessionFlushQueue[[sess$token]] <- c(sessionFlushQueue[[sess$token]], list(msg))
} else {
sess$onFlushed(function() {
sess$sendCustomMessage("leaflet-calls", msg)
}, once = TRUE) # nolint
}
} else {
sess$sendCustomMessage("leaflet-calls", msg)
}
map
}
# A helper function to generate the body of function(x, y) list(x = x, y = y),
# to save some typing efforts in writing tileOptions(), markerOptions(), ...
makeListFun <- function(list) {
if (is.function(list)) list <- formals(list)
nms <- names(list)
cat(sprintf("list(%s)\n", paste(nms, nms, sep = " = ", collapse = ", ")))
}
"%||%" <- function(a, b) {
if (!is.null(a)) a else b
}
#' Utility function to check if a coordinates is valid
#' @param lng vector with longitude values
#' @param lat vector with latitude values
#' @param funcName Name of calling function
#' @param warn A boolean. Whether to generate a warning message if there are rows with missing/invalid data
#' @param mode if `"point"` then warn about any `NA` lng/lat values;
#' if `"polygon"` then `NA` values are expected to be used as
#' polygon delimiters
#' @export
validateCoords <- function(lng, lat, funcName, warn = TRUE,
mode = c("point", "polygon")) {
mode <- match.arg(mode)
if (is.null(lng) && is.null(lat)) {
stop(funcName, " requires non-NULL longitude/latitude values")
} else if (is.null(lng)) {
stop(funcName, " requires non-NULL longitude values")
} else if (is.null(lat)) {
stop(funcName, " requires non-NULL latitude values")
}
if (!is.numeric(lng) && !is.numeric(lat)) {
stop(funcName, " requires numeric longitude/latitude values")
} else if (!is.numeric(lng)) {
stop(funcName, " requires numeric longitude values")
} else if (!is.numeric(lat)) {
stop(funcName, " requires numeric latitude values")
}
if (mode == "point") {
incomplete <- is.na(lat) | is.na(lng)
if (any(incomplete)) {
warning(sprintf("Data contains %s rows with either missing or invalid lat/lon values and will be ignored", sum(incomplete))) # nolint
}
} else if (mode == "polygon") {
incomplete <- is.na(lat) != is.na(lng)
if (any(incomplete)) {
warning(sprintf("Data contains %s rows with either missing or invalid lat/lon values and will be ignored", sum(incomplete))) # nolint
}
lng <- lng[!incomplete]
lat <- lat[!incomplete]
}
data.frame(lng = lng, lat = lat)
}