Shiny interactivity

DESCRIPTION

@@ -31,5 +31,6 @@ Suggests:
     maps,
     shiny,
     sp,
-    testit
+    testit,
+    R6
 VignetteBuilder: knitr

NAMESPACE

@@ -15,20 +15,33 @@ export(addPopups)
 export(addRectangles)
 export(addTiles)
 export(clearBounds)
+export(clearGeoJSON)
+export(clearMarkers)
+export(clearPopups)
+export(clearShapes)
+export(clearTiles)
 export(colorBin)
 export(colorFactor)
 export(colorNumeric)
 export(colorQuantile)
 export(createLeafletMap)
+export(dispatch)
 export(fitBounds)
+export(invokeMethod)
 export(leaflet)
 export(leafletMap)
 export(leafletOutput)
+export(leafletProxy)
 export(mapOptions)
 export(markerOptions)
 export(pathOptions)
 export(popupOptions)
 export(previewColors)
+export(removeGeoJSON)
+export(removeMarker)
+export(removePopup)
+export(removeShape)
+export(removeTiles)
 export(renderLeaflet)
 export(setView)
 export(tileOptions)

R/layers.R

@@ -60,6 +60,7 @@ bboxAdd = function(a, b) {
 #' @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 \code{map} object
 #' @seealso \code{\link{tileOptions}}, \code{\link{popupOptions}},
 #'   \code{\link{markerOptions}}, \code{\link{pathOptions}}
 #' @references The Leaflet API documentation:
@@ -70,6 +71,7 @@ addTiles = function(
   map,
   urlTemplate = 'http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png',
   attribution = NULL,
+  layerId = NULL,
   options = tileOptions()
 ) {
   options$attribution = attribution
@@ -78,7 +80,7 @@ addTiles = function(
       '&copy; <a href="http://openstreetmap.org">OpenStreetMap</a>',
       'contributors, <a href="http://creativecommons.org/licenses/by-sa/2.0/">CC-BY-SA</a>'
     )
-  appendMapData(map, getMapData(map), 'tileLayer', urlTemplate, options)
+  invokeMethod(map, getMapData(map), 'addTiles', urlTemplate, layerId, options)
 }
 
 #' Extra options for map elements and layers
@@ -122,6 +124,40 @@ tileOptions = function(
   )
 }
 
+#' Remove elements from a map
+#'
+#' Remove one or more features from a map, identified by \code{layerId}; or,
+#' clear all features of the given type.
+#'
+#' @note When used with a \code{\link{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 \code{"foo"} and the call
+#' \code{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 \code{leaflet} map
+#' objects and are really intended to be used with \code{\link{leafletProxy}}
+#' instead.
+#'
+#' @param map a map widget object, possibly created from \code{\link{leaflet}}()
+#'   but more likely from \code{\link{leafletProxy}}()
+#' @param layerId character vector; the layer id(s) of the item to remove
+#' @return the new \code{map} object
+#'
+#' @name remove
+#' @export
+removeTiles = function(map, layerId) {
+  invokeMethod(map, NULL, 'removeTiles', layerId)
+}
+
+#' @rdname remove
+#' @export
+clearTiles = function(map) {
+  invokeMethod(map, NULL, 'clearTiles')
+}
+
 #' @param lng a numeric vector of longitudes, or a one-sided formula of the form
 #'   \code{~x} where \code{x} is a variable in \code{data}; by default (if not
 #'   explicitly provided), it will be automatically inferred from \code{data} by
@@ -145,7 +181,7 @@ addPopups = function(
   data = getMapData(map)
 ) {
   pts = derivePoints(data, lng, lat, missing(lng), missing(lat), "addPopups")
-  appendMapData(map, data, 'popup', pts$lat, pts$lng, popup, layerId, options) %>%
+  invokeMethod(map, data, 'addPopups', pts$lat, pts$lng, popup, layerId, options) %>%
     expandLimits(pts$lat, pts$lng)
 }
 
@@ -177,6 +213,18 @@ popupOptions = function(
   )
 }
 
+#' @rdname remove
+#' @export
+removePopup = function(map, layerId) {
+  invokeMethod(map, NULL, 'removePopup', layerId)
+}
+
+#' @rdname remove
+#' @export
+clearPopups = function(map) {
+  invokeMethod(map, NULL, 'clearPopups')
+}
+
 #' @param icon the icon for markers; if you want to create a new icon using
 #'   JavaScript, please remember to use \code{\link[htmlwidgets]{JS}()} on the
 #'   JavaScript string; see \url{http://leafletjs.com/reference.html#icon}
