Merge pull request #23 from timelyportfolio/modules

Shiny modules for select and edit

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: mapedit
 Title: Interactive Editing of Spatial Data in R
 Description: What the package does (one paragraph).
-Version: 0.1.0
-Date: 2017-05-19
+Version: 0.2.0
+Date: 2017-06-05
 Authors@R: c(
     person("Tim", "Appelhans", role = c("aut", "cre"), email = "[email protected]"),
     person("Kenton", "Russell", role = c("aut"))
@@ -18,11 +18,10 @@ Imports:
     jsonlite,
     leaflet,
     leaflet.extras,
+    mapview,
     miniUI,
     sf,
     shiny
-Suggests:
-    mapview
 Encoding: UTF-8
 LazyData: true
 RoxygenNote: 6.0.1

NAMESPACE

@@ -6,5 +6,9 @@ S3method(selectFeatures,Spatial)
 S3method(selectFeatures,sf)
 S3method(selectMap,leaflet)
 export(editMap)
+export(editMod)
+export(editModUI)
 export(selectFeatures)
 export(selectMap)
+export(selectMod)
+export(selectModUI)

NEWS.md

@@ -1,3 +1,15 @@
+# mapedit 0.2.0
+
+* add Shiny module functionality
+* add selectFeatures function for easy selection of features from simple features (sf)
+* defaults to repeat mode in editMap()
+* removes circle Leaflet.draw tool by default in editMap()
+* use layerId instead of group for select
+* uses Viewer window for selectMap()
+* promote mapview to Imports
+* uses newly exported mapview::addFeatures()
+
+
 # mapedit 0.1.0
 
 **API breaking change**

R/edit.R

@@ -9,132 +9,43 @@
 #' library(mapedit)
 #' editMap(leaflet() %>% addTiles())
 #'
-#' @example inst/experiments/randgeo_edit.R
+#' @example inst/examples/examples_edit.R
 #' @export
 editMap <- function(x, ...) {
   UseMethod("editMap")
 }
 
 #' @export
-editMap.leaflet <- function(x = NULL, targetLayerId = NULL, sf = TRUE) {
+editMap.leaflet <- function(x = NULL, targetLayerId = NULL, sf = TRUE, ns = "mapedit-edit") {
   stopifnot(!is.null(x), inherits(x, "leaflet"))
 
   stopifnot(
+    requireNamespace("leaflet"),
     requireNamespace("leaflet.extras"),
     requireNamespace("shiny"),
     requireNamespace("miniUI")
   )
 
-  # check to see if addDrawToolbar has been already added to the map
-  if(is.null(
-    Find(
-      function(cl) {
-        cl$method == "addDrawToolbar"
-      },
-      x$x$calls
-    )
-  )) {
-    # add draw toolbar if not found
-    x <- leaflet.extras::addDrawToolbar(
-      x,
-      targetGroup = targetLayerId,
-      editOptions = leaflet.extras::editToolbarOptions()
-    )
-  }
-
   ui <- miniUI::miniPage(
-    miniUI::miniContentPanel(x, height=NULL, width=NULL),
+    miniUI::miniContentPanel(editModUI(ns), height=NULL, width=NULL),
     miniUI::gadgetTitleBar("Edit Map", right = miniUI::miniTitleBarButton("done", "Done", primary = TRUE))
   )
 
   server <- function(input, output, session) {
-    drawn <- list()
-    edited_all <- list()
-    deleted_all <- list()
-    finished <- drawn
-
-    EVT_DRAW <- "undefined_draw_new_feature"
-    EVT_EDIT <- "undefined_draw_edited_features"
-    EVT_DELETE <- "undefined_draw_deleted_features"
-
-    shiny::observeEvent(input[[EVT_DRAW]], {
-      drawn <<- c(drawn, list(input[[EVT_DRAW]]))
-      finished <<- c(finished, list(input[[EVT_DRAW]]))
-    })
-
-    shiny::observeEvent(input[[EVT_EDIT]], {
-      edited <- input[[EVT_EDIT]]
-      # find the edited features and update drawn
-      # start by getting the leaflet ids to do the match
-      ids <- unlist(lapply(finished, function(x){x$properties$`_leaflet_id`}))
-      # now modify drawn to match edited
-      lapply(edited$features, function(x) {
-        loc <- match(x$properties$`_leaflet_id`, ids)
-        if(length(loc) > 0) {
-          finished[loc] <<- list(x)
-        }
-      })
-
-      edited_all <<- c(edited_all, list(edited))
-    })
-
-    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(finished, function(x){x$properties$`_leaflet_id`}))
-      # now modify finished to match edited
-      lapply(deleted$features, function(x) {
-        loc <- match(x$properties$`_leaflet_id`, ids)
-        if(length(loc) > 0) {
-          finished[loc] <<- NULL
-        }
-      })
+    crud <- callModule(
+      editMod,
+      ns,
+      x,
+      targetLayerId = targetLayerId,
+      sf = sf
+    )
 
-      deleted_all <<- c(deleted_all, list(deleted))
-    })
+    observe({crud()})
 
     shiny::observeEvent(input$done, {
-      # collect all of the the features into a list
-      #  by action
-      returnlist <- list(
-        drawn = drawn,
-        edited = edited_all,
-        deleted = deleted_all,
-        finished = finished
+      shiny::stopApp(
+        crud()
       )
-      # if sf argument is TRUE then convert to simple features
-      if(sf) {
-        returnlist <- lapply(
-          returnlist,
-          function(gj) {
-            # ignore empty action types to prevent error
-            #   handle in the helper functions?
-            if(length(gj) == 0) { return() }
-
-            # deleted is often a FeatureCollection
-            #  which requires special treatment
-            if(gj[[1]]$type == "FeatureCollection") {
-              return(
-                combine_list_of_sf(
-                  lapply(
-                    gj[[1]]$features,
-                    function(feature) {
-                      st_as_sf.geo_list(feature)
-                    }
-                  )
-                )
-              )
-            }
-
-            combine_list_of_sf(
-              lapply(gj, st_as_sf.geo_list)
-            )
-          }
-        )
-      }
-      # return geojson or sf list
-      shiny::stopApp(returnlist)
     })
 
     shiny::observeEvent(input$cancel, { shiny::stopApp (NULL) })
@@ -149,14 +60,8 @@ editMap.leaflet <- function(x = NULL, targetLayerId = NULL, sf = TRUE) {
 }
 
 #' @export
-editMap.mapview <- function(x = NULL, targetLayerId = NULL, sf = TRUE) {
+editMap.mapview <- function(x = NULL, targetLayerId = NULL, sf = TRUE, ns = "mapedit-edit") {
   stopifnot(!is.null(x), inherits(x, "mapview"), inherits(x@map, "leaflet"))
 
-  stopifnot(
-    requireNamespace("leaflet.extras"),
-    requireNamespace("shiny"),
-    requireNamespace("miniUI")
-  )
-
-  editMap.leaflet(x@map, targetLayerId = targetLayerId, sf = sf)
+  editMap.leaflet(x@map, targetLayerId = targetLayerId, sf = sf, ns = ns)
 }

R/edit_map_return_sf.R

@@ -1,17 +1,21 @@
+#' @keywords internal
+geojson_to_sf = function(x) {
+  do.call(
+    rbind,
+    lapply(x, function(x) {
+      x <- lapply(x, fix_geojso)
+      sf::read_sf(
+        jsonlite::toJSON(x, force=TRUE, auto_unbox=TRUE)
+      )
+    })
+  )
+}
+
 #' @keywords internal
 st_as_sfc.geo_list = function(x, ...) {
-  x = switch(x$type,
-             Point = sf::st_point(x$coordinates),
-             MultiPoint = sf::st_multipoint(x$coordinates),
-             LineString = sf::st_linestring(x$coordinates),
-             MultiLineString = sf::st_multilinestring(x$coordinates),
-             Polygon = sf::st_polygon(x$coordinates),
-             MultiPolygon = sf::st_multipolygon(x$coordinates),
-             GeometryCollection = sf::st_geometrycollection(
-               lapply(x$geometries, function(y) st_as_sfc.geo_list(y)[[1]])),
-             stop("unknown class")
+  sf::read_sf(
+    jsonlite::toJSON(x, auto_unbox=TRUE, force=TRUE)
   )
-  sf::st_sfc(x, crs = sf::st_crs(4326))
 }
 
 #' @keywords internal
@@ -22,21 +26,21 @@ st_as_sf.geo_list = function(x, ...) {
 
   x <- fix_geojson_coords(x)
 
-  props <- do.call(
-    data.frame,
-    modifyList(
-      Filter(Negate(is.null), x$properties),
-      list(stringsAsFactors=FALSE)
-    )
-  )
+  #props <- do.call(
+  #  data.frame,
+  #  modifyList(
+  #    Filter(Negate(is.null), x$properties),
+  #    list(stringsAsFactors=FALSE)
+  #  )
+  #)
 
-  geom_sf <- st_as_sfc.geo_list(x$geometry)
+  geom_sf <- st_as_sfc.geo_list(x)
   # if props are empty then we need to handle differently
-  if(nrow(props) == 0 ) {
-    return(sf::st_sf(feature=geom_sf, crs = sf::st_crs(4326)))
-  } else {
-    return(sf::st_sf(props, feature=geom_sf, crs = sf::st_crs(4326)))
-  }
+  #if(nrow(props) == 0 ) {
+  #  return(sf::st_sf(feature=geom_sf, crs = sf::st_crs(4326)))
+  #} else {
+  #  return(sf::st_sf(props, feature=geom_sf, crs = sf::st_crs(4326)))
+  #}
 }
 
 #' @keywords internal
@@ -73,9 +77,9 @@ combine_list_of_sf <- function(sf_list) {
     lapply(
       sf_list,
       function(x) {
-        dplyr::select(
+        dplyr::select_(
           as.data.frame(x, stringsAsFactors=FALSE),
-          -feature
+          paste0("-",attr(x, "sf_column", exact=TRUE))
         )
       }
     )
@@ -84,7 +88,7 @@ combine_list_of_sf <- function(sf_list) {
   sf::st_sf(
     props,
     feature = sf::st_sfc(
-      unlist(lapply(sf_list, function(x) x$feature), recursive=FALSE)
+      unlist(lapply(sf_list, function(x) sf::st_geometry(x)), recursive=FALSE)
     ),
     crs = sf::st_crs(4326)
   )