Merge pull request #94 from r-spatial/leafpm

Add leafpm

DESCRIPTION

@@ -2,11 +2,12 @@ Package: mapedit
 Title: Interactive Editing of Spatial Data in R
 Description: Suite of interactive functions and helpers for selecting and editing
     geospatial data.
-Version: 0.4.3
-Date: 2018-08-16
+Version: 0.5.0
+Date: 2019-03-16
 Authors@R: c(
     person("Tim", "Appelhans", role = c("aut", "cre"), email = "[email protected]"),
-    person("Kenton", "Russell", role = c("aut"))
+    person("Kenton", "Russell", role = c("aut")),
+    person("Lorenzo", "Busetto", role = c("aut"))
   )
 URL: https://github.com/r-spatial/mapedit
 BugReports: https://github.com/r-spatial/mapedit/issues
@@ -20,6 +21,7 @@ Imports:
     jsonlite,
     leaflet (>= 2.0.1),
     leaflet.extras (>= 1.0),
+    leafpm,
     mapview,
     miniUI,
     sf (>= 0.5-2),
@@ -30,4 +32,4 @@ Enhances:
     geojsonio
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 6.1.0
+RoxygenNote: 6.1.1

NEWS.md

@@ -1,3 +1,10 @@
+## mapedit 0.5.0
+
+### New Features
+
+* add `editor  = "leafpm"` to `draw*()` and `edit*()` functions to use the `Leaflet.pm` pluging for editing.  `Leaflet.pm` provides support for creating and editing holes, snapping, and integrates better with some `multi*` features.  Note, `mapedit` now offers two editors `"leaflet.extras"` and `"leafpm"`, since each have advantages and disadvantages.
+
+
 ## mapedit 0.4.3
 
 ### New Features

R/draw.R

@@ -15,6 +15,7 @@
 #'          Firefox is an exception. See Details for instructions on how to enable this
 #'          behaviour in Firefox.
 #' @param title \code{string} to customize the title of the UI window.
+#' @param editor \code{character} either "leaflet.extras" or "leafpm"
 #' @param ... additional arguments passed on to \code{\link{editMap}}.
 #'
 #' @details
