Feature/plugin proj4 leaflet

.gitignore

@@ -4,3 +4,5 @@
 node_modules
 inst/htmlwidgets/sources
 *.swp
+inst/examples/rsconnect
+inst/examples/*.html

NAMESPACE

@@ -62,6 +62,7 @@ export(labelFormat)
 export(labelOptions)
 export(layersControlOptions)
 export(leaflet)
+export(leafletCRS)
 export(leafletMap)
 export(leafletOutput)
 export(leafletProxy)

R/layers.R

@@ -242,6 +242,7 @@ clearImages = function(map) {
 #' minZoom,maxZoom,maxNativeZoom,tileSize,subdomains,errorTileUrl,tms,continuousWorld,noWrap,zoomOffset,zoomReverse,zIndex,unloadInvisibleTiles,updateWhenIdle,detectRetina,reuseTiles
 #' the tile layer options; see
 #' \url{http://leafletjs.com/reference.html#tilelayer}
+#' @param ... extra options passed to underlying Javascript object constructor.
 #' @describeIn map-options Options for tile layers
 #' @export
 tileOptions = function(
@@ -261,8 +262,8 @@ tileOptions = function(
   unloadInvisibleTiles = NULL,
   updateWhenIdle = NULL,
   detectRetina = FALSE,
-  reuseTiles = FALSE
-  # bounds = TODO
+  reuseTiles = FALSE,
+  ...
 ) {
   list(
     minZoom = minZoom, maxZoom = maxZoom, maxNativeZoom = maxNativeZoom,
@@ -271,7 +272,8 @@ tileOptions = function(
     zoomOffset = zoomOffset, zoomReverse = zoomReverse, opacity = opacity,
     zIndex = zIndex, unloadInvisibleTiles = unloadInvisibleTiles,
     updateWhenIdle = updateWhenIdle, detectRetina = detectRetina,
-    reuseTiles = reuseTiles
+    reuseTiles = reuseTiles,
+    ...
   )
 }
 
@@ -333,8 +335,6 @@ addWMSTiles = function(
 #' @param version version of the WMS service to use
 #' @param crs Coordinate Reference System to use for the WMS requests, defaults
 #'   to map CRS (don't change this if you're not sure what it means)
-#' @param ... other tile options for \code{WMSTileOptions()} (all arguments of
-#'   \code{tileOptions()} can be used)
 #' @describeIn map-options Options for WMS tile layers
 #' @export
 WMSTileOptions = function(
@@ -398,12 +398,13 @@ popupOptions = function(
   # autoPanPadding = TODO,
   zoomAnimation = TRUE,
   closeOnClick = NULL,
-  className = ""
+  className = "",
+  ...
 ) {
   list(
     maxWidth = maxWidth, minWidth = minWidth, maxHeight = maxHeight,
     autoPan = autoPan, keepInView = keepInView, closeButton = closeButton,
-    zoomAnimation = zoomAnimation, closeOnClick = closeOnClick, className = className
+    zoomAnimation = zoomAnimation, closeOnClick = closeOnClick, className = className, ...
   )
 }
 
@@ -451,13 +452,14 @@ labelOptions = function(
   textsize = "10px",
   textOnly = FALSE,
   style = NULL,
-  zoomAnimation = TRUE
+  zoomAnimation = TRUE,
+  ...
 ) {
   list(
     clickable = clickable, noHide = noHide, direction = direction,
     opacity = opacity, offset = offset,
     textsize = textsize, textOnly = textOnly, style = style,
-    zoomAnimation = zoomAnimation, className = className
+    zoomAnimation = zoomAnimation, className = className, ...
   )
 }
 
@@ -731,12 +733,13 @@ markerOptions = function(
   zIndexOffset = 0,
   opacity = 1.0,
   riseOnHover = FALSE,
-  riseOffset = 250
+  riseOffset = 250,
+  ...
 ) {
   list(
     clickable = clickable, draggable = draggable, keyboard = keyboard,
     title = title, alt = alt, zIndexOffset = zIndexOffset, opacity = opacity,
-    riseOnHover = riseOnHover, riseOffset = riseOffset
+    riseOnHover = riseOnHover, riseOffset = riseOffset, ...
   )
 }
 
@@ -865,11 +868,12 @@ pathOptions = function(
   lineJoin = NULL,
   clickable = TRUE,
   pointerEvents = NULL,
-  className = ""
+  className = "",
+  ...
 ) {
   list(
     lineCap = lineCap, lineJoin = lineJoin, clickable = clickable,
-    pointerEvents = pointerEvents, className = className
+    pointerEvents = pointerEvents, className = className, ...
   )
 }
 
@@ -1094,9 +1098,10 @@ addLayersControl = function(map,
 #'   to have the layers control always appear in its expanded state.
 #' @param autoZIndex if \code{TRUE}, the control will automatically maintain
 #'   the z-order of its various groups as overlays are switched on and off.
+#' @param ... other options for \code{layersControlOptions()}
 #' @export
-layersControlOptions = function(collapsed = TRUE, autoZIndex = TRUE) {
-  list(collapsed = collapsed, autoZIndex = autoZIndex)
+layersControlOptions = function(collapsed = TRUE, autoZIndex = TRUE, ...) {
+  list(collapsed = collapsed, autoZIndex = autoZIndex, ...)
 }
 
 #' @rdname addLayersControl

R/leaflet.R

@@ -19,15 +19,24 @@
 #' @param width the width of the map
 #' @param height the height of the map
 #' @param padding the padding of the map
+#' @param options the map options
 #' @return A HTML widget object, on which we can add graphics layers using
 #'   \code{\%>\%} (see examples).
 #' @example inst/examples/leaflet.R
 #' @export
-leaflet = function(data = NULL, width = NULL, height = NULL, padding = 0) {
+leaflet = function(data = NULL, width = NULL, height = NULL,
+                   padding = 0, options = list()) {
+
+  # Validate the CRS if specified
+  if(!is.null(options[['crs']]) &&
+     !inherits(options[['crs']], 'leaflet_crs')) {
+    stop("CRS in mapOptions should be a return value of leafletCRS() function")
+  }
+
   htmlwidgets::createWidget(
     'leaflet',
     structure(
-      list(),
+      list(options = options),
       leafletData = data
     ),
     width = width, height = height,
@@ -36,10 +45,29 @@ leaflet = function(data = NULL, width = NULL, height = NULL, padding = 0) {
       defaultHeight = 400,
       padding = padding,
       browser.fill = TRUE
-    )
+    ),
+    preRenderHook = function(widget) {
+      if (!is.null(widget$jsHooks$render)) {
+        widget$jsHooks$render <- lapply(widget$jsHooks$render, function(hook) {
+          if (is.list(hook)) {
+            hook$code <- sprintf(hookWrapperTemplate, paste(hook$code, collapse = "\n"))
+          } else if (is.character(hook)) {
+            hook <- sprintf(hookWrapperTemplate, paste(hook, collapse = "\n"))
+          } else {
+            stop("Unknown hook class ", class(hook))
+          }
+          hook
+        })
+      }
+      widget
+    }
   )
 }
 
+hookWrapperTemplate <- "function(el, x, data) {
+  return (%s).call(this.getMap(), el, x, data);
+}"
+
 getMapData = function(map) {
   attr(map$x, "leafletData", exact = TRUE)
 }
@@ -70,3 +98,71 @@ mapOptions <- function(map, zoomToLimits = c("always", "first", "never")) {
 
   map
 }
+
+# CRS classes supported
+crsClasses <- list( 'L.CRS.EPSG3857', 'L.CRS.EPSG4326', 'L.CRS.EPSG3395',
+                    'L.CRS.Simple', 'L.Proj.CRS', 'L.Proj.CRS.TMS' )
+
+#' creates a custom CRS
+#' Refer to \url{https://kartena.github.io/Proj4Leaflet/api/} for details.
+#' @param crsClass One of L.CRS.EPSG3857, L.CRS.EPSG4326, L.CRS.EPSG3395,
+#' L.CRS.Simple, L.Proj.CRS, L.Proj.CRS.TMS
+#' @param code CRS identifier
+#' @param proj4def Proj4 string
+#' @param projectedBounds Only when crsClass = 'L.Proj.CRS.TMS'
+#' @param origin Origin in projected coordinates, if set overrides transformation option.
+#' @param transformation to use when transforming projected coordinates into pixel coordinates
+#' @param scales Scale factors (pixels per projection unit, for example pixels/meter)
+#'   for zoom levels; specify either scales or resolutions, not both
+#' @param resolutions factors (projection units per pixel, for example meters/pixel)
+#'   for zoom levels; specify either scales or resolutions, not both
+#' @param bounds Bounds of the CRS, in projected coordinates; if defined,
+#'    Proj4Leaflet will use this in the getSize method, otherwise
+#'    defaulting to Leaflet's default CRS size
+#' @param tileSize Tile size, in pixels, to use in this CRS (Default 256)
+#'    Only needed when crsClass = 'L.Proj.CRS.TMS'
+#' @export
+leafletCRS <- function(
+  crsClass = 'L.CRS.EPSG3857',
+  code = NULL,
+  proj4def = NULL,
+  projectedBounds = NULL,
+  origin = NULL,
+  transformation = NULL,
+  scales = NULL,
+  resolutions = NULL,
+  bounds = NULL,
+  tileSize = NULL
+) {
+  if(!crsClass %in% crsClasses) {
+    stop(sprintf("crsClass argument must be one of %s",
+                 paste0(crsClasses, collapse = ', ')))
+
+  }
+  if(crsClass %in% c('L.Proj.CRS', 'L.Proj.CRS.TMS') &&
+    !is.null(scales) && !is.null(resolutions)) {
+    stop(sprintf("Either input scales or resolutions"))
+  }
+  if(crsClass %in% c('L.Proj.CRS', 'L.Proj.CRS.TMS') &&
+    is.null(scales) && is.null(resolutions)) {
+    stop(sprintf("Input either scales or resolutions, not both"))
+  }
+    structure(
+      list(
+        crsClass = crsClass,
+        code = code,
+        proj4def = proj4def,
+        projectedBounds = projectedBounds,
+        options = filterNULL(list(
+          origin = origin,
+          transformation = transformation,
+          scales = scales,
+          resolutions = resolutions,
+          bounds = bounds,
+          tileSize = tileSize
+        ))
+      ),
+      class = 'leaflet_crs'
+  )
+}
+

R/plugin-graticule.R

@@ -14,6 +14,7 @@ leafletGraticuleDependencies <- function() {
 #'
 #' @param map a map widget object
 #' @param interval The spacing in map units between horizontal and vertical lines.
+#' @param sphere boolean. Default FALSE
 #' @param style path options for the generated lines. See \url{http://leafletjs.com/reference.html#path-options}
 #' @param layerId the layer id
 #' @param group the name of the group this layer belongs to.
@@ -28,6 +29,7 @@ leafletGraticuleDependencies <- function() {
 addGraticule <- function(
   map,
   interval = 20,
+  sphere = FALSE,
   style = list(color= '#333', weight= 1),
   layerId = NULL,
   group=NULL
@@ -38,6 +40,7 @@ addGraticule <- function(
     getMapData(map),
     'addGraticule',
     interval,
+    sphere,
     style,
     layerId,
     group

inst/examples/minimap.R

@@ -32,13 +32,14 @@ m %>%
   addMiniMap(
              tiles = esri[[1]],
              toggleDisplay = T) %>%
-  htmlwidgets::onRender("function(el, x) {
-                            var myMap = this;
-                            this.on('baselayerchange',
-                                    function (e) {
-                                        myMap.minimap.changeLayer(L.tileLayer.provider(e.name));
-                                    })
-                        }")
+  htmlwidgets::onRender("
+    function(el, x) {
+      var myMap = this;
+      myMap.on('baselayerchange',
+        function (e) {
+          myMap.minimap.changeLayer(L.tileLayer.provider(e.name));
+        })
+    }")
 
 #' <br/><br/>
 #' Another advanced use case
@@ -69,33 +70,27 @@ leaflet() %>% addTiles() %>%
              options = markerOptions(riseOnHover = TRUE, opacity = 0.75),
              group = 'pubs') %>%
   addMiniMap() %>%
-  htmlwidgets::onRender("function(el, t) {
-                             var myMap = this;
+  htmlwidgets::onRender("
+    function(el, t) {
+      var myMap = this;
 
-                             var pubs = myMap.layerManager._byGroup.pubs;
-                             var pubs2 = new L.FeatureGroup();
+      var pubs = myMap.layerManager._byGroup.pubs;
+      var pubs2 = new L.FeatureGroup();
 
-                             for(pub in pubs) {
-                                 var m = new L.CircleMarker(pubs[pub]._latlng,
-                                                            {radius: 2});
-                                 pubs2.addLayer(m);
-
-                             }
-                             var layers = new L.LayerGroup([myMap.minimap._layer, pubs2]);
-
-                             myMap.minimap.changeLayer(layers);
-                        }")
+      for(pub in pubs) {
+        var m = new L.CircleMarker(pubs[pub]._latlng, {radius: 2});
+        pubs2.addLayer(m);
+      }
+      var layers = new L.LayerGroup([myMap.minimap._layer, pubs2]);
+      myMap.minimap.changeLayer(layers);
+    }")
 
 #' <br/><br/>
 #' Finally combine the approaches in last 2 examples
 #' Minimap w/ changable layers and circle markers.
 m <- leaflet()
-esri <- providers %>%
-  purrr::keep(~ grepl('^Esri',.))
-
 esri %>%
   purrr::walk(function(x) m <<- m %>% addProviderTiles(x,group=x))
-
 m %>%
   setView(10.758276373601069, 59.92448055859924, 13) %>%
   addAwesomeMarkers(data=spdf,
@@ -109,27 +104,24 @@ m %>%
   ) %>%
   addMiniMap(tiles = esri[[1]],
              toggleDisplay = T) %>%
-  htmlwidgets::onRender("function(el, t) {
-                             var myMap = this;
-
-                             var pubs = myMap.layerManager._byGroup.pubs;
-                             var pubs2 = new L.FeatureGroup();
-
-                             for(pub in pubs) {
-                                 var m = new L.CircleMarker(pubs[pub]._latlng,
-                                                            {radius: 2});
-                                 pubs2.addLayer(m);
-
-                             }
-                             var layers = new L.LayerGroup([myMap.minimap._layer, pubs2]);
-
-                             myMap.minimap.changeLayer(layers);
-
-                             myMap.on('baselayerchange',
-                                      function (e) {
-                                          debugger;
-                                          myMap.minimap.changeLayer(
-                                             new L.LayerGroup([L.tileLayer.provider(e.name),
-                                                pubs2]));
-                                      });
-                        }")
+  htmlwidgets::onRender("
+    function(el, t) {
+      var myMap = this;
+
+      var pubs = myMap.layerManager._byGroup.pubs;
+      var pubs2 = new L.FeatureGroup();
+
+      for(pub in pubs) {
+        var m = new L.CircleMarker(pubs[pub]._latlng, {radius: 2});
+        pubs2.addLayer(m);
+      }
+      var layers = new L.LayerGroup([myMap.minimap._layer, pubs2]);
+
+      myMap.minimap.changeLayer(layers);
+
+      myMap.on('baselayerchange',
+        function (e) {
+          myMap.minimap.changeLayer(
+            new L.LayerGroup([L.tileLayer.provider(e.name), pubs2]));
+        });
+    }")