/
plugin-awesomeMarkers.R
302 lines (277 loc) · 9.82 KB
/
plugin-awesomeMarkers.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
leafletAwesomeMarkersDependencies <- function() {
list(
htmltools::htmlDependency(
"leaflet-awesomemarkers",
"2.0.3",
"htmlwidgets/plugins/Leaflet.awesome-markers",
package = "leaflet",
script = c("leaflet.awesome-markers.min.js"),
stylesheet = c("leaflet.awesome-markers.css")
)
)
}
leafletAmBootstrapDependencies <- function(map) {
list(
htmltools::htmlDependency(
"bootstrap",
"3.3.7",
"htmlwidgets/plugins/Leaflet.awesome-markers",
package = "leaflet",
script = c("bootstrap.min.js"),
stylesheet = c("bootstrap.min.css")
)
)
}
# Required for using BootStrap Fonts
# @param map the map to add awesome Markers to.
addBootstrap <- function(map) {
map$dependencies <- c(map$dependencies, leafletAmBootstrapDependencies())
map
}
leafletAmFontAwesomeDependencies <- function(map) {
list(
htmltools::htmlDependency(
"fontawesome",
"4.7.0",
"htmlwidgets/plugins/Leaflet.awesome-markers",
package = "leaflet",
stylesheet = c("font-awesome.min.css")
)
)
}
# Required for using Font-Awesome Fonts
# @param map the map to add awesome Markers to.
addFontAwesome <- function(map) {
map$dependencies <- c(map$dependencies, leafletAmFontAwesomeDependencies())
map
}
leafletAmIonIconDependencies <- function(map) {
list(
htmltools::htmlDependency(
"ionicons",
"2.0.1",
"htmlwidgets/plugins/Leaflet.awesome-markers",
package = "leaflet",
stylesheet = c("ionicons.min.css")
)
)
}
# Required for using IonIcon Fonts
# @param map the map to add awesome Markers to.
addIonIcon <- function(map) {
map$dependencies <- c(map$dependencies, leafletAmIonIconDependencies())
map
}
#' Make awesome-icon set
#'
#' @param ... icons created from [makeAwesomeIcon()]
#' @export
#' @examples
#'
#' iconSet <- awesomeIconList(
#' home = makeAwesomeIcon(icon = "Home", library = "fa"),
#' flag = makeAwesomeIcon(icon = "Flag", library = "fa")
#' )
#'
#' iconSet[c("home", "flag")]
awesomeIconList <- function(...) {
res <- structure(
list(...),
class = "leaflet_awesome_icon_set"
)
cls <- unlist(lapply(res, inherits, "leaflet_awesome_icon"))
if (any(!cls))
stop("Arguments passed to awesomeIconList() must be icon objects returned from makeAwesomeIcon()") # nolint
res
}
#' @export
`[.leaflet_awesome_icon_set` <- function(x, i) {
if (is.factor(i)) {
i <- as.character(i)
}
if (!is.character(i) && !is.numeric(i) && !is.integer(i)) {
stop("Invalid subscript type '", typeof(i), "'")
}
structure(.subset(x, i), class = "leaflet_awesome_icon_set")
}
awesomeIconSetToAwesomeIcons <- function(x) {
# c("icon", "library", ...)
cols <- names(formals(makeAwesomeIcon))
# list(icon = "icon", library = "library", ...)
cols <- structure(as.list(cols), names = cols)
# Construct an equivalent output to awesomeIcons().
filterNULL(lapply(cols, function(col) {
# Pluck the `col` member off of each item in awesomeIconObjs and put them in an
# unnamed list (or vector if possible).
colVals <- unname(sapply(x, `[[`, col))
# If this is the common case where there's lots of values but they're all
# actually the same exact thing, then just return one value; this will be
# much cheaper to send to the client, and we'll do recycling on the client
# side anyway.
if (length(unique(colVals)) == 1) {
return(colVals[[1]])
} else {
return(colVals)
}
}))
}
#' Make Awesome Icon
#'
#' @inheritParams awesomeIcons
#' @export
makeAwesomeIcon <- function(
icon = "home",
library = "glyphicon",
markerColor = "blue",
iconColor = "white",
spin = FALSE,
extraClasses = NULL,
squareMarker = FALSE,
iconRotate = 0,
fontFamily = "monospace",
text = NULL
) {
if (!inherits(library, "formula")) {
verifyIconLibrary(library)
}
icon <- filterNULL(list(
icon = icon, library = library, markerColor = markerColor,
iconColor = iconColor, spin = spin, extraClasses = extraClasses,
squareMarker = squareMarker, iconRotate = iconRotate,
font = fontFamily, text = text
))
structure(icon, class = "leaflet_awesome_icon")
}
#' Create a list of awesome icon data
#'
#' An icon can be represented as a list of the form `list(icon, library,
#' ...)`. This function is vectorized over its arguments to create a list of
#' icon data. Shorter argument values will be recycled. `NULL` values for
#' these arguments will be ignored.
#' @seealso <https://github.com/lennardv2/Leaflet.awesome-markers>
#' @param icon Name of the icon
#' @param library Which icon library. Default `"glyphicon"`, other possible
#' values are `"fa"` (fontawesome) or `"ion"` (ionicons).
#' @param markerColor Possible values are `"red"`, `"darkred"`, `"lightred"`, `"orange"`,
#' `"beige"`, `"green"`, `"darkgreen"`, `"lightgreen"`, `"blue"`,
#' `"darkblue"`, `"lightblue"`, `"purple"`, `"darkpurple"`, `"pink"`,
#' `"cadetblue"`, `"white"`, `"gray"`, `"lightgray"`, `"black"`
#' @param iconColor The color to use for the icon itself. Use any CSS-valid
#' color (hex, rgba, etc.) or a named web color.
#' @param spin If `TRUE`, make the icon spin (only works when `library = "fa"`)
#' @param extraClasses Additional css classes to include on the icon.
#' @return A list of awesome-icon data that can be passed to the `icon`
#' @param squareMarker Whether to use a square marker.
#' @param iconRotate Rotate the icon by a given angle.
#' @param fontFamily Used when `text` option is specified.
#' @param text Use this text string instead of an icon. Argument of
#' [addAwesomeMarkers()].
#' @export
awesomeIcons <- function(
icon = "home",
library = "glyphicon",
markerColor = "blue",
iconColor = "white",
spin = FALSE,
extraClasses = NULL,
squareMarker = FALSE,
iconRotate = 0,
fontFamily = "monospace",
text = NULL
) {
if (!inherits(library, "formula")) {
verifyIconLibrary(library)
}
filterNULL(list(
icon = icon, library = library, markerColor = markerColor,
iconColor = iconColor, spin = spin, extraClasses = extraClasses,
squareMarker = squareMarker, iconRotate = iconRotate,
font = fontFamily, text = text
))
}
verifyIconLibrary <- function(library) {
bad <- library[!(library %in% c("glyphicon", "fa", "ion"))]
if (length(bad) > 0) {
stop("Invalid icon library names: ", paste(unique(bad), collapse = ", "))
}
}
#' Add Awesome Markers
#' @param map the map to add awesome Markers to.
#' @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.
#' @param data the data object from which the argument values are derived; by
#' default, it is the `data` object provided to `leaflet()`
#' initially, but can be overridden
#' @param icon the icon(s) for markers;
#' @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
#' @param options a list of extra options for tile layers, popups, paths
#' (circles, rectangles, polygons, ...), or other map elements
#' @export
addAwesomeMarkers <- 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()
map$dependencies <- c(map$dependencies, leafletAwesomeMarkersDependencies())
if (!is.null(icon)) {
# 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_awesome_icon_set")) {
icon <- awesomeIconSetToAwesomeIcons(icon)
}
icon <- filterNULL(icon)
verifyIconLibrary(icon$library)
lapply(unique(icon$library), function(lib) {
libFunc <- switch(lib,
glyphicon = addBootstrap,
fa = addFontAwesome,
ion = addIonIcon,
default = stop("Unknown icon library \"", lib, "\"")
)
map <<- libFunc(map)
})
icon$prefix <- icon$library
icon$library <- NULL
}
if (!is.null(clusterOptions))
map$dependencies <- c(map$dependencies, markerClusterDependencies())
pts <- derivePoints(data, lng, lat, missing(lng), missing(lat), "addAwesomeMarkers")
invokeMethod(
map, data, "addAwesomeMarkers", pts$lat, pts$lng, icon, layerId,
group, options, popup, popupOptions,
clusterOptions, clusterId, safeLabel(label, data), labelOptions,
getCrosstalkOptions(data)
) %>% expandLimits(pts$lat, pts$lng)
}