@@ -33,12 +34,14 @@ drawFeatures = function(map = NULL,
                         record = FALSE,
                         viewer = shiny::paneViewer(),
                         title = "Draw Features",
+                        editor = c("leaflet.extras", "leafpm"),
                         ...) {
   res = editMap(x = map,
                 sf = sf,
                 record = record,
                 viewer = viewer,
                 title = title,
+                editor = editor,
                 ...)
   if (!inherits(res, "sf") && is.list(res)) res = res$finished
   return(res)

R/edit.R

@@ -34,6 +34,7 @@ editMap <- function(x, ...) {
 #' @param crs see \code{\link[sf]{st_crs}}.
 #' @param title \code{string} to customize the title of the UI window.  The default
 #'          is "Edit Map".
+#' @param editor \code{character} either "leaflet.extras" or "leafpm"
 #'
 #' @details
 #'   When setting \code{viewer = browserViewer(browser = getOption("browser"))} and
@@ -51,6 +52,7 @@ editMap.leaflet <- function(
   ns = "mapedit-edit", record = FALSE, viewer = shiny::paneViewer(),
   crs = 4326,
   title = "Edit Map",
+  editor = c("leaflet.extras", "leafpm"),
   ...
 ) {
   stopifnot(!is.null(x), inherits(x, "leaflet"))
@@ -72,7 +74,7 @@ editMap.leaflet <- function(
       right = miniUI::miniTitleBarButton("done", "Done", primary = TRUE)
     ),
     tags$script(HTML(
-"
+      "
 // close browser window on session end
 $(document).on('shiny:disconnected', function() {
   // check to make sure that button was pressed
@@ -96,7 +98,8 @@ $(document).on('shiny:disconnected', function() {
       targetLayerId = targetLayerId,
       sf = sf,
       record = record,
-      crs = crs
+      crs = crs,
+      editor = editor
     )
 
     observe({crud()})
@@ -136,20 +139,22 @@ editMap.mapview <- function(
   ns = "mapedit-edit", record = FALSE, viewer = shiny::paneViewer(),
   crs = 4326,
   title = "Edit Map",
+  editor = c("leaflet.extras", "leafpm"),
   ...
 ) {
   stopifnot(!is.null(x), inherits(x, "mapview"), inherits(x@map, "leaflet"))
 
   editMap.leaflet(
     x@map, targetLayerId = targetLayerId, sf = sf,
     ns = ns, viewer = viewer, record = TRUE, crs = crs,
-    title = title
+    title = title,
+    editor = editor
   )
 }
 
 #' @name editMap
 #' @export
-editMap.NULL = function(x, ...) {
+editMap.NULL = function(x, editor = c("leaflet.extras", "leafpm"), ...) {
   m = mapview::mapview()@map
   m = leaflet::fitBounds(
     m,
@@ -158,7 +163,7 @@ editMap.NULL = function(x, ...) {
     lng2 = 180, #as.numeric(sf::st_bbox(x)[3]),
     lat2 = 90 #as.numeric(sf::st_bbox(x)[4])
   )
-  ed = editMap(m, record=TRUE)
+  ed = editMap(m, record = TRUE, editor = editor)
   ed_record <- ed$finished
   attr(ed_record, "recorder") <- attr(ed, "recorder", exact = TRUE)
   ed_record
@@ -196,6 +201,7 @@ editFeatures = function(x, ...) {
 #' @param crs see \code{\link[sf]{st_crs}}.
 #' @param title \code{string} to customize the title of the UI window.  The default
 #'          is "Edit Map".
+#' @param editor \code{character} either "leaflet.extras" or "leafpm"
 #'
 #' @details
 #'   When setting \code{viewer = browserViewer(browser = getOption("browser"))} and
@@ -217,9 +223,19 @@ editFeatures.sf = function(
   crs = 4326,
   label = NULL,
   title = "Edit Map",
+  editor = c("leaflet.extras", "leafpm"),
   ...
 ) {
 
+  # store original projection of edited object ----
+  orig_proj <- sf::st_crs(x)
+  if (is.na(orig_proj)) {
+    stop("The CRS of the input object is not set. Aborting. `mapedit` does not currently
+         allow editing objects with arbitrary coordinates system. Please set the
+         CRS of the input using `sf::st_set_crs()` (for `sf` objects) or `proj4string()
+         for `sp` objects", call. = FALSE)
+  }
+
   x$edit_id = as.character(1:nrow(x))
 
   if (is.null(map)) {
@@ -252,10 +268,27 @@ editFeatures.sf = function(
     )
   }
 
+  # currently we don't have a way to set custom options for leaflet.pm
+  # and we will want to customize allowSelfIntersection depending on feature types
+  if(inherits(map, "mapview")) map = map@map
+  if(editor[1] == "leafpm") {
+    # now let's see if any of the features are polygons
+    if(any(sf::st_dimension(x) == 2)) {
+      map = leafpm::addPmToolbar(
+        map,
+        targetGroup = "toedit",
+        toolbarOptions = leafpm::pmToolbarOptions(drawCircle = FALSE),
+        drawOptions = leafpm::pmDrawOptions(allowSelfIntersection = FALSE),
+        editOptions = leafpm::pmEditOptions(allowSelfIntersection = FALSE),
+        cutOptions = leafpm::pmCutOptions(allowSelfIntersection = FALSE)
+      )
+    }
+  }
+
   crud = editMap(
     map, targetLayerId = "toedit",
     viewer = viewer, record = record,
-    crs = crs, title = title, ...
+    crs = crs, title = title, editor = editor, ...
   )
 
   merged <- Reduce(
@@ -293,6 +326,16 @@ editFeatures.sf = function(
 
   merged <- dplyr::select_(merged, "-edit_id")
 
+  # re-transform to original projection if needed ----
+  if (sf::st_crs(merged) != orig_proj) {
+    merged <- sf::st_transform(merged, orig_proj)
+  }
+
+  # warn if anything is not valid
+  if(!all(sf::st_is_valid(merged))) {
+    warning("returned features do not appear valid; please inspect closely", call. = FALSE)
+  }
+
   # return merged features
   if(record==TRUE) {
     attr(merged, "recorder") <- attr(crud, "recorder", exact=TRUE)

R/merge.R

@@ -33,17 +33,30 @@ merge_edit <- function(
 
   orig_ids = orig2[[names(by)[1]]]
 
-  edit_ids = edits[,by[[1]], drop=TRUE]
+  edit_ids = edits[, by[[1]], drop=TRUE]
 
   mapply(
     function(ed, ed_id) {
       matched_id_row = which(orig_ids == ed_id)
-      sf::st_geometry(orig2)[matched_id_row] <<- sf::st_geometry(sf::st_cast(
-        sf::st_sfc(ed),
-        as.character(sf::st_geometry_type(
-          sf::st_geometry(orig2[matched_id_row,])
-        ))
+
+      # get type of original
+      orig_type <- as.character(sf::st_geometry_type(
+        sf::st_geometry(orig[matched_id_row,])
       ))
+
+      tryCatch(
+        sf::st_geometry(orig2)[matched_id_row] <<- sf::st_geometry(sf::st_cast(
+          sf::st_sfc(ed),
+          orig_type
+        )),
+        error = function(e) {
+          sf::st_geometry(orig2)[matched_id_row] <<- ed
+          warning(
+            paste0("Unable to cast back to original type - ", e$message, " - but this is often caused by intermediate step."),
+            call. = FALSE
+          )
+        }
+      )
       return(NULL)
     },
     sf::st_geometry(edits),
@@ -67,6 +80,7 @@ merge_edit <- function(
   #))
 
   #sf::st_geometry(orig2)[matched_id_rows] <- sf::st_geometry(edits)
+
   orig2
 }
 

R/modules.R

@@ -98,6 +98,7 @@ editModUI <- function(id, ...) {
 #'          \code{GeoJSON}.
 #' @param record \code{logical} to record all edits for future playback.
 #' @param crs see \code{\link[sf]{st_crs}}.
+#' @param editor \code{character} either "leaflet.extras" or "leafpm"
 #'
 #' @return server function for Shiny module
 #' @import shiny
@@ -108,29 +109,40 @@ editMod <- function(
   targetLayerId = NULL,
   sf = TRUE,
   record = FALSE,
-  crs = 4326
+  crs = 4326,
+  editor = c("leaflet.extras", "leafpm")
 ) {
   # check to see if addDrawToolbar has been already added to the map
   if(is.null(
     Find(
       function(cl) {
-        cl$method == "addDrawToolbar"
+        cl$method == "addDrawToolbar" || cl$method == "addPmToolbar"
       },
       leafmap$x$calls
     )
   )) {
-    # add draw toolbar if not found
-    leafmap <- leaflet.extras::addDrawToolbar(
-      leafmap,
-      targetGroup = targetLayerId,
-      polylineOptions = leaflet.extras::drawPolylineOptions(repeatMode = TRUE),
-      polygonOptions = leaflet.extras::drawPolygonOptions(repeatMode = TRUE),
-      circleOptions = FALSE,
-      rectangleOptions = leaflet.extras::drawRectangleOptions(repeatMode = TRUE),
-      markerOptions = leaflet.extras::drawMarkerOptions(repeatMode = TRUE),
-      circleMarkerOptions = leaflet.extras::drawCircleMarkerOptions(repeatMode = TRUE),
-      editOptions = leaflet.extras::editToolbarOptions()
-    )
+    if(editor[1] == "leaflet.extras") {
+      # add draw toolbar if not found
+      leafmap <- leaflet.extras::addDrawToolbar(
+        leafmap,
+        targetGroup = targetLayerId,
+        polylineOptions = leaflet.extras::drawPolylineOptions(repeatMode = TRUE),
+        polygonOptions = leaflet.extras::drawPolygonOptions(repeatMode = TRUE),
+        circleOptions = FALSE,
+        rectangleOptions = leaflet.extras::drawRectangleOptions(repeatMode = TRUE),
+        markerOptions = leaflet.extras::drawMarkerOptions(repeatMode = TRUE),
+        circleMarkerOptions = leaflet.extras::drawCircleMarkerOptions(repeatMode = TRUE),
+        editOptions = leaflet.extras::editToolbarOptions()
+      )
+    }
+
+    if(editor[1] == "leafpm") {
+      leafmap <- leafpm::addPmToolbar(
+        leafmap,
+        targetGroup = targetLayerId,
+        toolbarOptions = leafpm::pmToolbarOptions(drawCircle = FALSE)
+      )
+    }
   }
 
   output$map <- leaflet::renderLeaflet({leafmap})
@@ -174,9 +186,20 @@ editMod <- function(
 
   shiny::observeEvent(input[[EVT_DELETE]], {
     deleted <- input[[EVT_DELETE]]
+
     # find the deleted features and update finished
     # start by getting the leaflet ids to do the match
     ids <- unlist(lapply(featurelist$finished, function(x){x$properties$`_leaflet_id`}))
+
+    # leaflet.pm returns only a single feature while leaflet.extras returns feature collection
+    # convert leaflet.pm so logic will be the same
+    if(editor == "leafpm") {
+      deleted <- list(
+        type = "FeatureCollection",
+        features = list(deleted)
+      )
+    }
+
     # now modify finished to match edited
     lapply(deleted$features, function(x) {
       loc <- match(x$properties$`_leaflet_id`, ids)

inst/examples/examples_leafpm.R

@@ -0,0 +1,10 @@
+library(sf)
+library(mapview)
+
+#devtools::install_github("r-spatial/mapedit@leafpm")
+library(mapedit)
+#devtools::install_github("r-spatial/leafpm")
+library(leafpm)
+
+
+editFeatures(franconia[1:3,], editor = "leafpm")