@@ -191,7 +239,7 @@ addMarkers = function(
 ) {
   options$icon = icon
   pts = derivePoints(data, lng, lat, missing(lng), missing(lat), "addMarkers")
-  appendMapData(map, data, 'marker', pts$lat, pts$lng, layerId, options, popup) %>%
+  invokeMethod(map, data, 'addMarkers', pts$lat, pts$lng, layerId, options, popup) %>%
     expandLimits(pts$lat, pts$lng)
 }
 
@@ -256,10 +304,22 @@ addCircleMarkers = function(
     dashArray = dashArray
   ))
   pts = derivePoints(data, lng, lat, missing(lng), missing(lat), "addCircleMarkers")
-  appendMapData(map, data, 'circleMarker', pts$lat, pts$lng, radius, layerId, options, popup) %>%
+  invokeMethod(map, data, 'addCircleMarkers', pts$lat, pts$lng, radius, layerId, options, popup) %>%
     expandLimits(pts$lat, pts$lng)
 }
 
+#' @rdname remove
+#' @export
+removeMarker = function(map, layerId) {
+  invokeMethod(map, NULL, 'removeMarker', layerId)
+}
+
+#' @rdname remove
+#' @export
+clearMarkers = function(map) {
+  invokeMethod(map, NULL, 'clearMarkers')
+}
+
 #' @param lineCap a string that defines
 #'   \href{https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-linecap}{shape
 #'    to be used at the end} of the stroke
@@ -306,7 +366,7 @@ addCircles = function(
     dashArray = dashArray
   ))
   pts = derivePoints(data, lng, lat, missing(lng), missing(lat), "addCircles")
-  appendMapData(map, data, 'circle', pts$lat, pts$lng, radius, layerId, options, popup) %>%
+  invokeMethod(map, data, 'addCircles', pts$lat, pts$lng, radius, layerId, options, popup) %>%
     expandLimits(pts$lat, pts$lng)
 }
 
@@ -337,7 +397,7 @@ addPolylines = function(
     dashArray = dashArray, smoothFactor = smoothFactor, noClip = noClip
   ))
   pgons = derivePolygons(data, lng, lat, missing(lng), missing(lat), "addPolylines")
-  appendMapData(map, data, 'polyline', pgons, layerId, options, popup) %>%
+  invokeMethod(map, data, 'addPolylines', pgons, layerId, options, popup) %>%
     expandLimitsBbox(pgons)
 }
 
@@ -370,7 +430,7 @@ addRectangles = function(
   lat1 = resolveFormula(lat1, data)
   lng2 = resolveFormula(lng2, data)
   lat2 = resolveFormula(lat2, data)
-  appendMapData(map, data, 'rectangle',lat1, lng1, lat2, lng2, layerId, options, popup) %>%
+  invokeMethod(map, data, 'addRectangles',lat1, lng1, lat2, lng2, layerId, options, popup) %>%
     expandLimits(c(lat1, lat2), c(lng1, lng2))
 }
 
@@ -398,13 +458,37 @@ addPolygons = function(
     dashArray = dashArray, smoothFactor = smoothFactor, noClip = noClip
   ))
   pgons = derivePolygons(data, lng, lat, missing(lng), missing(lat), "addPolygons")
-  appendMapData(map, data, 'polygon', pgons, layerId, options, popup) %>%
+  invokeMethod(map, data, 'addPolygons', pgons, layerId, options, popup) %>%
     expandLimitsBbox(pgons)
 }
 
+#' @rdname remove
+#' @export
+removeShape = function(map, layerId) {
+  invokeMethod(map, NULL, 'removeShape', layerId)
+}
+
+#' @rdname remove
+#' @export
+clearShapes = function(map) {
+  invokeMethod(map, NULL, 'clearShapes')
+}
+
 #' @param geojson a GeoJSON list
 #' @describeIn map-layers Add GeoJSON layers to the map
 #' @export
 addGeoJSON = function(map, geojson, layerId = NULL) {
-  appendMapData(map, getMapData(map), 'geoJSON', geojson, layerId)
+  invokeMethod(map, getMapData(map), 'addGeoJSON', geojson, layerId)
+}
+
+#' @rdname remove
+#' @export
+removeGeoJSON = function(map, layerId) {
+  invokeMethod(map, NULL, 'removeGeoJSON', layerId)
+}
+
+#' @rdname remove
+#' @export
+clearGeoJSON = function(map) {
+  invokeMethod(map, NULL, 'clearGeoJSON')
 }

R/methods.R

@@ -17,26 +17,52 @@
 #' m %>% fitBounds(-72, 40, -70, 43)
 #' m %>% clearBounds()  # world view
 setView = function(map, lng, lat, zoom, options = list()) {
-  map$x$setView = list(c(lat, lng), zoom, options)
-  map$x$fitBounds = NULL
-  map
+  view = list(c(lat, lng), zoom, options)
+
+  dispatch(map,
+    "setView",
+    leaflet = {
+      map$x$setView = view
+      map$x$fitBounds = NULL
+      map
+    },
+    leaflet_proxy = {
+      invokeRemote(map, "setView", view)
+      map
+    }
+  )
 }
 
 #' @describeIn map-methods Set the bounds of a map
 #' @param lng1,lat1,lng2,lat2 the coordinates of the map bounds
 #' @export
 fitBounds = function(map, lng1, lat1, lng2, lat2) {
-  map$x$fitBounds = list(lat1, lng1, lat2, lng2)
-  map$x$setView = NULL
-  map
+  bounds = list(lat1, lng1, lat2, lng2)
+
+  dispatch(map,
+    "fitBounds",
+    leaflet = {
+      map$x$fitBounds = bounds
+      map$x$setView = NULL
+      map
+    },
+    leaflet_proxy = {
+      invokeRemote(map, "fitBounds", bounds)
+    }
+  )
 }
 
 #' @describeIn map-methods Clear the bounds of a map, and the bounds will be
 #'   automatically determined from latitudes and longitudes of the map elements
 #'   if available (otherwise the full world view is used)
 #' @export
 clearBounds = function(map) {
-  map$x$fitBounds = NULL
-  map$x$setView = NULL
-  map
+  dispatch(map,
+    "clearBounds",
+    leaflet = {
+      map$x$fitBounds = NULL
+      map$x$setView = NULL
+      map
+    }
+  )
 }

R/shiny.R

@@ -29,92 +29,3 @@ renderLeaflet = function(expr, env = parent.frame(), quoted = FALSE) {
   if (!quoted) expr = substitute(expr)  # force quoted
   htmlwidgets::shinyRenderWidget(expr, leafletOutput, env, quoted = TRUE)
 }
-
-#' Create a Leaflet map controller
-#'
-#' This function is called from \file{server.R} and returns an object that can
-#' be used to manipulate the Leaflet map from R.
-#' @param session The \code{session} argument passed through from the
-#'   \code{\link[shiny]{shinyServer}} server function.
-#' @param id The string identifier that was passed to
-#'   \code{\link{leaflet}()}.
-#' @return A list of methods. See the package vignette \code{vignette('intro',
-#'   'leaflet'} for details.
-#' @keywords internal
-leafletController = function(session, id) {
-
-  # This function is how we "dynamically" invoke code on the client. The
-  # method parameter indicates what leaflet operation we want to perform,
-  # and the other arguments will be serialized to JS objects and used as
-  # client side function args.
-  send = function(method, func, msg) {
-
-    msg = msg[names(formals(func))]
-    names(msg) = NULL
-
-    opts = options(digits = 22)
-    on.exit(options(opts))
-
-    session$sendCustomMessage('leaflet', list(
-      mapId = id,
-      method = method,
-      args = msg
-    ))
-
-  }
-
-  # Turns a call like:
-  #
-  #     stub(expression(setView(lat, lng, zoom, forceReset = FALSE)))
-  #
-  # into:
-  #
-  #     list(setView = function(lat, lng, zoom, forceReset = FALSE) {
-  #       send("setView", sys.function(), as.list(environment()))
-  #     })
-  stub = function(p) {
-    # The function name is the first element
-    name = as.character(p[[1]])
-
-    # Get textual representation of the expression; change name to "function"
-    # and add a NULL function body
-    txt = paste(deparse(p), collapse = "\n")
-    txt = sub(name, "function", txt, fixed = TRUE)
-    txt = paste0(txt, "NULL")
-
-    # Create the function
-    func = eval(parse(text = txt))
-
-    # Replace the function body
-    body(func) = substituteDirect(
-      quote(send(name, sys.function(), as.list(environment()))),
-      list(name = name)
-    )
-    environment(func) = environment(send)
-
-    # Return as list
-    structure(list(func), names = name)
-  }
-
-  obj = lapply(expression(
-    setView(lat, lng, zoom, forceReset = FALSE),
-    addMarker(lat, lng, layerId = NULL, options = list()),
-    addCircleMarker(lat, lng, radius, layerId = NULL, options = list()),
-    clearMarkers(),
-    clearShapes(),
-    fitBounds(lat1, lng1, lat2, lng2),
-    addCircle(lat, lng, radius, layerId = NULL, options = list()),
-    addRectangle(lat1, lng1, lat2, lng2, layerId = NULL, options = list()),
-    addPolyline(lat, lng, layerId, options = list()),
-    addPolygon(lat, lng, layerId, options = list()),
-    addGeoJSON(data, layerId),
-    showPopup(lat, lng, content, layerId = NULL, options = list()),
-    removePopup(layerId),
-    clearPopups(),
-    removeShape(layerId),
-    clearShapes(),
-    removeMarker(layerId),
-    clearMarkers()
-  ), stub)
-  unlist(obj, recursive = FALSE)
-}