├── .Rbuildignore ├── .github ├── .gitignore └── workflows │ └── R-CMD-check.yaml ├── .gitignore ├── CONDUCT.md ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R ├── addToolbar.R ├── addin.R ├── draw.R ├── edit.R ├── editAttributes.R ├── edit_map_return_sf.R ├── helpers.R ├── mapedit.R ├── mapview_extent.R ├── mapview_init.R ├── mapview_projection.R ├── merge.R ├── modules.R ├── playback.R ├── query.R └── select.R ├── README.Rmd ├── README.md ├── cran-comments.md ├── experiments ├── add_sf_to_df.R ├── crosstalk.R ├── crosstalk_shiny.R ├── draw_shiny_deleted.R ├── edit_map_draw_border.R ├── edit_map_return_sf_tests.R ├── experiment_split.R ├── flubber_playback.R ├── flubber_playback.RData ├── gadget_draw2.R ├── igraph_mapedit.r ├── mapedit_attribute_poc.R ├── merge_tests.R ├── randgeo_edit.R ├── select_crosstalk.R ├── select_shiny_crosstalk.R └── sf_leafletdraw_intersect.R ├── inst ├── examples │ ├── examples_edit.R │ ├── examples_leafpm.R │ ├── examples_select.R │ └── shiny_modules.R ├── posts │ ├── 2017-01-22_interactivity.Rmd │ ├── 2017-05-10_edit_sf.Rmd │ └── 2020-01-24_geoattributes.Rmd └── rstudio │ └── addins.dcf ├── man ├── addToolbar.Rd ├── createFeatures.Rd ├── drawFeatures.Rd ├── editAttributes.Rd ├── editFeatures.Rd ├── editMap.Rd ├── editMod.Rd ├── editModUI.Rd ├── mapedit-package.Rd ├── merge_add.Rd ├── merge_delete.Rd ├── merge_edit.Rd ├── pipe.Rd ├── playback.Rd ├── processOpts.Rd ├── selectFeatures.Rd ├── selectMap.Rd ├── selectMod.Rd └── selectModUI.Rd └── mapedit.Rproj /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^README\.Rmd$ 4 | ^README-.*\.png$ 5 | ^CONDUCT\.md$ 6 | ^experiments 7 | ^cran-comments\.md$ 8 | ^\.github$ 9 | ^LICENSE\.md$ 10 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | 8 | name: R-CMD-check 9 | 10 | permissions: read-all 11 | 12 | jobs: 13 | R-CMD-check: 14 | runs-on: ${{ matrix.config.os }} 15 | 16 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 17 | 18 | strategy: 19 | fail-fast: false 20 | matrix: 21 | config: 22 | - {os: macos-latest, r: 'release'} 23 | - {os: windows-latest, r: 'release'} 24 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 25 | - {os: ubuntu-latest, r: 'release'} 26 | - {os: ubuntu-latest, r: 'oldrel-1'} 27 | 28 | env: 29 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 30 | R_KEEP_PKG_SOURCE: yes 31 | 32 | steps: 33 | - uses: actions/checkout@v4 34 | 35 | - uses: r-lib/actions/setup-pandoc@v2 36 | 37 | - uses: r-lib/actions/setup-r@v2 38 | with: 39 | r-version: ${{ matrix.config.r }} 40 | http-user-agent: ${{ matrix.config.http-user-agent }} 41 | use-public-rspm: true 42 | 43 | - uses: r-lib/actions/setup-r-dependencies@v2 44 | with: 45 | extra-packages: any::rcmdcheck 46 | needs: check 47 | 48 | - uses: r-lib/actions/check-r-package@v2 49 | with: 50 | upload-snapshots: true 51 | build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' 52 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, we pledge to respect all people who 4 | contribute through reporting issues, posting feature requests, updating documentation, 5 | submitting pull requests or patches, and other activities. 6 | 7 | We are committed to making participation in this project a harassment-free experience for 8 | everyone, regardless of level of experience, gender, gender identity and expression, 9 | sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. 10 | 11 | Examples of unacceptable behavior by participants include the use of sexual language or 12 | imagery, derogatory comments or personal attacks, trolling, public or private harassment, 13 | insults, or other unprofessional conduct. 14 | 15 | Project maintainers have the right and responsibility to remove, edit, or reject comments, 16 | commits, code, wiki edits, issues, and other contributions that are not aligned to this 17 | Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed 18 | from the project team. 19 | 20 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by 21 | opening an issue or contacting one or more of the project maintainers. 22 | 23 | This Code of Conduct is adapted from the Contributor Covenant 24 | (http:contributor-covenant.org), version 1.0.0, available at 25 | http://contributor-covenant.org/version/1/0/0/ 26 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: mapedit 2 | Title: Interactive Editing of Spatial Data in R 3 | Description: Suite of interactive functions and helpers for selecting and editing 4 | geospatial data. 5 | Version: 0.7.0.9001 6 | Authors@R: c( 7 | person("Tim", "Appelhans", role = c("aut", "cre"), email = "tim.appelhans@gmail.com"), 8 | person("Kenton", "Russell", role = c("aut")), 9 | person("Lorenzo", "Busetto", role = c("aut")), 10 | person("Josh", "O'Brien", role = c("ctb")), 11 | person("Jakob", "Gutschlhofer", role = c("ctb")), 12 | person("Matt", "Johnson", role = c("ctb")), 13 | person("Eli", "Pousson", role = "ctb", comment = c(ORCID = "0000-0001-8280-1706")) 14 | ) 15 | URL: https://github.com/r-spatial/mapedit 16 | BugReports: https://github.com/r-spatial/mapedit/issues 17 | License: MIT + file LICENSE 18 | Depends: 19 | R (>= 3.1.0) 20 | Imports: 21 | assertthat, 22 | dplyr, 23 | DT, 24 | htmltools (>= 0.3), 25 | htmlwidgets, 26 | jsonlite, 27 | leafem, 28 | leaflet (>= 2.0.1), 29 | leaflet.extras (>= 1.0), 30 | leafpm, 31 | leafpop, 32 | mapview, 33 | methods, 34 | miniUI, 35 | raster, 36 | rstudioapi, 37 | scales, 38 | sf (>= 0.5-2), 39 | shiny, 40 | tmaptools, 41 | shinyWidgets (>= 0.4.3), 42 | magrittr 43 | Suggests: 44 | crayon, 45 | sp 46 | Enhances: 47 | geojsonio 48 | Encoding: UTF-8 49 | Roxygen: list(markdown = TRUE) 50 | RoxygenNote: 7.3.2 51 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2025 2 | COPYRIGHT HOLDER: mapedit authors 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2025 mapedit authors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(editFeatures,Spatial) 4 | S3method(editFeatures,sf) 5 | S3method(editMap,"NULL") 6 | S3method(editMap,leaflet) 7 | S3method(editMap,mapview) 8 | S3method(selectFeatures,Spatial) 9 | S3method(selectFeatures,sf) 10 | S3method(selectMap,leaflet) 11 | export("%>%") 12 | export(createFeatures) 13 | export(drawFeatures) 14 | export(editAttributes) 15 | export(editFeatures) 16 | export(editMap) 17 | export(editMod) 18 | export(editModUI) 19 | export(selectFeatures) 20 | export(selectMap) 21 | export(selectMod) 22 | export(selectModUI) 23 | importFrom(magrittr,"%>%") 24 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # mapedit 0.7.0.9001 (2025-04-21) 2 | 3 | #### ✨ features and improvements 4 | 5 | #### 🐛 bug fixes 6 | 7 | #### 💬 documentation etc 8 | 9 | #### 🍬 miscellaneous 10 | 11 | 12 | # mapedit 0.7.0 (2025-04-20) 13 | 14 | #### ✨ features and improvements 15 | 16 | * add editAttributes app and RStudio addin #120 17 | 18 | #### 🐛 bug fixes 19 | 20 | * update deprecated dplyr::select_() calls #124 21 | 22 | 23 | # mapedit 0.6.2 (2025-04-19) 24 | 25 | ### Bug Fix 26 | 27 | * properly flush deleted features when user deletes multiple. See [issue #106](https://github.com/r-spatial/mapedit/issues/106). 28 | 29 | * allow `mapedit` to work in a loop or in sequence. See [issue #83](https://github.com/r-spatial/mapedit/issues/83). 30 | 31 | * make behavior of `selectFeatures` consistent between modes `"draw"` and `"click"` when working with features with no CRS. See [issue #110](https://github.com/r-spatial/mapedit/issues/110). 32 | 33 | ### New Features 34 | 35 | * Add listener for all features and add to returned features with `leaflet.extras` editor. See [pull #98](https://github.com/r-spatial/mapedit/pull/98). 36 | 37 | * Add `editorOptions` for better control of options in `edit*` and `draw*` functions. See [pull #100](https://github.com/r-spatial/mapedit/pull/100) and [pull #103](https://github.com/r-spatial/mapedit/pull/103). 38 | 39 | ### New Features 40 | 41 | * 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. 42 | 43 | ### New Features 44 | 45 | * stopApp when session ended to handle when a user closes a browser tab or window when using `viewer = browserViewer(browser = getOption("browser"))` 46 | 47 | * add circleMarkerOptions for Leaflet.draw 48 | 49 | * warn when feature drawn outside of -180, 180 50 | 51 | ### Bug Fixes 52 | 53 | * fix precision to match new Leaflet 6 digits 54 | 55 | * expose title argument to editFeatures and drawFeatures 56 | 57 | ### Bug Fix 58 | 59 | * fix `edit` module lookup for already added `Leaflet.draw` 60 | 61 | ### New Features 62 | 63 | * add drawing mode to selectFeatures to enable selection via point/line/polygon drawing. Selection will be done using any of `?geos_binary_ops`; thx @tim-salabim 64 | 65 | * add `CRS` in `edit*` functions; thx @tim-salabim 66 | 67 | * add label for reference in `edit*` and `select*` 68 | 69 | * add title argument for `editMap()` 70 | 71 | * automatically close browser window on Shiny session end when using 72 | `viewer = browserViewer(browser = getOption("browser"))` 73 | 74 | * add new function drawFeatures 75 | 76 | 77 | # mapedit 0.3.2 78 | 79 | ### Bug Fix 80 | 81 | * polygons of `length > 1` not handled correctly. See [discussion](https://github.com/r-spatial/mapedit/issues/48). 82 | 83 | * remove internally added `edit_id` column in editFeatures return 84 | 85 | * cast edits back to their original type. See [discussion](https://github.com/r-spatial/mapedit/issues/48) 86 | 87 | * fix merge_edit to only consider last edit when there are multiple edits per layerId 88 | 89 | 90 | # mapedit 0.3.1 91 | 92 | ### Bug Fix 93 | 94 | * multiple edits and deletes resulting in multiple FeatureCollections not handled properly causing some actions to not be considered when converting to `sf`; thanks @tim-salabim for identifying 95 | 96 | 97 | # mapedit 0.3.0 98 | 99 | ### API Changes 100 | 101 | * **BREAKING** editFeatures and selectFeatures add a map argument 102 | instead of platform 103 | 104 | ### New Features 105 | 106 | * add editFeatures function for easy add, edit, delete with existing simple features (sf) 107 | * add editMap.NULL 108 | * add record argument to edit* functions to preserve the series 109 | of actions from an editing session. If `record = TRUE` then a `"recorder"` attribute will be added to the returned object for 110 | full reproducibility. 111 | * add internal playback for recorded session for future use 112 | * add viewer argument to select and edit functions to allow 113 | user the flexibility to adjust the viewer experience. Default 114 | will be paneViewer() in an attempt to keep the workflow 115 | within one RStudio window/context. 116 | * change height to 97% to fill viewer 117 | * document more thoroughly 118 | * pass trial CRAN check 119 | 120 | ## Bug Fixes 121 | 122 | * fix internal `combine_list_of_sf` with length 0 `list`; found when `editFeatures()` and save with no changes 123 | 124 | 125 | # mapedit 0.2.0 126 | 127 | * add Shiny module functionality 128 | * add selectFeatures function for easy selection of features from simple features (sf) 129 | * defaults to repeat mode in editMap() 130 | * removes circle Leaflet.draw tool by default in editMap() 131 | * use layerId instead of group for select 132 | * uses Viewer window for selectMap() 133 | * promote mapview to Imports 134 | * uses newly exported mapview::addFeatures() 135 | 136 | 137 | # mapedit 0.1.0 138 | 139 | **API breaking change** 140 | 141 | * camelCase `editMap` and `selectMap` 142 | 143 | 144 | # mapedit 0.0.2 145 | 146 | * add dependency on `dplyr` 147 | * add dependency on `sf` 148 | * `edit_map()` now returns `sf` instead of `geojson` by default. Toggle 149 | behavior with the `sf` argument. 150 | 151 | 152 | # mapedit 0.0.1 153 | 154 | * first release with proof-of-concept functionality 155 | -------------------------------------------------------------------------------- /R/addToolbar.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ##' @title Prepare arguments for addDrawToolbar or addPmToolbar 4 | ##' @param fun Function used by editor package (leafpm or 5 | ##' leaflet.extras) to set defaults 6 | ##' @param args Either a (possibly nested) list of named options of 7 | ##' the form suitable for passage to \code{fun} or (if the chosen 8 | ##' editor is \code{"leaflet.extras"}) \code{FALSE}. 9 | ##' @return An object suitable for passing in as the supplied argument 10 | ##' to either \code{leaflet.extras::addDrawToolbar} or 11 | ##' \code{leafpm::addPmToolbar}. 12 | processOpts <- function(fun, args) { 13 | ## Account for special meaning of `FALSE` as arg in leaflet.extras 14 | if(identical(args, FALSE)) { 15 | return(FALSE) 16 | } else { 17 | return(do.call(fun, args)) 18 | } 19 | } 20 | 21 | 22 | ##' @title Add a (possibly customized) toolbar to a leaflet map 23 | ##' @param leafmap leaflet map to use for Selection 24 | ##' @param editorOptions A list of options to be passed on to either 25 | ##' \code{leaflet.extras::addDrawToolbar} or 26 | ##' \code{leafpm::addPmToolbar}. 27 | ##' @param editor Character string giving editor to be used for the 28 | ##' current map. Either \code{"leafpm"} or 29 | ##' \code{"leaflet.extras"}. 30 | ##' @param targetLayerId \code{string} name of the map layer group to 31 | ##' use with edit 32 | ##' @return The leaflet map supplied to \code{leafmap}, now with an 33 | ##' added toolbar. 34 | addToolbar <- function(leafmap, editorOptions, editor, 35 | targetLayerId) { 36 | ## Set up this package's defaults 37 | if (editor == "leafpm") { 38 | if(any(sapply(leafmap$x$calls, "[[", "method") %in% 39 | c("addPolylines", "addPolygons"))) { 40 | editorDefaults <- 41 | list(toolbarOptions = list(drawCircle = FALSE), 42 | drawOptions = list(allowSelfIntersection = FALSE), 43 | editOptions = list(allowSelfIntersection = FALSE), 44 | cutOptions = list(allowSelfIntersection = FALSE)) 45 | } else { 46 | editorDefaults <- 47 | list(toolbarOptions = list(drawCircle = FALSE), 48 | drawOptions = list(), 49 | editOptions = list(), 50 | cutOptions = list()) 51 | } 52 | } 53 | if (editor == "leaflet.extras") { 54 | editorDefaults <- 55 | list(polylineOptions = list(repeatMode = TRUE), 56 | polygonOptions = list(repeatMode = TRUE), 57 | circleOptions = FALSE, 58 | rectangleOptions = list(repeatMode = TRUE), 59 | markerOptions = list(repeatMode = TRUE), 60 | circleMarkerOptions = list(repeatMode = TRUE), 61 | editOptions = list()) 62 | } 63 | 64 | ## Apply user-supplied options, if any 65 | editorArgs <- utils::modifyList(editorDefaults, editorOptions) 66 | 67 | 68 | ## Add toolbar to leafmap object 69 | if (editor == "leaflet.extras") { 70 | leaflet.extras::addDrawToolbar( 71 | leafmap, 72 | targetGroup = targetLayerId, 73 | polylineOptions = 74 | processOpts(leaflet.extras::drawPolylineOptions, 75 | editorArgs[["polylineOptions"]]), 76 | polygonOptions = 77 | processOpts(leaflet.extras::drawPolygonOptions, 78 | editorArgs[["polygonOptions"]]), 79 | circleOptions = 80 | processOpts(leaflet.extras::drawCircleOptions, 81 | editorArgs[["circleOptions"]]), 82 | rectangleOptions = 83 | processOpts(leaflet.extras::drawRectangleOptions, 84 | editorArgs[["rectangleOptions"]]), 85 | markerOptions = 86 | processOpts(leaflet.extras::drawMarkerOptions, 87 | editorArgs[["markerOptions"]]), 88 | circleMarkerOptions = 89 | processOpts(leaflet.extras::drawCircleMarkerOptions, 90 | editorArgs[["circleMarkerOptions"]]), 91 | editOptions = 92 | processOpts(leaflet.extras::editToolbarOptions, 93 | editorArgs[["editOptions"]]) 94 | ) 95 | } else if (editor == "leafpm") { 96 | leafpm::addPmToolbar( 97 | leafmap, 98 | targetGroup = targetLayerId, 99 | toolbarOptions = processOpts(leafpm::pmToolbarOptions, 100 | editorArgs[["toolbarOptions"]]), 101 | drawOptions = processOpts(leafpm::pmDrawOptions, 102 | editorArgs[["drawOptions"]]), 103 | editOptions = processOpts(leafpm::pmEditOptions, 104 | editorArgs[["editOptions"]]), 105 | cutOptions = processOpts(leafpm::pmCutOptions, 106 | editorArgs[["cutOptions"]]) 107 | ) 108 | } 109 | } 110 | 111 | -------------------------------------------------------------------------------- /R/addin.R: -------------------------------------------------------------------------------- 1 | #' @title mapedit create features Addin 2 | #' @description Create and save spatial objects within the Rstudio IDE. Objects 3 | #' can then be saved to file types such as \code{.geojson} or \code{.shp}. 4 | #' Objects are also output to the console and can be assigned to a variable 5 | #' using `.Last.value`. If you wish to pass the output directly to a variable 6 | #' simply call the addin function, ie. \code{new_sf <- createFeatures()}. 7 | #' 8 | #' An existing sf \code{data.frame} can also be passed either indirectly by 9 | #' selecting text in RStudio with the name of the object, or directly by 10 | #' passing the existing sf object to \code{new_sf <- createFeatures(existing_sf)}. 11 | #' When passing an existing sf object you can only add and edit additional features, 12 | #' the existing features cannot be changed. 13 | #' 14 | #' @param SF_OBJECT sf Simple feature collection 15 | #' 16 | #' @return sf object and/or saved to file 17 | #' @export 18 | #' 19 | createFeatures <- function(SF_OBJECT = NULL) { 20 | 21 | ui <- miniUI::miniPage( 22 | miniUI::gadgetTitleBar("Edit Map"), 23 | miniUI::miniContentPanel( 24 | mapedit::editModUI("editor"), 25 | miniUI::miniButtonBlock( 26 | htmltools::div(style="display: inline-block;padding-top:22px;padding-left:30px;width:200px;", 27 | shinyWidgets::switchInput('savefile', 'Save', value = FALSE, onStatus = "success", offStatus = "danger")), 28 | htmltools::div(style="display: inline-block; width: 400px;", 29 | shiny::textInput('filename', '', value = 'saved_geometry.geojson')), 30 | htmltools::div(style="display: inline-block;padding-top:18px;width: 400px;font-size: 10pt;color: #313844;", 31 | 'The filename can include a path relative to working directory. ', 32 | 'A different file type can be selected by changing the file extension.') 33 | ) 34 | ) 35 | ) 36 | 37 | server <- function(input, output, session) { 38 | 39 | # get values from rstudio 40 | ct <- rstudioapi::getActiveDocumentContext() 41 | 42 | TEXT <- ct$selection[[1]]$text 43 | OBJECTNAME <- ifelse(TEXT == '', 'geom', TEXT) 44 | FILENAME <- ifelse(TEXT == '', 'saved_geometry.geojson', paste0(TEXT, '.geojson')) 45 | 46 | # test selected text an sf object (if not passed directly) 47 | try({ 48 | if (is.null(SF_OBJECT)) { 49 | SF_OBJECT <- get(TEXT) 50 | if (!('sf' %in% class(SF_OBJECT))) {SF_OBJECT <- NULL} 51 | } 52 | }, silent = TRUE) 53 | 54 | # update UI based on inputs 55 | shiny::updateTextInput(session, 'filename', value = FILENAME) 56 | if (FILENAME != 'saved_geometry.geojson') { 57 | shinyWidgets::updateSwitchInput(session, 'savefile', value = TRUE) 58 | } 59 | 60 | # load mapedit 61 | if ('sf' %in% class(SF_OBJECT)) { 62 | geo <- shiny::callModule(mapedit::editMod, "editor", mapview::mapview(SF_OBJECT)@map) 63 | } else { 64 | geo <- shiny::callModule(mapedit::editMod, "editor", leaflet::setView(mapview::mapview()@map, 80, 0, 3)) 65 | } 66 | 67 | shiny::observe({ 68 | input$filename 69 | OBJECTNAME <- tools::file_path_sans_ext(basename(input$filename)) 70 | }) 71 | 72 | # return geometry to file and object in console 73 | shiny::observeEvent(input$done, { 74 | geom <- geo()$finished 75 | 76 | if (!is.null(geom) & !is.null(SF_OBJECT)) { 77 | geom <- dplyr::bind_rows(SF_OBJECT, geom) 78 | } 79 | 80 | if (!is.null(geom)) { 81 | if (input$savefile) { 82 | sf::write_sf(geom, input$filename, delete_layer = TRUE, delete_dsn = TRUE) 83 | } 84 | } 85 | 86 | shiny::stopApp({ 87 | if (!is.null(geom)) { 88 | geom 89 | } 90 | }) 91 | }) 92 | 93 | } 94 | 95 | viewer <- shiny::paneViewer(600) 96 | shiny::runGadget(ui, server, viewer = viewer) 97 | 98 | } 99 | -------------------------------------------------------------------------------- /R/draw.R: -------------------------------------------------------------------------------- 1 | #' Draw (simple) features on a map 2 | #' 3 | #' @name drawFeatures 4 | #' 5 | #' @param map a background \code{leaflet} or \code{mapview} map 6 | #' to be used for editing. If \code{NULL} a blank 7 | #' mapview canvas will be provided. 8 | #' @param sf \code{logical} return simple features. The default is \code{TRUE}. 9 | #' If \code{sf = FALSE}, \code{GeoJSON} will be returned. 10 | #' @param record \code{logical} to record all edits for future playback. 11 | #' @param viewer \code{function} for the viewer. See Shiny \code{shiny::viewer}. 12 | #' NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 13 | #' open the app in the default browser, the browser window will automatically 14 | #' close when closing the app (by pressing "done" or "cancel") in most browsers. 15 | #' Firefox is an exception. See Details for instructions on how to enable this 16 | #' behaviour in Firefox. 17 | #' @param title \code{string} to customize the title of the UI window. 18 | #' @param editor \code{character} either "leaflet.extras" or "leafpm" 19 | #' @param editorOptions \code{list} of options suitable for passing to 20 | #' either \code{leaflet.extras::addDrawToolbar} or 21 | #' \code{leafpm::addPmToolbar}. 22 | #' @param ... additional arguments passed on to \code{\link{editMap}}. 23 | #' 24 | #' @details 25 | #' When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 26 | #' the systems default browser is Firefox, the browser window will likely not 27 | #' automatically close when the app is closed (by pressing "done" or "cancel"). 28 | #' To enable automatic closing of tabs/windows in Firefox try the following: 29 | #' \itemize{ 30 | #' \item{input "about:config " to your firefox address bar and hit enter} 31 | #' \item{make sure your "dom.allow_scripts_to_close_windows" is true} 32 | #' } 33 | #' 34 | #' @export 35 | drawFeatures = function(map = NULL, 36 | sf = TRUE, 37 | record = FALSE, 38 | viewer = shiny::paneViewer(), 39 | title = "Draw Features", 40 | editor = c("leaflet.extras", "leafpm"), 41 | editorOptions = list(), 42 | ...) { 43 | res = editMap(x = map, 44 | sf = sf, 45 | record = record, 46 | viewer = viewer, 47 | title = title, 48 | editor = editor, 49 | editorOptions = editorOptions, 50 | ...) 51 | if (!inherits(res, "sf") && is.list(res)) res = res$finished 52 | return(res) 53 | } 54 | -------------------------------------------------------------------------------- /R/edit.R: -------------------------------------------------------------------------------- 1 | #' Interactively Edit a Map 2 | #' 3 | #' @param x \code{leaflet} or \code{mapview} map to edit 4 | #' @param ... other arguments for \code{leafem::addFeatures()} when 5 | #' using \code{editMap.NULL} or \code{selectFeatures} 6 | #' 7 | #' @return \code{sf} simple features or \code{GeoJSON} 8 | #' 9 | #' @examples 10 | #' \dontrun{ 11 | #' library(leaflet) 12 | #' library(mapedit) 13 | #' editMap(leaflet() %>% addTiles()) 14 | #' } 15 | #' @example inst/examples/examples_edit.R 16 | #' @export 17 | editMap <- function(x, ...) { 18 | UseMethod("editMap") 19 | } 20 | 21 | #' @name editMap 22 | #' @param targetLayerId \code{string} name of the map layer group to use with edit 23 | #' @param sf \code{logical} return simple features. The default is \code{TRUE}. 24 | #' If \code{sf = FALSE}, \code{GeoJSON} will be returned. 25 | #' @param ns \code{string} name for the Shiny \code{namespace} to use. The \code{ns} 26 | #' is unlikely to require a change. 27 | #' @param record \code{logical} to record all edits for future playback. 28 | #' @param viewer \code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 29 | #' NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 30 | #' open the app in the default browser, the browser window will automatically 31 | #' close when closing the app (by pressing "done" or "cancel") in most browsers. 32 | #' Firefox is an exception. See Details for instructions on how to enable this 33 | #' behaviour in Firefox. 34 | #' @param crs see \code{\link[sf]{st_crs}}. 35 | #' @param title \code{string} to customize the title of the UI window. The default 36 | #' is "Edit Map". 37 | #' @param editor \code{character} either "leaflet.extras" or "leafpm" 38 | #' @param editorOptions \code{list} of options suitable for passing to 39 | #' either \code{leaflet.extras::addDrawToolbar} or 40 | #' \code{leafpm::addPmToolbar}. 41 | #' 42 | #' @details 43 | #' When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 44 | #' the systems default browser is Firefox, the browser window will likely not 45 | #' automatically close when the app is closed (by pressing "done" or "cancel"). 46 | #' To enable automatic closing of tabs/windows in Firefox try the following: 47 | #' \itemize{ 48 | #' \item{input "about:config " to your firefox address bar and hit enter} 49 | #' \item{make sure your "dom.allow_scripts_to_close_windows" is true} 50 | #' } 51 | #' 52 | #' @export 53 | editMap.leaflet <- function( 54 | x = NULL, targetLayerId = NULL, sf = TRUE, 55 | ns = "mapedit-edit", record = FALSE, viewer = shiny::paneViewer(), 56 | crs = 4326, 57 | title = "Edit Map", 58 | editor = c("leaflet.extras", "leafpm"), 59 | editorOptions = list(), 60 | ... 61 | ) { 62 | stopifnot(!is.null(x), inherits(x, "leaflet")) 63 | 64 | stopifnot( 65 | requireNamespace("leaflet"), 66 | requireNamespace("leaflet.extras"), 67 | requireNamespace("shiny"), 68 | requireNamespace("miniUI") 69 | ) 70 | 71 | ui <- miniUI::miniPage( 72 | miniUI::miniContentPanel( 73 | editModUI(id = ns, height="97%"), 74 | height=NULL, width=NULL 75 | ), 76 | miniUI::gadgetTitleBar( 77 | title = title, 78 | right = miniUI::miniTitleBarButton("done", "Done", primary = TRUE) 79 | ), 80 | htmltools::tags$script(htmltools::HTML( 81 | " 82 | // close browser window on session end 83 | $(document).on('shiny:disconnected', function() { 84 | // check to make sure that button was pressed 85 | // to avoid websocket disconnect caused by some other reason than close 86 | if( 87 | Shiny.shinyapp.$inputValues['cancel:shiny.action'] || 88 | Shiny.shinyapp.$inputValues['done:shiny.action'] 89 | ) { 90 | window.close() 91 | } 92 | }) 93 | " 94 | )) 95 | ) 96 | 97 | server <- function(input, output, session) { 98 | crud <- shiny::callModule( 99 | editMod, 100 | ns, 101 | x, 102 | targetLayerId = targetLayerId, 103 | sf = sf, 104 | record = record, 105 | crs = crs, 106 | editor = editor, 107 | editorOptions = editorOptions 108 | ) 109 | 110 | shiny::observe({crud()}) 111 | 112 | # if browser viewer and user closes tab/window 113 | # then Shiny does not stop so we will stopApp 114 | # when a session ends. This works fine unless a user might 115 | # have two sessions open. Closing one will also close the 116 | # other. 117 | sessionEnded <- session$onSessionEnded(function() { 118 | # should this be a cancel where we send NULL 119 | # or a done where we send crud() 120 | shiny::stopApp(shiny::isolate(crud())) 121 | }) 122 | 123 | shiny::observeEvent(input$done, { 124 | shiny::stopApp( 125 | crud() 126 | ) 127 | # cancel session ended handler to prevent https://github.com/r-spatial/mapedit/issues/83 128 | sessionEnded() 129 | }) 130 | 131 | 132 | shiny::observeEvent(input$cancel, { 133 | shiny::stopApp (NULL) 134 | # cancel session ended handler to prevent https://github.com/r-spatial/mapedit/issues/83 135 | sessionEnded() 136 | }) 137 | } 138 | 139 | shiny::runGadget( 140 | ui, 141 | server, 142 | viewer = viewer, 143 | stopOnCancel = FALSE 144 | ) 145 | } 146 | 147 | #' @name editMap 148 | #' @export 149 | editMap.mapview <- function( 150 | x = NULL, targetLayerId = NULL, sf = TRUE, 151 | ns = "mapedit-edit", record = FALSE, viewer = shiny::paneViewer(), 152 | crs = 4326, 153 | title = "Edit Map", 154 | editor = c("leaflet.extras", "leafpm"), 155 | editorOptions = list(), 156 | ... 157 | ) { 158 | stopifnot(!is.null(x), inherits(x, "mapview"), inherits(x@map, "leaflet")) 159 | 160 | editMap.leaflet( 161 | x@map, targetLayerId = targetLayerId, sf = sf, 162 | ns = ns, viewer = viewer, record = TRUE, crs = crs, 163 | title = title, 164 | editor = editor, 165 | editorOptions = editorOptions 166 | ) 167 | } 168 | 169 | #' @name editMap 170 | #' @export 171 | editMap.NULL = function(x, editor = c("leaflet.extras", "leafpm"), 172 | editorOptions = list(), ...) { 173 | m = mapview::mapview()@map 174 | m = leaflet::fitBounds( 175 | m, 176 | lng1 = -180, #as.numeric(sf::st_bbox(x)[1]), 177 | lat1 = -90, #as.numeric(sf::st_bbox(x)[2]), 178 | lng2 = 180, #as.numeric(sf::st_bbox(x)[3]), 179 | lat2 = 90 #as.numeric(sf::st_bbox(x)[4]) 180 | ) 181 | ed = editMap(m, record = TRUE, editor = editor, 182 | editorOptions = editorOptions) 183 | ed_record <- ed$finished 184 | attr(ed_record, "recorder") <- attr(ed, "recorder", exact = TRUE) 185 | ed_record 186 | } 187 | 188 | 189 | #' Interactively Edit Map Features 190 | #' 191 | #' @param x features to edit 192 | #' @param ... other arguments 193 | #' 194 | #' @example ./inst/examples/examples_select.R 195 | #' @export 196 | editFeatures = function(x, ...) { 197 | UseMethod("editFeatures") 198 | } 199 | 200 | #' @name editFeatures 201 | #' 202 | #' @param map a background \code{leaflet} or \code{mapview} map 203 | #' to be used for editing. If \code{NULL} a blank 204 | #' mapview canvas will be provided. 205 | #' @param mergeOrder \code{vector} or \code{character} arguments to specify the order 206 | #' of merge operations. By default, merges will proceed in the order 207 | #' of add, edit, delete. 208 | #' @param record \code{logical} to record all edits for future playback. 209 | #' @param viewer \code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 210 | #' NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 211 | #' open the app in the default browser, the browser window will automatically 212 | #' close when closing the app (by pressing "done" or "cancel") in most browsers. 213 | #' Firefox is an exception. See Details for instructions on how to enable this 214 | #' behaviour in Firefox. 215 | #' @param label \code{character} vector or \code{formula} for the 216 | #' content that will appear in label/tooltip. 217 | #' @param crs see \code{\link[sf]{st_crs}}. 218 | #' @param title \code{string} to customize the title of the UI window. The default 219 | #' is "Edit Map". 220 | #' @param editor \code{character} either "leaflet.extras" or "leafpm" 221 | #' @param editorOptions \code{list} of options suitable for passing to 222 | #' either \code{leaflet.extras::addDrawToolbar} or 223 | #' \code{leafpm::addPmToolbar}. 224 | #' 225 | #' @details 226 | #' When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 227 | #' the systems default browser is Firefox, the browser window will likely not 228 | #' automatically close when the app is closed (by pressing "done" or "cancel"). 229 | #' To enable automatic closing of tabs/windows in Firefox try the following: 230 | #' \itemize{ 231 | #' \item{input "about:config " to your firefox address bar and hit enter} 232 | #' \item{make sure your "dom.allow_scripts_to_close_windows" is true} 233 | #' } 234 | #' 235 | #' @export 236 | editFeatures.sf = function( 237 | x, 238 | map = NULL, 239 | mergeOrder = c("add", "edit", "delete"), 240 | record = FALSE, 241 | viewer = shiny::paneViewer(), 242 | crs = 4326, 243 | label = NULL, 244 | title = "Edit Map", 245 | editor = c("leaflet.extras", "leafpm"), 246 | editorOptions = list(), 247 | ... 248 | ) { 249 | 250 | # store original projection of edited object ---- 251 | orig_proj <- sf::st_crs(x) 252 | if (is.na(orig_proj)) { 253 | stop("The CRS of the input object is not set. Aborting. `mapedit` does not currently 254 | allow editing objects with arbitrary coordinates system. Please set the 255 | CRS of the input using `sf::st_set_crs()` (for `sf` objects) or `proj4string() 256 | for `sp` objects", call. = FALSE) 257 | } 258 | 259 | x$edit_id = as.character(1:nrow(x)) 260 | 261 | if (is.null(map)) { 262 | x = checkAdjustProjection(x) 263 | map = mapview::mapview()@map 264 | map = leafem::addFeatures( 265 | map, data=x, layerId=~x$edit_id, 266 | label=label, 267 | labelOptions = leaflet::labelOptions(direction="top", offset=c(0,-40)), 268 | group = "toedit" 269 | ) 270 | ext = createExtent(x) 271 | map = leaflet::fitBounds( 272 | map, 273 | lng1 = ext[1], 274 | lat1 = ext[3], 275 | lng2 = ext[2], 276 | lat2 = ext[4] 277 | ) 278 | map = leafem::addHomeButton(map = map, ext = ext) 279 | } else { 280 | if(inherits(map, "mapview")) { 281 | map = map@map 282 | } 283 | map = leafem::addFeatures( 284 | map, data=x, layerId=~x$edit_id, 285 | label=label, 286 | labelOptions = leaflet::labelOptions(direction="top", offset=c(0,-40)), 287 | group = "toedit" 288 | ) 289 | } 290 | 291 | if(inherits(map, "mapview")) map = map@map 292 | 293 | crud = editMap( 294 | map, targetLayerId = "toedit", 295 | viewer = viewer, record = record, 296 | crs = crs, title = title, 297 | editor = editor, editorOptions = editorOptions, ... 298 | ) 299 | 300 | merged <- Reduce( 301 | function(left_sf, op) { 302 | op <- tolower(op) 303 | if(op == "add") sf_merge <- crud$finished 304 | if(op == "edit") sf_merge <- crud$edited 305 | if(op == "delete") sf_merge <- crud$deleted 306 | 307 | if(is.null(sf_merge)) return(left_sf) 308 | 309 | # will need to rethink this but for now 310 | # since we use finished above 311 | # only apply edit and delete 312 | # where an edit_id is available 313 | # meaning only to a feature in the original sf 314 | if(op %in% c("edit", "delete")) { 315 | # if layerId column does not exist then all are new features 316 | # and should already be handled in finished 317 | if(!("layerId" %in% colnames(sf_merge))) { 318 | return(left_sf) 319 | } 320 | # ignore any with NA as layerId since these will also be 321 | # handled in finished 322 | sf_merge <- sf_merge[which(!is.na(sf_merge$layerId)),] 323 | } 324 | 325 | if(nrow(sf_merge) == 0) return(left_sf) 326 | 327 | eval(call(paste0("merge_", op), left_sf, sf_merge, c("edit_id" = "layerId"))) 328 | }, 329 | mergeOrder, 330 | init = x 331 | ) 332 | 333 | merged <- dplyr::select(merged, -dplyr::all_of("edit_id")) 334 | 335 | # re-transform to original projection if needed ---- 336 | if (sf::st_crs(merged) != orig_proj) { 337 | merged <- sf::st_transform(merged, orig_proj) 338 | } 339 | 340 | # warn if anything is not valid 341 | if(!all(sf::st_is_valid(merged))) { 342 | warning("returned features do not appear valid; please inspect closely", call. = FALSE) 343 | } 344 | 345 | # return merged features 346 | if(record==TRUE) { 347 | attr(merged, "recorder") <- attr(crud, "recorder", exact=TRUE) 348 | attr(merged, "original") <- x 349 | } 350 | 351 | merged 352 | } 353 | 354 | #' @name editFeatures 355 | #' @export 356 | editFeatures.Spatial = function(x, ...) { 357 | editFeatures(sf::st_as_sf(x), ...) 358 | } 359 | -------------------------------------------------------------------------------- /R/editAttributes.R: -------------------------------------------------------------------------------- 1 | #' @title Edit Feature Attributes 2 | #' 3 | #' @description Launches a `shiny` application where you can add and edit spatial geometry 4 | #' and attributes. Geometry is created or edited within the interactive map, while feature attributes 5 | #' can be added to and edited within the editable table. 6 | #' 7 | #' Starting with a `data.frame` or an `sf data.frame`, a list of `sf data.frames` or nothing 8 | #' at all. You can add columns, and rows and geometry for each row. Clicking on a row with geometry you can 9 | #' zoom across the map between features. 10 | #' 11 | #' When you are done, your edits are saved to an `sf data.frame` for 12 | #' use in R or to be saved to anyformat you wish via \link[sf]{st_write}. 13 | #' 14 | #' The application can dynamically handle: character, numeric, integer, factor and date fields. 15 | #' 16 | #' When the input data set is an `sf data.frame` the map automatically zooms to the extent of the `sf` object. 17 | #' 18 | #' When the input has no spatial data, you must tell the function where to zoom. The function uses 19 | #' \link[tmaptools]{geocode_OSM} to identify the coordinates of your area of interest. 20 | #' 21 | #' @param dat input data source, can be a `data.frame` or an `sf data.frame`, or it can be left empty. 22 | #' When nothing is passed to `dat` a basic `data.frame` is generated with `id` and `comment` fields. 23 | #' @param zoomto character area of interest. The area is defined using \link[tmaptools]{geocode_OSM}, 24 | #' which uses \href{https://nominatim.org/}{OSM Nominatim}. The area can be as ambiguous as a country, or 25 | #' as specific as a street address. You can test the area of interest using the application or the example 26 | #' code below. 27 | #' @param col_add boolean option to enable add columns form. Set to false if you don't want to allow a user to modify 28 | #' the data structure. 29 | #' @param reset boolean option to reset attribute input. Set to false if you don't want the attribute input to 30 | #' reset to NA after each added row. Use this option when features share common attributes 31 | #' @param provider A character string indicating the provider tile of choice, e.g. 'Esri.WorldImagery' (default) 32 | #' @param testing Only relevant for internal testing using shinytest. 33 | #' 34 | #' @note Editing of feature geometries does not work for multi-geometry inputs. For this use case it is advisable to 35 | #' split the data set by geometry type and edit separately 36 | #' 37 | #' @return sf data.frame 38 | #' @export 39 | #' 40 | #' @examples 41 | #' \dontrun{ 42 | #' 43 | #' # with no input 44 | #' data_sf <- editAttributes(zoomto = 'germany') 45 | #' 46 | #' # a data.frame input 47 | #' dat <- data.frame(name = c('SiteA', 'SiteB'), 48 | #' type = factor( 49 | #' c('park', 'zoo') 50 | #' , levels = c('park', 'factory', 'zoo', 'warehouse') 51 | #' ), 52 | #' size = c(35, 45)) 53 | #' 54 | #' data_sf <- editAttributes(dat, zoomto = 'berlin') 55 | #' 56 | #' # an sf data.frame input 57 | #' data_sf <- editAttributes(data_sf) 58 | #' 59 | #' # test zoomto area of interest 60 | #' zoomto_area <- tmaptools::geocode_OSM('paris') 61 | #' mapview(st_as_sfc(zoomto_area$bbox)) 62 | #' 63 | #' } 64 | editAttributes <- function(dat, zoomto = NULL, col_add = TRUE, reset = TRUE, provider = 'Esri.WorldImagery', testing = FALSE){ 65 | 66 | DEFAULT_ZOOM <- 'africa' 67 | MSG <- 'When neither sf object nor zoomto is default, map will zoom to Africa' 68 | 69 | leaf_id = NULL 70 | 71 | #create base df if dat missing 72 | if (missing(dat)) { 73 | dat <- data.frame(id = 'CHANGE ME', comments = 'ADD COMMENTS...') %>% 74 | dplyr::mutate(leaf_id = 1) 75 | if (is.null(zoomto)) { 76 | message(MSG) 77 | zoomto <- DEFAULT_ZOOM 78 | } 79 | } 80 | 81 | APP_CRS <- 4326 82 | 83 | # Need to parse out spatial objects if input data is spatial 84 | type <- c('sf', 'SpatVector') 85 | 86 | # accept list of sf data.frames with multiple geom types 87 | original_sf <- NULL 88 | if (all(class(dat) == 'list')) { 89 | original_sf <- lapply(dat, function(df){ 90 | df %>% dplyr::mutate(leaf_id = 1:nrow(df)) 91 | }) 92 | dat <- dplyr::bind_rows(dat) %>% dplyr::mutate(leaf_id = 1:nrow(dat)) 93 | } 94 | 95 | if (all(class(dat) == 'data.frame')) { 96 | dat <- dat %>% dplyr::mutate(leaf_id = 1:nrow(dat)) 97 | data_copy <- sf::st_as_sf( 98 | dat, 99 | geometry = sf::st_sfc(lapply(seq_len(nrow(dat)),function(i){sf::st_point()})) 100 | ) %>% sf::st_set_crs(APP_CRS) 101 | 102 | user_crs <- APP_CRS 103 | le = TRUE 104 | 105 | if (is.null(zoomto)) { 106 | message(MSG) 107 | zoomto <- DEFAULT_ZOOM 108 | } 109 | 110 | } else if (any(type %in% class(dat))) { 111 | 112 | dat <- dat %>% dplyr::mutate(leaf_id = 1:nrow(dat)) %>% sf::st_transform(APP_CRS) 113 | data_copy <- dat # TODO check orig crs and transform to 4326 114 | 115 | if(is.na(sf::st_crs(dat))){dat <- dat %>% sf::st_set_crs(APP_CRS)} 116 | if(class(dat)[[1]] == 'SpatVector'){dat <- sf::st_as_sf(dat)} 117 | #if(class(dat)[[1]] == 'sf'){class(dat) <- c('sf', 'data.frame')} 118 | 119 | user_crs <- sf::st_crs(dat) 120 | 121 | # this is used to make sure the edit toolbar is disabled when these are inputs 122 | # if not, then the app will hang and requires ending task. 123 | le <- !any(sf::st_geometry_type(dat) %in% c('MULTILINESTRING', 'MULTIPOLYGON')) 124 | 125 | } else if (!any(type %in% class(dat))) { 126 | assertthat::assert_that(!(is.null(zoomto)), 127 | msg = 'If your input is a non-spatial data.frame you must define a zoomto location') 128 | } 129 | 130 | # if data or empty (dat) need a zoom to place 131 | if (!is.null(zoomto)) { 132 | zoomto_area <- tmaptools::geocode_OSM(zoomto) 133 | zoomto <- sf::st_as_sfc(zoomto_area$bbox) %>% sf::st_sf() %>% sf::st_set_crs(APP_CRS) 134 | } 135 | 136 | 137 | ui <- htmltools::tagList( 138 | shinyWidgets::useSweetAlert(), 139 | shiny::fluidPage( 140 | shiny::fluidRow( 141 | shiny::column(12, editModUI("map")) 142 | ), 143 | htmltools::tags$hr(), 144 | shiny::fluidRow( 145 | shiny::column(ifelse(col_add, 6, 9), 146 | DT::dataTableOutput("tbl",width="100%", height=200)), 147 | shiny::column(3, 148 | shiny::wellPanel( 149 | shiny::h3('Add New Row'), 150 | shiny::uiOutput('dyn_form'), 151 | shinyWidgets::actionBttn("row_add", "Row", 152 | icon = shiny::icon('plus'), 153 | style = 'material-flat', 154 | block = TRUE, 155 | color = 'primary', 156 | size = 'md')) 157 | ), 158 | {if (col_add) { 159 | shiny::column(3, 160 | shiny::wellPanel( 161 | shiny::h3('Add New Column'), 162 | shiny::textInput('new_name', 'New Column Name', width = '100%'), 163 | shiny::radioButtons('new_type', 'Column Type', choices = c('character', 'numeric', 'integer', 'Date')), 164 | shinyWidgets::actionBttn("col_add", "Column", 165 | icon = shiny::icon('plus'), 166 | style = 'material-flat', 167 | block = TRUE, 168 | color = 'primary', 169 | size = 'md')) 170 | )} else { 171 | NULL 172 | } 173 | } 174 | ), 175 | shiny::fluidRow(htmltools::tags$hr(), 176 | shiny::div(style = 'padding: 20px', 177 | shinyWidgets::actionBttn("donebtn", "Done", 178 | icon = shiny::icon('check-circle'), 179 | style = 'material-flat', 180 | block = TRUE, 181 | color = 'success', 182 | size = 'lg'))) 183 | 184 | ) 185 | ) 186 | 187 | server <- function(input, output, session) { 188 | 189 | # gather all data into reactiveValues 190 | df <- shiny::reactiveValues(types = sapply(dat, class), 191 | data = data_copy, 192 | zoom_to = zoomto, 193 | edit_logic = le) 194 | 195 | # mapedit module 196 | shiny::observe({ 197 | 198 | edits <- shiny::callModule( 199 | module = editMod, 200 | leafmap = { 201 | 202 | if (any(type %in% class(dat))){ 203 | 204 | mapv <- leaflet::leaflet() %>% 205 | leaflet::addProviderTiles(provider = provider, 206 | group = provider) %>% 207 | leaflet::addLayersControl(baseGroups = provider, 208 | position = 'topleft') %>% 209 | leafem::addFeatures(data = df$data, 210 | layerId = df$data$leaf_id, 211 | group = 'editLayer', 212 | popup = leafpop::popupTable(df$data)) 213 | } else { 214 | mapv <- mapview::mapview(df$zoom_to, 215 | map.types = provider)@map %>% 216 | leaflet::hideGroup('df$zoom_to') %>% 217 | leafem::addFeatures(data = df$data, 218 | layerId = df$data$leaf_id, 219 | group = 'editLayer', 220 | popup = leafpop::popupTable(df$data)) 221 | } 222 | mapv 223 | }, 224 | id = "map", 225 | targetLayerId = 'editLayer', 226 | sf = TRUE, 227 | editorOptions = list(editOptions = leaflet.extras::editToolbarOptions(edit = df$edit_logic)), 228 | ) 229 | }) 230 | 231 | #make a proxy map 232 | proxy_map <- leaflet::leafletProxy('map-map', session) 233 | 234 | # watch for NEW COLUMN button clicks 235 | shiny::observeEvent(input$col_add, { 236 | 237 | if (nchar(input$new_name)==0) { 238 | shinyWidgets::show_alert('Missing Column Name', 239 | 'this column is missing a name, this must be entered before adding a column', 240 | type = 'warning') 241 | } else { 242 | 243 | add_col <- df$data 244 | add_col[[input$new_name]] <- do.call(paste0('as.', input$new_type), list(NA)) 245 | 246 | df$data <- add_col 247 | ntype <- input$new_type 248 | names(ntype) <- input$new_name 249 | df$types <- c(df$types, ntype) 250 | 251 | shiny::updateTextInput(session, 'new_name', value = NA) 252 | shiny::showNotification('Added New Column') 253 | } 254 | }) 255 | 256 | 257 | # render new row form based on the existing data structure 258 | shiny::observe({ 259 | 260 | output$dyn_form <- shiny::renderUI({ 261 | 262 | htmltools::tagList( 263 | lapply(1:length(df$types), function(n){ 264 | name <- names(df$types[n]) 265 | label <- paste0(names(df$types[n]), ' (', df$types[n], ')') 266 | if (df$types[n] == 'character') { 267 | shiny::textInput(name, label, width = '100%') 268 | } else if (df$types[n] == 'factor') { 269 | shiny::selectInput(name, label, width = '100%', 270 | choices = levels(dat[[names(df$types[n])]]), 271 | selected = NULL, 272 | selectize = TRUE) 273 | } else if (df$types[n] %in% c('numeric','integer')) { 274 | shiny::numericInput(name, label, width = '100%', value = NA) 275 | } else if (df$types[n] == 'Date') { 276 | shiny::dateInput(name, label, width = '100%', value = NA) 277 | } 278 | }), 279 | # we don't want to see this element but it is needed to form data structure 280 | htmltools::tags$script("document.getElementById('leaf_id-label').hidden = true; document.getElementById('leaf_id').style.visibility = 'hidden';") 281 | ) 282 | 283 | }) 284 | }) 285 | 286 | # render editable data table 287 | output$tbl <- DT::renderDataTable({ 288 | 289 | n <- grep('leaf_id|geom', colnames(df$data)) # used to hide geometry/leaf_id column 290 | 291 | DT::datatable( 292 | df$data, 293 | options = list(scrollY="200px", 294 | pageLength = 50, 295 | scrollX = TRUE, 296 | columnDefs = list(list(visible=FALSE, targets=n))), 297 | # could support multi but do single for now 298 | selection = "single", 299 | height = 200, 300 | editable = TRUE, 301 | ) 302 | }) 303 | 304 | proxy = DT::dataTableProxy('tbl') 305 | 306 | 307 | # modify namespace to get map ID 308 | nsm <- function(event="", id="map") { 309 | paste0(session$ns(id), "-", event) 310 | } 311 | 312 | # unfortunately I did not implement last functionality 313 | # for editMap, so do it the hard way 314 | # last seems useful, so I might circle back and add that 315 | EVT_DRAW <- "map_draw_new_feature" 316 | EVT_EDIT <- "map_draw_edited_features" 317 | EVT_DELETE <- "map_draw_deleted_features" 318 | 319 | #create a vector input for 'row_add' 320 | EVT_ADD_ROW <- "row_add" 321 | 322 | # determines whether to use 'row_add' or 'map_draw_feature' 323 | # also, if rows are selected then it won't trigger the 'map_draw_feature' 324 | addRowOrDrawObserve <- function(event, id) { 325 | shiny::observeEvent( 326 | if(is.na(id)){ 327 | 328 | input[[event]] 329 | 330 | } else { 331 | 332 | input[[nsm(event, id = id)]]},{ 333 | 334 | if(!is.null(input$tbl_rows_selected)){ 335 | 336 | } else { 337 | 338 | # creates first column and row (must be more elegant way) 339 | new_row <- data.frame(X = input[[names(df$types[1])]]) 340 | colnames(new_row) <- names(df$types[1]) 341 | 342 | # remaining columns will be correct size 343 | for (i in 2:length(df$types)) { 344 | new_row[names(df$types[i])] <- input[[names(df$types[i])]] 345 | } 346 | 347 | new_row <- sf::st_as_sf(new_row, geometry = sf::st_sfc(sf::st_point()), crs = APP_CRS) 348 | 349 | suppressWarnings({ 350 | # add to data_copy data.frame and update visible table 351 | df$data <- df$data %>% 352 | rbind(new_row) 353 | }) 354 | 355 | # reset input table 356 | if(isTRUE(reset)){ 357 | for (i in 1:length(df$types)) { 358 | typ <- df$types[i] 359 | nm <- names(typ) 360 | 361 | if (typ == 'character') { 362 | shiny::updateTextInput(session, nm, value = NA) 363 | } else if (typ %in% c('numeric','integer')) { 364 | shiny::updateNumericInput(session, nm, value = NA) 365 | } else if (typ == 'Date') { 366 | shiny::updateDateInput(session, nm, value = NA) 367 | } 368 | 369 | } 370 | } 371 | } 372 | }) 373 | } 374 | 375 | addRowOrDrawObserve(EVT_ADD_ROW, id = NA) 376 | addRowOrDrawObserve(EVT_DRAW, id = 'map') 377 | 378 | addDrawObserve <- function(event) { 379 | shiny::observeEvent( 380 | input[[nsm(event)]], 381 | { 382 | evt <- input[[nsm(event)]] 383 | 384 | # this allows the user to edit geometries or delete and then save without selecting row. 385 | # you can also select row and edit/delete as well but this gives the ability to not do so. 386 | if(event == EVT_DELETE) { 387 | 388 | ids <- vector() 389 | 390 | for(i in 1:length(evt$features)){ 391 | iter <- evt$features[[i]]$properties[['layerId']] 392 | ids <- append(ids, iter) 393 | } 394 | 395 | df$data <- dplyr::filter(df$data, !df$data$leaf_id %in% ids) 396 | df$ids <- ids 397 | 398 | } else if (event == EVT_EDIT) { 399 | 400 | for(i in 1:length(evt$features)){ 401 | 402 | evt_type <- evt$features[[i]]$geometry$type 403 | leaf_id <- evt$features[[i]]$properties[['layerId']] 404 | geom <- unlist(evt$features[[i]]$geometry$coordinates) 405 | 406 | if (evt_type == 'Point') { 407 | sf::st_geometry(df$data[df$data$leaf_id %in% leaf_id,]) <- sf::st_sfc(sf::st_point(geom)) 408 | } else if (evt_type == 'Polygon'){ 409 | geom <- matrix(geom, ncol = 2, byrow = T) 410 | sf::st_geometry(df$data[df$data$leaf_id %in% leaf_id,]) <- sf::st_sfc(sf::st_polygon(list(geom))) 411 | } else if (evt_type == 'LineString'){ 412 | geom <- matrix(geom, ncol = 2, byrow = T) 413 | sf::st_geometry(df$data[df$data$leaf_id %in% leaf_id,]) <- sf::st_sfc(sf::st_linestring(geom)) 414 | } 415 | } 416 | 417 | } else { 418 | 419 | # below determines whether to use 'row_add' or 'map_draw_feature' for adding geometries 420 | if(!is.null(input$tbl_rows_selected)) { 421 | selected <- shiny::isolate(input$tbl_rows_selected) 422 | } else if (event == EVT_DRAW){ 423 | selected <- length(input$tbl_rows_all) + 1 424 | } 425 | 426 | skip = FALSE 427 | 428 | # ignore if selected is null 429 | if(is.null(selected)) {skip = TRUE} 430 | 431 | # replace if draw or edit 432 | if(skip==FALSE) { 433 | sf::st_geometry(df$data[selected,]) <- sf::st_geometry( 434 | st_as_sfc.geo_list(evt)) 435 | 436 | #adding the leaf_id when we draw or row_add 437 | df$data[selected, 'leaf_id'] <- as.integer(evt$properties[['_leaflet_id']]) 438 | 439 | } 440 | } 441 | }) 442 | } 443 | 444 | addDrawObserve(EVT_DRAW) 445 | addDrawObserve(EVT_EDIT) 446 | addDrawObserve(EVT_DELETE) 447 | 448 | # this is used to keep the zoom of leaflet relevant 449 | shiny::observeEvent(input[[nsm(EVT_DRAW)]],{ 450 | 451 | click <- input[[nsm('map_draw_new_feature')]] 452 | 453 | if (click$geometry$type == 'Point') { 454 | 455 | clat <- click$geometry$coordinates[[2]] 456 | clng <- click$geometry$coordinates[[1]] 457 | proxy_map %>% 458 | leaflet::setView(lng = clng, lat = clat, zoom = input[[nsm('map_zoom')]]) 459 | 460 | } else { 461 | 462 | click_mat <- matrix(unlist(click$geometry$coordinates),ncol=2, byrow=TRUE) 463 | 464 | if(click$geometry$type == 'LineString'){ 465 | clat <- click_mat[[1,2]] 466 | clng <- click_mat[[1,1]] 467 | proxy_map %>% 468 | leaflet::setView(lng = clng, lat = clat, zoom = input[[nsm('map_zoom')]]) 469 | } else { 470 | bb <- sf::st_bbox(sf::st_geometry(sf::st_polygon(x = list(click_mat)))) 471 | proxy_map %>% 472 | leaflet::fitBounds(bb[['xmin']], bb[['ymin']], bb[['xmax']], bb[['ymax']]) 473 | 474 | } 475 | } 476 | }) 477 | 478 | # zoom to if feature available on selected row, same as above but with DT selected rows 479 | shiny::observeEvent( 480 | input$tbl_rows_selected, 481 | { 482 | selected <- input$tbl_rows_selected 483 | 484 | if(!is.null(selected)) { 485 | rowsel <- df$data[selected, ] 486 | # simple check to see if feature available 487 | # and leaflet id populated 488 | if (all(!is.na(sf::st_coordinates(sf::st_geometry(rowsel)[[1]])))) { 489 | 490 | if (sf::st_geometry_type(rowsel) == 'POINT') { 491 | pnt <- sf::st_coordinates(rowsel) %>% as.data.frame() 492 | proxy_map %>% 493 | leaflet::flyTo(lng = pnt$X, lat = pnt$Y, zoom = input[[nsm('map_zoom')]]) 494 | } else { 495 | bb <- sf::st_bbox(sf::st_geometry(rowsel)) 496 | proxy_map %>% 497 | leaflet::flyToBounds(bb[['xmin']], bb[['ymin']], bb[['xmax']], bb[['ymax']]) 498 | } 499 | 500 | } 501 | } 502 | } 503 | ) 504 | 505 | # update table cells with double click on cell 506 | shiny::observeEvent(input$tbl_cell_edit, { 507 | 508 | df$data <- DT::editData(df$data, input$tbl_cell_edit, 'tbl', resetPaging = F) 509 | DT::replaceData(proxy, df$data, rownames = FALSE, resetPaging = FALSE) 510 | 511 | }) 512 | 513 | # provide mechanism to return after all done 514 | shiny::observeEvent(input$donebtn, { 515 | 516 | if (testing) shiny::stopApp() 517 | 518 | if(grepl(class(df$data$geometry)[[1]], "sfc_GEOMETRY")){ 519 | 520 | if (any(sf::st_is_empty(df$data$geometry))) { 521 | shinyWidgets::show_alert('Missing Geometry', 522 | 'some features are missing geometry, these must be entered before saving', 523 | type = 'warning') 524 | } else { 525 | shiny::stopApp({ 526 | out <- df$data %>% dplyr::select(-leaf_id) %>% 527 | dplyr::mutate(geo_type = as.character(sf::st_geometry_type(df$data))) 528 | out <- sf::st_sf(out, crs = user_crs) 529 | out <- split(out , f = out$geo_type) 530 | 531 | # clean bounding box just in case 532 | for(i in 1:length(out)){ 533 | attr(sf::st_geometry(out[[i]]), "bbox") <- sf::st_bbox(sf::st_union(out[[i]]$geometry)) 534 | } 535 | 536 | out 537 | 538 | }) 539 | } 540 | 541 | } else { 542 | 543 | if (any(sf::st_is_empty(df$data$geometry))) { 544 | shinyWidgets::show_alert('Missing Geometry', 545 | 'some features are missing geometry, these must be entered before saving', 546 | type = 'warning') 547 | } else { 548 | shiny::stopApp({ 549 | # ensure export is sf and same as input crs 550 | out <- sf::st_sf(df$data,crs=user_crs) 551 | 552 | # clean bounding box just in case 553 | attr(sf::st_geometry(out), "bbox") <- sf::st_bbox(sf::st_union(out$geometry)) 554 | out %>% dplyr::select(-leaf_id) 555 | }) 556 | } 557 | } 558 | }) 559 | 560 | } 561 | 562 | # this allows shinytest to record 563 | if (testing) { 564 | return(shiny::shinyApp(ui,server)) 565 | } else { 566 | return(shiny::runApp(shiny::shinyApp(ui,server))) 567 | } 568 | 569 | 570 | } 571 | 572 | 573 | 574 | -------------------------------------------------------------------------------- /R/edit_map_return_sf.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | geojson_to_sf = function(x) { 3 | do.call( 4 | rbind, 5 | lapply(x, function(x) { 6 | x <- lapply(x, fix_geojson_coords) 7 | sf::read_sf( 8 | jsonlite::toJSON(x, force=TRUE, auto_unbox=TRUE, digits = NA) 9 | ) 10 | }) 11 | ) 12 | } 13 | 14 | #' @keywords internal 15 | st_as_sfc.geo_list = function(x, crs = 4326, ...) { 16 | geom_sf = sf::read_sf( 17 | jsonlite::toJSON(x, auto_unbox=TRUE, force=TRUE, digits = NA) 18 | ) 19 | suppressWarnings({ 20 | sf::st_crs(geom_sf) = crs 21 | }) 22 | return(geom_sf) 23 | } 24 | 25 | #' @keywords internal 26 | st_as_sf.geo_list = function(x, crs = 4326, ...) { 27 | if(x$type != "Feature") { 28 | stop("should be of type 'Feature'", call.=FALSE) 29 | } 30 | 31 | geom_sf <- st_as_sfc.geo_list(x) 32 | suppressWarnings({ 33 | sf::st_crs(geom_sf) = crs 34 | }) 35 | return(geom_sf) 36 | } 37 | 38 | #' @keywords internal 39 | fix_geojson_coords <- function(ft) { 40 | 41 | if(ft$geometry$type == "Point") { 42 | ft$geometry$coordinates <- unlist(ft$geometry$coordinates) 43 | } 44 | 45 | if(ft$geometry$type == "LineString") { 46 | ft$geometry$coordinates <- matrix( 47 | unlist(ft$geometry$coordinates), 48 | ncol = 2, 49 | byrow = TRUE 50 | ) 51 | } 52 | 53 | if(!(ft$geometry$type %in% c("Point", "LineString"))) { 54 | ft$geometry$coordinates <- lapply( 55 | ft$geometry$coordinates, 56 | function(coords) { 57 | matrix( 58 | unlist(ft$geometry$coordinates), 59 | ncol = 2, 60 | byrow = TRUE 61 | ) 62 | } 63 | ) 64 | } 65 | 66 | ft 67 | } 68 | 69 | #' @keywords internal 70 | combine_list_of_sf <- function(sf_list, crs = sf::st_crs(sf_list[[1]])) { 71 | if(length(sf_list) == 0) {return(NULL)} 72 | props <- dplyr::bind_rows( 73 | lapply( 74 | sf_list, 75 | function(x) { 76 | dplyr::select( 77 | as.data.frame(x, stringsAsFactors=FALSE), 78 | -dplyr::all_of(attr(x, "sf_column", exact=TRUE)) 79 | ) 80 | } 81 | ) 82 | ) 83 | 84 | sf::st_sf( 85 | props, 86 | geometry = sf::st_sfc( 87 | unlist(lapply(sf_list, function(x) sf::st_geometry(x)), recursive=FALSE) 88 | ), 89 | crs = sf::st_crs(crs) 90 | ) 91 | } 92 | -------------------------------------------------------------------------------- /R/helpers.R: -------------------------------------------------------------------------------- 1 | # check for sane longitude bounds of drawn features - latitude is always -90/90 2 | insane_longitude_warning = function() { 3 | if (requireNamespace("crayon", quietly = TRUE)) { 4 | warning(crayon::bgRed(crayon::white("\ndrawn features lie outside standard longitude bounds (-180 to 180) which is likely to cause trouble later!!")), 5 | call. = FALSE) 6 | } else { 7 | warning("\ndrawn features lie outside standard longitude bounds (-180 to 180) which is likely to cause trouble later!!", 8 | call. = FALSE) 9 | } 10 | } 11 | 12 | #' @title Pipe operator 13 | #' @description 14 | #' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 15 | #' 16 | #' @name %>% 17 | #' @usage lhs \%>\% rhs 18 | #' @rdname pipe 19 | #' @keywords internal 20 | #' @importFrom magrittr %>% 21 | #' @return `NULL` (this is the magrittr pipe operator) 22 | #' @export 23 | NULL 24 | -------------------------------------------------------------------------------- /R/mapedit.R: -------------------------------------------------------------------------------- 1 | #' mapedit: interactive editing and selection for geospatial data 2 | #' 3 | #' mapedit, a RConsortium funded project, provides interactive 4 | #' tools to incorporate in geospatial workflows that require editing or selection 5 | #' of spatial data. 6 | #' 7 | #' @section Edit: 8 | #' \itemize{ 9 | #' \item{\code{\link{editMap}}} 10 | #' \item{\code{\link{editFeatures}}} 11 | #' \item{Shiny edit module \code{\link{editModUI}}, \code{\link{editMod}}} 12 | #' } 13 | #' 14 | #' #' @section Edit: 15 | #' \itemize{ 16 | #' \item{\code{\link{selectMap}}} 17 | #' \item{\code{\link{selectFeatures}}} 18 | #' \item{Shiny edit module \code{\link{selectModUI}}, \code{\link{selectMod}}} 19 | #' } 20 | "_PACKAGE" 21 | -------------------------------------------------------------------------------- /R/mapview_extent.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | createExtent <- function(x, offset = NULL) { 3 | 4 | if (inherits(x, "Extent")) { 5 | return(x) 6 | } else { 7 | if (inherits(x, "Raster")) { 8 | ext <- raster::extent( 9 | raster::projectExtent(x, crs = sp::CRS("+init=epsg:4326"))) 10 | } else if (inherits(x, "Spatial")) { 11 | ext <- raster::extent(raster::xmin(x), 12 | raster::xmax(x), 13 | raster::ymin(x), 14 | raster::ymax(x)) 15 | } else if (inherits(x, "sfc") | inherits(x, "sf") | 16 | inherits(x, "XY") | inherits(x, "stars")) { 17 | bb <- sf::st_bbox(x) 18 | ext <- raster::extent(bb[1], bb[3], bb[2], bb[4]) 19 | } 20 | 21 | if (is.null(offset)) { 22 | xxtend <- c(ext[1], ext[2]) 23 | yxtend <- c(ext[3], ext[4]) 24 | ext@xmin <- xxtend[1] 25 | ext@xmax <- xxtend[2] 26 | ext@ymin <- yxtend[1] 27 | ext@ymax <- yxtend[2] 28 | } else { 29 | ext@xmin <- ext@xmin - offset 30 | ext@xmax <- ext@xmax + offset 31 | ext@ymin <- ext@ymin - offset 32 | ext@ymax <- ext@ymax + offset 33 | } 34 | 35 | return(ext) 36 | } 37 | 38 | } 39 | -------------------------------------------------------------------------------- /R/mapview_init.R: -------------------------------------------------------------------------------- 1 | ### these are all copies of unexported functions in mapview 2 | 3 | # Initialise mapView map -------------------------------------------------- 4 | 5 | initMap <- function(map = NULL, 6 | map.types = NULL, 7 | proj4str, 8 | native.crs = FALSE, 9 | canvas = FALSE, 10 | viewer.suppress = FALSE, 11 | platform = mapview::mapviewGetOption("platform"), 12 | ...) { 13 | 14 | # if (missing(map.types)) map.types <- mapview::mapviewGetOption("basemaps") 15 | ls = list(...) 16 | nms = names(ls) 17 | 18 | if (platform %in% c("leaflet", "leafgl")) { 19 | 20 | if (is.null(map) & is.null(map.types)) { 21 | map.types <- mapview::mapviewGetOption("basemaps") 22 | } 23 | 24 | leafletHeight <- mapview::mapviewGetOption("leafletHeight") 25 | leafletWidth <- mapview::mapviewGetOption("leafletWidth") 26 | 27 | if (missing(proj4str)) proj4str <- NA 28 | ## create base map using specified map types 29 | if (is.null(map)) { 30 | if (is.na(proj4str) | native.crs) { 31 | m <- leaflet::leaflet( 32 | height = leafletHeight, 33 | width = leafletWidth, 34 | options = leaflet::leafletOptions( 35 | minZoom = -1000, 36 | crs = leaflet::leafletCRS(crsClass = "L.CRS.Simple"), 37 | preferCanvas = canvas), 38 | sizingPolicy = leaflet::leafletSizingPolicy( 39 | viewer.suppress = viewer.suppress, 40 | browser.external = viewer.suppress 41 | ) 42 | ) 43 | } else { 44 | m <- initBaseMaps( 45 | map.types 46 | , canvas = canvas 47 | , viewer.suppress = viewer.suppress 48 | ) 49 | } 50 | } else { 51 | m <- map 52 | } 53 | 54 | } 55 | 56 | return(m) 57 | } 58 | 59 | 60 | initBaseMaps <- function(map.types, canvas = FALSE, viewer.suppress = FALSE) { 61 | ## create base map using specified map types 62 | if (missing(map.types)) map.types <- mapview::mapviewGetOption("basemaps") 63 | leafletHeight <- mapview::mapviewGetOption("leafletHeight") 64 | leafletWidth <- mapview::mapviewGetOption("leafletWidth") 65 | lid <- 1:length(map.types) 66 | m <- leaflet::leaflet( 67 | height = leafletHeight, 68 | width = leafletWidth, 69 | options = leaflet::leafletOptions( 70 | minZoom = 1, 71 | maxZoom = 52, 72 | bounceAtZoomLimits = FALSE, 73 | maxBounds = list( 74 | list(c(-90, -370)), 75 | list(c(90, 370))), 76 | preferCanvas = canvas), 77 | sizingPolicy = leaflet::leafletSizingPolicy( 78 | viewer.suppress = viewer.suppress, 79 | browser.external = viewer.suppress 80 | ) 81 | ) 82 | if (!(is.null(map.types))) { 83 | m <- leaflet::addProviderTiles(m, provider = map.types[1], 84 | layerId = map.types[1], group = map.types[1], 85 | options = leaflet::providerTileOptions( 86 | pane = "tilePane" 87 | )) 88 | if (length(map.types) > 1) { 89 | for (i in 2:length(map.types)) { 90 | m <- leaflet::addProviderTiles(m, provider = map.types[i], 91 | layerId = map.types[i], group = map.types[i], 92 | options = leaflet::providerTileOptions( 93 | pane = "tilePane" 94 | )) 95 | m = removeDuplicatedMapDependencies(m) 96 | } 97 | } 98 | } 99 | return(m) 100 | } 101 | 102 | removeDuplicatedMapDependencies <- function(map) { 103 | ind <- duplicated(map$dependencies) 104 | if (any(ind)) map$dependencies[ind] <- NULL 105 | return(map) 106 | } 107 | -------------------------------------------------------------------------------- /R/mapview_projection.R: -------------------------------------------------------------------------------- 1 | ### these are all copies of unexported functions in mapview 2 | 3 | # Scale coordinates for unprojected spatial objects ----------------------- 4 | 5 | scaleCoordinates <- function(x.coords, y.coords) { 6 | 7 | if (length(x.coords) == 1) { 8 | x_sc <- y_sc <- 0 9 | } else { 10 | ratio <- diff(range(y.coords)) / diff(range(x.coords)) 11 | x_sc <- scales::rescale(x.coords, to = c(0, 1)) 12 | y_sc <- scales::rescale(y.coords, to = c(0, 1)) * ratio 13 | } 14 | return(cbind(x_sc, y_sc)) 15 | 16 | } 17 | 18 | 19 | 20 | # Scale extent ------------------------------------------------------------ 21 | 22 | scaleExtent <- function(x) { 23 | ratio <- raster::nrow(x) / raster::ncol(x) 24 | x_sc <- scales::rescale(c(x@extent@xmin, x@extent@xmax), c(0, 1)) 25 | y_sc <- scales::rescale(c(x@extent@ymin, x@extent@ymax), c(0, 1)) * ratio 26 | 27 | return(raster::extent(c(x_sc, y_sc))) 28 | } 29 | 30 | 31 | # Scale unprojected SpatialPolygons* objects ------------------------------ 32 | 33 | scalePolygonsCoordinates <- function(x) { 34 | 35 | coord_lst <- lapply(methods::slot(x, "polygons"), function(x) { 36 | lapply(methods::slot(x, "Polygons"), function(y) methods::slot(y, "coords")) 37 | }) 38 | 39 | xcoords <- do.call("c", do.call("c", lapply(seq(coord_lst), function(i) { 40 | lapply(seq(coord_lst[[i]]), function(j) { 41 | coord_lst[[i]][[j]][, 1] 42 | }) 43 | }))) 44 | 45 | ycoords <- do.call("c", do.call("c", lapply(seq(coord_lst), function(i) { 46 | lapply(seq(coord_lst[[i]]), function(j) { 47 | coord_lst[[i]][[j]][, 2] 48 | }) 49 | }))) 50 | 51 | ratio <- diff(range(ycoords)) / diff(range(xcoords)) 52 | 53 | x_mn <- min(xcoords, na.rm = TRUE) 54 | x_mx <- max(xcoords - min(xcoords, na.rm = TRUE), na.rm = TRUE) 55 | 56 | y_mn <- min(ycoords, na.rm = TRUE) 57 | y_mx <- max(ycoords - min(ycoords, na.rm = TRUE), na.rm = TRUE) 58 | 59 | #do.call("rbind", 60 | pols <- lapply(seq(coord_lst), function(j) { 61 | 62 | ## extract current 'Polygons' 63 | pys <- x@polygons[[j]] 64 | 65 | lst <- lapply(seq(pys@Polygons), function(h) { 66 | 67 | # extract current 'Polygon' 68 | py <- pys@Polygons[[h]] 69 | 70 | # rescale coordinates 71 | crd <- sp::coordinates(py) 72 | coords_rscl <- cbind((crd[, 1] - x_mn) / x_mx, 73 | (crd[, 2] - y_mn) / y_mx * ratio) 74 | 75 | # assign new coordinates and label point 76 | methods::slot(py, "coords") <- coords_rscl 77 | methods::slot(py, "labpt") <- range(coords_rscl) 78 | 79 | return(py) 80 | }) 81 | 82 | sp::Polygons(lst, ID = pys@ID) 83 | # sp::SpatialPolygons(list(sp::Polygons(lst, ID = pys@ID)), 84 | # proj4string = sp::CRS(sp::proj4string(x))) 85 | })#) 86 | 87 | x@polygons <- pols 88 | 89 | x_rng <- range(sapply(pols, function(i) sp::bbox(i)[1, ])) 90 | y_rng <- range(sapply(pols, function(i) sp::bbox(i)[2, ])) 91 | x@bbox <- matrix(c(x_rng[1], x_rng[2], y_rng[1], y_rng[2]), 92 | ncol = 2, byrow = TRUE) 93 | return(x) 94 | } 95 | 96 | 97 | # Scale unprojected SpatialLines* objects ------------------------------ 98 | 99 | scaleLinesCoordinates <- function(x) { 100 | 101 | coord_lst <- lapply(methods::slot(x, "lines"), function(x) { 102 | lapply(methods::slot(x, "Lines"), function(y) methods::slot(y, "coords")) 103 | }) 104 | 105 | xcoords <- do.call("c", do.call("c", lapply(seq(coord_lst), function(i) { 106 | lapply(seq(coord_lst[[i]]), function(j) { 107 | coord_lst[[i]][[j]][, 1] 108 | }) 109 | }))) 110 | 111 | ycoords <- do.call("c", do.call("c", lapply(seq(coord_lst), function(i) { 112 | lapply(seq(coord_lst[[i]]), function(j) { 113 | coord_lst[[i]][[j]][, 2] 114 | }) 115 | }))) 116 | 117 | ratio <- diff(range(ycoords)) / diff(range(xcoords)) 118 | 119 | x_mn <- min(xcoords, na.rm = TRUE) 120 | x_mx <- max(xcoords - min(xcoords, na.rm = TRUE), na.rm = TRUE) 121 | 122 | y_mn <- min(ycoords, na.rm = TRUE) 123 | y_mx <- max(ycoords - min(ycoords, na.rm = TRUE), na.rm = TRUE) 124 | 125 | #do.call("rbind", 126 | lins <- lapply(seq(coord_lst), function(j) { 127 | 128 | ## extract current 'Lines' 129 | lns <- x@lines[[j]] 130 | 131 | lst <- lapply(seq(lns@Lines), function(h) { 132 | 133 | # extract current 'Line' 134 | ln <- lns@Lines[[h]] 135 | 136 | # rescale coordinates 137 | crd <- sp::coordinates(ln) 138 | coords_rscl <- cbind((crd[, 1] - x_mn) / x_mx, 139 | (crd[, 2] - y_mn) / y_mx * ratio) 140 | 141 | # assign new coordinates and label point 142 | methods::slot(ln, "coords") <- coords_rscl 143 | 144 | return(ln) 145 | }) 146 | 147 | sp::Lines(lst, ID = lns@ID) 148 | 149 | # sp::SpatialLines(list(sp::Lines(lst, ID = lns@ID)), 150 | # proj4string = sp::CRS(sp::proj4string(x))) 151 | })#) 152 | 153 | x@lines <- lins 154 | 155 | x_rng <- range(sapply(lins, function(i) sp::bbox(i)[1, ])) 156 | y_rng <- range(sapply(lins, function(i) sp::bbox(i)[2, ])) 157 | x@bbox <- matrix(c(x_rng[1], x_rng[2], y_rng[1], y_rng[2]), 158 | ncol = 2, byrow = TRUE) 159 | return(x) 160 | } 161 | 162 | 163 | ## the two crs we use 164 | wmcrs <- "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext +no_defs" 165 | llcrs <- "+proj=longlat +datum=WGS84 +no_defs" 166 | 167 | non_proj_warning <- 168 | "supplied layer has no projection information and is shown without background map" 169 | 170 | wrong_proj_warning <- 171 | paste0("projection of supplied layer is not leaflet conform.", "\n", 172 | " projecting to '", llcrs, "'") 173 | 174 | # Check and potentially adjust projection of objects to be rendered ======= 175 | #' @keywords internal 176 | checkAdjustProjection <- function(x, method = "bilinear") { 177 | 178 | x <- switch(class(x)[1], 179 | "RasterLayer" = rasterCheckAdjustProjection(x, method), 180 | "RasterStack" = rasterCheckAdjustProjection(x, method), 181 | "RasterBrick" = rasterCheckAdjustProjection(x, method), 182 | "SpatialPointsDataFrame" = spCheckAdjustProjection(x), 183 | "SpatialPolygonsDataFrame" = spCheckAdjustProjection(x), 184 | "SpatialLinesDataFrame" = spCheckAdjustProjection(x), 185 | "SpatialPoints" = spCheckAdjustProjection(x), 186 | "SpatialPolygons" = spCheckAdjustProjection(x), 187 | "SpatialLines" = spCheckAdjustProjection(x), 188 | "sf" = sfCheckAdjustProjection(x), 189 | "XY" = sfCheckAdjustProjection(x), 190 | "sfc_POINT" = sfCheckAdjustProjection(x), 191 | "sfc_MULTIPOINT" = sfCheckAdjustProjection(x), 192 | "sfc_LINESTRING" = sfCheckAdjustProjection(x), 193 | "sfc_MULTILINESTRING" = sfCheckAdjustProjection(x), 194 | "sfc_POLYGON" = sfCheckAdjustProjection(x), 195 | "sfc_MULTIPOLYGON" = sfCheckAdjustProjection(x), 196 | "sfc_GEOMETRY" = sfCheckAdjustProjection(x), 197 | "sfc_GEOMETRYCOLLECTION" = sfCheckAdjustProjection(x)) 198 | 199 | return(x) 200 | 201 | } 202 | # 203 | # if (class(x)[1] %in% c("RasterLayer", "RasterStack", "RasterBrick")) { 204 | # x <- rasterCheckAdjustProjection(x) 205 | # } else if (class(x)[1] %in% c("SpatialPointsDataFrame", 206 | # "SpatialPolygonsDataFrame", 207 | # "SpatialLinesDataFrame", 208 | # "SpatialPoints", 209 | # "SpatialPolygons", 210 | # "SpatialLines")) { 211 | # x <- spCheckAdjustProjection(x) 212 | # } 213 | # 214 | # return(x) 215 | # } 216 | 217 | 218 | # Project Raster* objects for mapView ===================================== 219 | #' @keywords internal 220 | rasterCheckAdjustProjection <- function(x, method) { 221 | 222 | is.fact <- raster::is.factor(x)[1] 223 | 224 | if (is.na(raster::projection(x))) { 225 | warning(non_proj_warning) 226 | raster::extent(x) <- scaleExtent(x) 227 | raster::projection(x) <- llcrs 228 | } else if (is.fact) { 229 | x <- raster::projectRaster( 230 | x, raster::projectExtent(x, crs = sp::CRS(wmcrs)), 231 | method = "ngb") 232 | x <- raster::as.factor(x) 233 | } else { 234 | x <- raster::projectRaster( 235 | x, raster::projectExtent(x, crs = sp::CRS(wmcrs)), 236 | method = method) 237 | } 238 | 239 | return(x) 240 | 241 | } 242 | 243 | 244 | # Project stars* objects for mapView ===================================== 245 | #' @keywords internal 246 | starsCheckAdjustProjection <- function(x, method) { 247 | 248 | # is.fact <- raster::is.factor(x)[1] 249 | 250 | # if (is.na(raster::projection(x))) { 251 | # warning(non_proj_warning) 252 | # raster::extent(x) <- scaleExtent(x) 253 | # raster::projection(x) <- llcrs 254 | # } else if (is.fact) { 255 | # x <- raster::projectRaster( 256 | # x, raster::projectExtent(x, crs = sp::CRS(wmcrs)), 257 | # method = "ngb") 258 | # x <- raster::as.factor(x) 259 | # } else { 260 | x <- sf::st_transform( 261 | x, 262 | crs = llcrs 263 | ) 264 | # } 265 | 266 | return(x) 267 | 268 | } 269 | 270 | 271 | # Check and potentially adjust projection of sf objects =================== 272 | #' @keywords internal 273 | sfCheckAdjustProjection <- function(x) { 274 | 275 | if (is.na(sf::st_crs(x))) { 276 | return(x) # warning(non_proj_warning) 277 | } else { #if (!validLongLat(sf::st_crs(x)$proj4string)) { 278 | x <- sf::st_transform(x, llcrs) 279 | } 280 | 281 | return(x) 282 | 283 | } 284 | 285 | 286 | # Check and potentially adjust projection of Spatial* objects ============= 287 | #' @keywords internal 288 | spCheckAdjustProjection <- function(x) { 289 | 290 | if (is.na(raster::projection(x))) { 291 | warning(non_proj_warning) 292 | if (class(x)[1] %in% c("SpatialPointsDataFrame", "SpatialPoints")) { 293 | methods::slot(x, "coords") <- scaleCoordinates(sp::coordinates(x)[, 1], 294 | sp::coordinates(x)[, 2]) 295 | } else if (class(x)[1] %in% c("SpatialPolygonsDataFrame", 296 | "SpatialPolygons")) { 297 | x <- scalePolygonsCoordinates(x) 298 | } else if (class(x)[1] %in% c("SpatialLinesDataFrame", 299 | "SpatialLines")) { 300 | x <- scaleLinesCoordinates(x) 301 | } 302 | 303 | raster::projection(x) <- llcrs 304 | 305 | } else if (!identical(raster::projection(x), llcrs)) { 306 | x <- sp::spTransform(x, CRSobj = llcrs) 307 | } 308 | 309 | return(x) 310 | 311 | } 312 | 313 | # Check projection of objects according to their keywords ================= 314 | # validLongLat <- function (p4s) { 315 | # proj <- datum <- nodefs <- FALSE 316 | # allWGS84 <- c("+init=epsg:4326", "+proj=longlat", "+datum=WGS84", 317 | # "+no_defs", "+ellps=WGS84", "+towgs84=0,0,0") 318 | # 319 | # p4s_splt = strsplit(p4s, " ")[[1]] 320 | # 321 | # for (comp in allWGS84) { 322 | # if (comp %in% p4s_splt) { 323 | # if (comp == "+init=epsg:4326") { 324 | # proj <- datum <- nodefs <- TRUE 325 | # } 326 | # if (comp == "+proj=longlat") { 327 | # proj <- TRUE 328 | # } 329 | # if (comp == "+no_defs") { 330 | # nodefs <- TRUE 331 | # } 332 | # if (comp == "+datum=WGS84") { 333 | # datum <- TRUE 334 | # } 335 | # } 336 | # } 337 | # if (proj & datum & nodefs) { 338 | # return(TRUE) 339 | # } else { 340 | # warning(wrong_proj_warning) 341 | # return(FALSE) 342 | # } 343 | # } 344 | 345 | -------------------------------------------------------------------------------- /R/merge.R: -------------------------------------------------------------------------------- 1 | #' Merge 'sf' Edits 2 | #' 3 | #' Internal function used with \code{editFeatures} to apply edits 4 | #' to a \code{sf} object. 5 | #' 6 | #' @param orig \code{sf} with the original or source data to which 7 | #' deletes should apply 8 | #' @param edits \code{sf} with sf data to edit 9 | #' @param by named \code{vector} with the name of the vector representing 10 | #' the column in orig that we will use to match and the value of 11 | #' the vector representing the column in edits that we will 12 | #' use to match. The argument is intended to work like 13 | #' the \code{*join} functions in \code{dplyr}. Note, this function 14 | #' will only use the first name 15 | #' and first value of the vector for matching. 16 | #' @keywords internal 17 | 18 | merge_edit <- function( 19 | orig = NULL, edits = NULL, by = c("id" = "layerId") 20 | ) { 21 | 22 | # if edits is empty return orig sf 23 | if(is.null(edits)) { 24 | return(orig) 25 | } 26 | # if orig is empty then just return drawn sf 27 | if(is.null(orig)) { 28 | return(edits) 29 | } 30 | 31 | # make a copy 32 | orig2 <- orig 33 | 34 | orig_ids = orig2[[names(by)[1]]] 35 | 36 | edit_ids = edits[, by[[1]], drop=TRUE] 37 | 38 | mapply( 39 | function(ed, ed_id) { 40 | matched_id_row = which(orig_ids == ed_id) 41 | 42 | # get type of original 43 | orig_type <- as.character(sf::st_geometry_type( 44 | sf::st_geometry(orig[matched_id_row,]) 45 | )) 46 | 47 | tryCatch( 48 | sf::st_geometry(orig2)[matched_id_row] <<- sf::st_geometry(sf::st_cast( 49 | sf::st_sfc(ed), 50 | orig_type 51 | )), 52 | error = function(e) { 53 | sf::st_geometry(orig2)[matched_id_row] <<- ed 54 | warning( 55 | paste0("Unable to cast back to original type - ", e$message, " - but this is often caused by intermediate step."), 56 | call. = FALSE 57 | ) 58 | } 59 | ) 60 | return(NULL) 61 | }, 62 | sf::st_geometry(edits), 63 | edit_ids 64 | ) 65 | 66 | #matched_id_rows = which(orig_ids %in% edit_ids) 67 | 68 | # cast edits to original type 69 | #sf::st_geometry(edits) <- sf::st_sfc(mapply( 70 | # function(ed, type) { 71 | # sf::st_cast(ed, type) 72 | # }, 73 | # sf::st_geometry(edits), 74 | # as.character( 75 | # sf::st_geometry_type( 76 | # sf::st_geometry(orig2) 77 | # )[matched_id_rows] 78 | # ), 79 | # SIMPLIFY = FALSE 80 | #)) 81 | 82 | #sf::st_geometry(orig2)[matched_id_rows] <- sf::st_geometry(edits) 83 | 84 | orig2 85 | } 86 | 87 | 88 | #' Merge 'sf' Deletes 89 | #' 90 | #' Internal function used with \code{editFeatures} to apply deletes 91 | #' to a \code{sf} object. 92 | #' 93 | #' @param orig \code{sf} with the original or source data to which 94 | #' deletes should apply 95 | #' @param deletes \code{sf} with sf data to delete 96 | #' @param by named \code{vector} with the name of the vector representing 97 | #' the column in orig that we will use to match and the value of 98 | #' the vector representing the column in deletes that we will 99 | #' use to match. The argument is intended to work like 100 | #' the \code{*join} functions in \code{dplyr}. Note, this function 101 | #' will only use the first name 102 | #' and first value of the vector for matching. 103 | #' @keywords internal 104 | 105 | merge_delete <- function( 106 | orig = NULL, deletes = NULL, by = c("id" = "layerId") 107 | ) { 108 | 109 | if(is.null(deletes)) { 110 | return(orig) 111 | } 112 | 113 | orig_ids = orig[,names(by)[1], drop = TRUE] 114 | del_ids = deletes[,by[[1]], drop=TRUE] 115 | 116 | orig[which(!(orig_ids %in% del_ids)),] 117 | } 118 | 119 | 120 | #' Merge 'sf' Adds 121 | #' 122 | #' Internal function used with \code{editFeatures} to apply adds or drawn 123 | #' to a \code{sf} object. 124 | #' 125 | #' @param orig \code{sf} with the original or source data to which 126 | #' adds should apply 127 | #' @param drawn \code{sf} with sf data to add to orig 128 | #' @param by not used in merge_add. This argument only exists 129 | #' for symmetry with the other merge functions. 130 | #' 131 | #' @keywords internal 132 | merge_add <- function(orig = NULL, drawn = NULL, by = NULL) { 133 | 134 | # if drawn is empty return orig sf 135 | if(is.null(drawn)) { 136 | return(orig) 137 | } 138 | 139 | # if orig is empty then just return drawn sf 140 | if(is.null(orig)) { 141 | return(drawn) 142 | } 143 | 144 | # use mapedit internal function to combine orig and drawn 145 | combine_list_of_sf( 146 | list(orig, drawn) 147 | ) 148 | } 149 | 150 | -------------------------------------------------------------------------------- /R/modules.R: -------------------------------------------------------------------------------- 1 | 2 | #' Shiny Module UI for Geo Selection 3 | #' 4 | #' @param id \code{character} id for the the Shiny namespace 5 | #' @param ... other arguments to \code{leafletOutput()} 6 | #' 7 | #' @return ui for Shiny module 8 | #' @export 9 | selectModUI <- function(id, ...) { 10 | ns <- shiny::NS(id) 11 | leaflet::leafletOutput(ns("map"), ...) 12 | } 13 | 14 | 15 | #' Shiny Module Server for Geo Selection 16 | #' 17 | #' @param input Shiny server function input 18 | #' @param output Shiny server function output 19 | #' @param session Shiny server function session 20 | #' @param leafmap leaflet map to use for Selection 21 | #' @param styleFalse named \code{list} of valid \code{CSS} for non-selected features 22 | #' @param styleTrue named \code{list} of valid \code{CSS} for selected features 23 | #' 24 | #' @return server function for Shiny module 25 | #' @export 26 | selectMod <- function( 27 | input, output, session, 28 | leafmap, 29 | styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4), 30 | styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7) 31 | ) { 32 | 33 | output$map <- leaflet::renderLeaflet({ 34 | add_select_script( 35 | leafmap, 36 | styleFalse = styleFalse, 37 | styleTrue = styleTrue, 38 | ns = session$ns(NULL) 39 | ) 40 | }) 41 | 42 | id = "mapedit" 43 | select_evt = paste0(id, "_selected") 44 | 45 | df <- data.frame() 46 | 47 | # a container for our selections 48 | selections <- shiny::reactive({ 49 | # when used in modules, we get an event with blank id 50 | # on initialize so also make sure we have an id 51 | id = as.character(input[[select_evt]]$id) 52 | if(nrow(df) == 0 && !is.null(id)) { 53 | df <<- data.frame( 54 | id = id, 55 | selected = input[[select_evt]]$selected, 56 | stringsAsFactors = FALSE 57 | ) 58 | } else { 59 | # see if already exists 60 | loc <- which(df$id == id) 61 | 62 | if(length(loc) > 0) { 63 | df[loc, "selected"] <<- input[[select_evt]]$selected 64 | } else { 65 | df[nrow(df) + 1, ] <<- c(id, input[[select_evt]]$selected) 66 | } 67 | } 68 | 69 | return(df) 70 | }) 71 | 72 | return(selections) 73 | 74 | } 75 | 76 | 77 | #' Shiny Module UI for Geo Create, Edit, Delete 78 | #' 79 | #' @param id \code{character} id for the the Shiny namespace 80 | #' @param ... other arguments to \code{leafletOutput()} 81 | #' 82 | #' @return ui for Shiny module 83 | #' @export 84 | editModUI <- function(id, ...) { 85 | ns <- shiny::NS(id) 86 | leaflet::leafletOutput(ns("map"), ...) 87 | } 88 | 89 | #' Shiny Module Server for Geo Create, Edit, Delete 90 | #' 91 | #' @param input Shiny server function input 92 | #' @param output Shiny server function output 93 | #' @param session Shiny server function session 94 | #' @param leafmap leaflet map to use for Selection 95 | #' @param targetLayerId \code{character} identifier of layer to edit, delete 96 | #' @param sf \code{logical} to return simple features. \code{sf=FALSE} will return 97 | #' \code{GeoJSON}. 98 | #' @param record \code{logical} to record all edits for future playback. 99 | #' @param crs see \code{\link[sf]{st_crs}}. 100 | #' @param editor \code{character} either "leaflet.extras" or "leafpm" 101 | #' @param editorOptions \code{list} of options suitable for passing to 102 | #' either \code{leaflet.extras::addDrawToolbar} or 103 | #' \code{leafpm::addPmToolbar}. 104 | #' 105 | #' @return server function for Shiny module 106 | #' @export 107 | editMod <- function( 108 | input, output, session, 109 | leafmap, 110 | targetLayerId = NULL, 111 | sf = TRUE, 112 | record = FALSE, 113 | crs = 4326, 114 | editor = c("leaflet.extras", "leafpm"), 115 | editorOptions = list() 116 | ) { 117 | editor <- match.arg(editor) 118 | # check to see if addDrawToolbar has been already added to the map 119 | if(!any(sapply(leafmap$x$calls, "[[", "method") %in% 120 | c("addDrawToolbar", "addPmToolbar"))) { 121 | leafmap <- addToolbar(leafmap, editorOptions, editor, targetLayerId) 122 | } 123 | 124 | output$map <- leaflet::renderLeaflet({leafmap}) 125 | 126 | featurelist <- shiny::reactiveValues( 127 | drawn = list(), 128 | edited_all = list(), 129 | deleted_all = list(), 130 | finished = list(), 131 | all = list() 132 | ) 133 | 134 | recorder <- list() 135 | 136 | EVT_DRAW <- "map_draw_new_feature" 137 | EVT_EDIT <- "map_draw_edited_features" 138 | EVT_DELETE <- "map_draw_deleted_features" 139 | EVT_ALL <- "map_draw_all_features" 140 | 141 | shiny::observeEvent(input[[EVT_DRAW]], { 142 | featurelist$drawn <- c(featurelist$drawn, list(input[[EVT_DRAW]])) 143 | if (any(unlist(input[[EVT_DRAW]]$geometry$coordinates) < -180) || 144 | any(unlist(input[[EVT_DRAW]]$geometry$coordinates) > 180)) 145 | insane_longitude_warning() 146 | featurelist$finished <- c(featurelist$finished, list(input[[EVT_DRAW]])) 147 | }) 148 | 149 | shiny::observeEvent(input[[EVT_EDIT]], { 150 | edited <- input[[EVT_EDIT]] 151 | # find the edited features and update drawn 152 | # start by getting the leaflet ids to do the match 153 | ids <- unlist(lapply(featurelist$finished, function(x){x$properties$`_leaflet_id`})) 154 | # now modify drawn to match edited 155 | lapply(edited$features, function(x) { 156 | loc <- match(x$properties$`_leaflet_id`, ids) 157 | if(length(loc) > 0) { 158 | featurelist$finished[loc] <<- list(x) 159 | } 160 | }) 161 | 162 | featurelist$edited_all <- c(featurelist$edited_all, list(edited)) 163 | }) 164 | 165 | shiny::observeEvent(input[[EVT_DELETE]], { 166 | deleted <- input[[EVT_DELETE]] 167 | 168 | # find the deleted features and update finished 169 | # start by getting the leaflet ids to do the match 170 | ids <- unlist(lapply(featurelist$finished, function(x){x$properties$`_leaflet_id`})) 171 | 172 | # leaflet.pm returns only a single feature while leaflet.extras returns feature collection 173 | # convert leaflet.pm so logic will be the same 174 | if(editor == "leafpm") { 175 | deleted <- list( 176 | type = "FeatureCollection", 177 | features = list(deleted) 178 | ) 179 | } 180 | 181 | # now modify finished to match edited 182 | lapply(deleted$features, function(x) { 183 | loc <- match(x$properties$`_leaflet_id`, ids) 184 | if(!is.null(loc) && length(loc) > 0) { 185 | ids <<- ids[-loc] 186 | featurelist$finished[loc] <<- NULL 187 | } 188 | }) 189 | 190 | featurelist$deleted_all <- c(featurelist$deleted_all, list(deleted)) 191 | }) 192 | 193 | shiny::observeEvent(input[[EVT_ALL]], { 194 | featurelist$all <- list(input[[EVT_ALL]]) 195 | if (any(unlist(input[[EVT_ALL]]$geometry$coordinates) < -180) || 196 | any(unlist(input[[EVT_ALL]]$geometry$coordinates) > 180)) 197 | insane_longitude_warning() 198 | }) 199 | 200 | # record events if record = TRUE 201 | if(record == TRUE) { 202 | lapply( 203 | c(EVT_DRAW, EVT_EDIT, EVT_DELETE, EVT_ALL), 204 | function(evt) { 205 | shiny::observeEvent(input[[evt]], { 206 | recorder <<- c( 207 | recorder, 208 | list( 209 | list( 210 | event = evt, 211 | timestamp = Sys.time(), 212 | feature = input[[evt]] 213 | ) 214 | ) 215 | ) 216 | }) 217 | } 218 | ) 219 | } 220 | 221 | 222 | # collect all of the the features into a list 223 | # by action 224 | returnlist <- shiny::reactive({ 225 | workinglist <- list( 226 | drawn = featurelist$drawn, 227 | edited = featurelist$edited_all, 228 | deleted = featurelist$deleted_all, 229 | finished = featurelist$finished, 230 | all = featurelist$all 231 | ) 232 | # if sf argument is TRUE then convert to simple features 233 | if(sf) { 234 | workinglist <- lapply( 235 | workinglist, 236 | function(action) { 237 | # ignore empty action types to prevent error 238 | # handle in the helper functions? 239 | if(length(action) == 0) { return() } 240 | 241 | # FeatureCollection requires special treatment 242 | # and we need to extract features 243 | features <- Reduce( 244 | function(left,right) { 245 | if(right$type == "FeatureCollection") { 246 | right <- lapply(right$features, identity) 247 | } else { 248 | right <- list(right) 249 | } 250 | c(left,right) 251 | }, 252 | action, 253 | init = NULL 254 | ) 255 | 256 | combine_list_of_sf( 257 | lapply(features, st_as_sf.geo_list, crs = crs) 258 | ) 259 | } 260 | ) 261 | 262 | recorder <- lapply( 263 | recorder, 264 | function(evt) { 265 | feature = st_as_sfc.geo_list(evt$feature, crs = crs) 266 | list(evt = evt$event, timestamp = evt$timestamp, feature = feature) 267 | } 268 | ) 269 | } 270 | # return merged features 271 | if(record==TRUE) { 272 | attr(workinglist, "recorder") <- recorder 273 | } 274 | return(workinglist) 275 | }) 276 | 277 | return(returnlist) 278 | } 279 | -------------------------------------------------------------------------------- /R/playback.R: -------------------------------------------------------------------------------- 1 | #' Playback a Recorded 'mapedit' Session on Leaflet Map 2 | #' 3 | #' @param x a recorded mapedit session from \code{editFeatures(..., record=TRUE)} 4 | #' @keywords internal 5 | 6 | playback <- function(x, origsf = NULL) { 7 | if(is.null(x)) { 8 | stop("x is NULL. Please provide x for playback.", call. = FALSE) 9 | } 10 | 11 | if(!requireNamespace("geojsonio")) { 12 | stop("Playback requires geojsonio. Please install.packages('geojsonio') and try again.", .call = FALSE) 13 | } 14 | 15 | view_orig <- getOption("viewer") 16 | on.exit(options(viewer=view_orig)) 17 | options(viewer = NULL) 18 | 19 | rec <- attr(x, "recorder", exact=TRUE) 20 | if(is.null(rec)) { 21 | stop("Did not find recorder. Please use record=TRUE with edit functions.", call. = FALSE) 22 | } 23 | # check for original in recorder 24 | # and use that if origsf not provided 25 | if(is.null(origsf)) { 26 | origsf <- attr(x, "original", exact=TRUE) 27 | } 28 | 29 | if(!is.null(origsf)) { 30 | map = mapview::mapview( 31 | origsf, 32 | alpha.regions=0.4, 33 | dashArray="5,5" 34 | )@map 35 | } else { 36 | map = mapview::mapview()@map 37 | } 38 | 39 | map$height = "100%" 40 | 41 | sf_all <- sf::st_geometry(combine_list_of_sf( 42 | lapply(rec,function(x){x$feature}) 43 | )) 44 | 45 | x = checkAdjustProjection(sf_all) 46 | 47 | if(!is.null(origsf)) { 48 | sf_all = c( 49 | sf::st_geometry(sf_all), 50 | sf::st_geometry(origsf) 51 | ) 52 | } 53 | 54 | ext = createExtent(sf_all) 55 | map = leaflet::fitBounds( 56 | map, 57 | lng1 = ext[1], 58 | lat1 = ext[3], 59 | lng2 = ext[2], 60 | lat2 = ext[4] 61 | ) 62 | 63 | orig_gj <- NULL 64 | if(!is.null(origsf)) { 65 | origsf = checkAdjustProjection(origsf) 66 | origsf$edit_id = as.character(1:nrow(origsf)) 67 | orig_gj = geojsonio::geojson_list(origsf) 68 | } 69 | 70 | scr <- sprintf( 71 | " 72 | function(el, x) { 73 | var map = this; 74 | var feat = %s; 75 | var feat_lookup = {}; 76 | var orig = %s; 77 | 78 | function get_id(feature) { 79 | if(feature.properties.edit_id) { 80 | return 'edit' + feature.properties.edit_id; 81 | } 82 | 83 | if(feature.properties.layerId) { 84 | return 'edit' + feature.properties.layerId 85 | } 86 | 87 | if(feature.properties.X_leaflet_id) { 88 | return 'leaf' + feature.properties.X_leaflet_id; 89 | } 90 | } 91 | 92 | function feat_overlay(feature, delay, trans) { 93 | return L.d3SvgOverlay(function(sel, proj) { 94 | var upd = sel.selectAll('path').data(feature.features); 95 | upd_new = upd.enter() 96 | .append('path') 97 | .attr('d', proj.pathFromGeojson) 98 | .style('fill', 'none') 99 | .style('stroke', 'black') 100 | .style('opacity', 0.0001) 101 | upd_new 102 | .transition(trans) 103 | .delay(delay) 104 | .style('opacity', 1) 105 | upd = upd.merge(upd_new) 106 | upd.attr('stroke-width', 1 / proj.scale); 107 | 108 | upd.each(function(f) { 109 | feat_lookup[get_id(f)] = { 110 | pathd: proj.pathFromGeojson(f), 111 | pathsvg: d3.select(this).node(), 112 | pathfun: proj.pathFromGeojson 113 | } 114 | }); 115 | }); 116 | } 117 | 118 | function draw(ed, delay) { 119 | feat_overlay(ed.feature, delay, 2000).addTo(map); 120 | }; 121 | 122 | function edit_polygon(f, path_f, ed, delay) { 123 | var interpolator = flubber.interpolate( 124 | path_f.pathd, 125 | path_f.pathfun(f) 126 | ); 127 | 128 | d3.select(path_f.pathsvg) 129 | .transition(2000) 130 | .delay(delay) 131 | .attrTween('d', function(d) {return interpolator}); 132 | 133 | path_f.pathd = path_f.pathfun(f); 134 | return f; 135 | } 136 | 137 | function edit_point(f, path_f, ed, delay) { 138 | d3.select(path_f.pathsvg) 139 | .transition(2000) 140 | .delay(delay) 141 | .attr('d', path_f.pathfun(f)); 142 | 143 | path_f.pathd = path_f.pathfun(f); 144 | return f; 145 | } 146 | 147 | function edit(ed, delay) { 148 | ed.feature.features.forEach(function(f) { 149 | var path_f = feat_lookup[get_id(f)]; 150 | 151 | if(f.geometry.type.toLowerCase() === 'point') { 152 | return edit_point(f, path_f, ed, delay); 153 | } 154 | 155 | return edit_polygon(f, path_f, ed, delay); 156 | }) 157 | }; 158 | 159 | function del(ed, delay) { 160 | ed.feature.features.forEach(function(f) { 161 | var path_f = feat_lookup[get_id(f)]; 162 | d3.select(path_f.pathsvg) 163 | .transition(2000) 164 | .delay(delay) 165 | .style('opacity', 0.0001) 166 | .remove(); 167 | 168 | delete feat_lookup[get_id(f)]; 169 | }); 170 | }; 171 | 172 | // add original features 173 | if(orig !== null) { 174 | feat_overlay(orig, 0, 0).addTo(map); 175 | } 176 | 177 | var actions = { 178 | 'map_draw_new_feature' : draw, 179 | 'map_draw_edited_features': edit, 180 | 'map_draw_deleted_features': del 181 | }; 182 | 183 | feat.forEach(function(ed, i) { 184 | if(orig !== null) { i = i + 1 } 185 | actions[ed.evt](ed, i * 1000) 186 | }); 187 | } 188 | ", 189 | jsonlite::toJSON( 190 | Map( 191 | function(x){ 192 | x$feature <- geojsonio::geojson_list(x$feature); 193 | x 194 | }, 195 | rec 196 | ), 197 | auto_unbox=TRUE, 198 | force=TRUE 199 | ), 200 | jsonlite::toJSON( 201 | orig_gj, 202 | auto_unbox=TRUE, 203 | force=TRUE, 204 | null="null" 205 | ) 206 | ) 207 | 208 | print(htmltools::browsable(htmltools::tagList( 209 | htmltools::tags$head( 210 | htmltools::tags$script(src="https://unpkg.com/d3"), 211 | htmltools::tags$script(src="https://unpkg.com/flubber@0.3.0"), 212 | htmltools::tags$script(src="https://cdn.rawgit.com/manubb/Leaflet.D3SvgOverlay/patch/L.D3SvgOverlay.js") 213 | ), 214 | htmltools::tags$script(htmltools::HTML("d3.selectAll('html,body').style('height','100%')")), 215 | htmltools::tags$div( 216 | style="height:100%;", 217 | htmlwidgets::onRender( 218 | map, 219 | scr 220 | ) 221 | ) 222 | )) 223 | ) 224 | } 225 | -------------------------------------------------------------------------------- /R/query.R: -------------------------------------------------------------------------------- 1 | #' Interactively Select Map Features 2 | #' 3 | #' @param x \code{leaflet} or \code{mapview} map to use for selection 4 | #' @param ... other arguments 5 | #' @example ./inst/examples/examples_select.R 6 | #' @export 7 | selectMap <- function(x, ...) { 8 | UseMethod("selectMap") 9 | } 10 | 11 | #' @name selectMap 12 | #' @param styleFalse,styleTrue names \code{list} of CSS styles used 13 | #' for selected (\code{styleTrue}) and deselected (\code{styleFalse}) 14 | #' @param ns \code{string} name for the Shiny \code{namespace} to use. The \code{ns} 15 | #' is unlikely to require a change. 16 | #' @param viewer \code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 17 | #' NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 18 | #' open the app in the default browser, the browser window will automatically 19 | #' close when closing the app (by pressing "done" or "cancel") in most browsers. 20 | #' Firefox is an exception. See Details for instructions on how to enable this 21 | #' behaviour in Firefox. 22 | #' @param title \code{string} to customize the title of the UI window. The default 23 | #' is "Select features". 24 | #' 25 | #' @details 26 | #' When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 27 | #' the systems default browser is Firefox, the browser window will likely not 28 | #' automatically close when the app is closed (by pressing "done" or "cancel"). 29 | #' To enable automatic closing of tabs/windows in Firefox try the following: 30 | #' \itemize{ 31 | #' \item{input "about:config " to your firefox address bar and hit enter} 32 | #' \item{make sure your "dom.allow_scripts_to_close_windows" is true} 33 | #' } 34 | #' 35 | #' @export 36 | selectMap.leaflet <- function( 37 | x = NULL, 38 | styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4), 39 | styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7), 40 | ns = "mapedit-select", 41 | viewer = shiny::paneViewer(), 42 | title = "Select features", 43 | ... 44 | ) { 45 | stopifnot(!is.null(x), inherits(x, "leaflet")) 46 | 47 | stopifnot( 48 | requireNamespace("leaflet"), 49 | requireNamespace("leaflet.extras"), 50 | requireNamespace("shiny"), 51 | requireNamespace("miniUI") 52 | ) 53 | 54 | ui <- miniUI::miniPage( 55 | miniUI::miniContentPanel( 56 | selectModUI(id = ns, height = "97%"), 57 | height=NULL, width=NULL 58 | ), 59 | miniUI::gadgetTitleBar( 60 | title = title, 61 | right = miniUI::miniTitleBarButton("done", "Done", primary = TRUE)), 62 | htmltools::tags$script(htmltools::HTML( 63 | " 64 | // close browser window on session end 65 | $(document).on('shiny:disconnected', function() { 66 | // check to make sure that button was pressed 67 | // to avoid websocket disconnect caused by some other reason than close 68 | if( 69 | Shiny.shinyapp.$inputValues['cancel:shiny.action'] || 70 | Shiny.shinyapp.$inputValues['done:shiny.action'] 71 | ) { 72 | window.close() 73 | } 74 | }) 75 | " 76 | )) 77 | ) 78 | 79 | server <- function(input, output, session) { 80 | selections <- shiny::callModule( 81 | selectMod, 82 | ns, 83 | x, 84 | styleFalse = styleFalse, 85 | styleTrue = styleTrue 86 | ) 87 | 88 | shiny::observe({selections()}) 89 | 90 | # if browser viewer and user closes tab/window 91 | # then Shiny does not stop so we will stopApp 92 | # when a session ends. This works fine unless a user might 93 | # have two sessions open. Closing one will also close the 94 | # other. 95 | sessionEnded <- session$onSessionEnded(function() { 96 | # should this be a cancel where we send NULL 97 | # or a done where we send crud() 98 | shiny::stopApp(shiny::isolate(selections())) 99 | }) 100 | 101 | shiny::observeEvent(input$done, { 102 | shiny::stopApp( 103 | selections() 104 | ) 105 | # cancel session ended handler to prevent https://github.com/r-spatial/mapedit/issues/83 106 | sessionEnded() 107 | }) 108 | 109 | shiny::observeEvent(input$cancel, { 110 | shiny::stopApp (NULL) 111 | # cancel session ended handler to prevent https://github.com/r-spatial/mapedit/issues/83 112 | sessionEnded() 113 | }) 114 | } 115 | 116 | 117 | shiny::runGadget( 118 | ui, 119 | server, 120 | viewer = viewer, 121 | stopOnCancel = FALSE 122 | ) 123 | } 124 | 125 | #' @keywords internal 126 | add_select_script <- function(lf, styleFalse, styleTrue, ns="") { 127 | ## check for existing onRender jsHook? 128 | 129 | htmlwidgets::onRender( 130 | lf, 131 | sprintf( 132 | " 133 | function(el,x) { 134 | var lf = this; 135 | var style_obj = { 136 | 'false': %s, 137 | 'true': %s 138 | } 139 | 140 | // define our functions for toggling 141 | function toggle_style(layer, style_obj) { 142 | layer.setStyle(style_obj); 143 | }; 144 | 145 | function toggle_state(layer, selected, init) { 146 | if(typeof(selected) !== 'undefined') { 147 | layer._mapedit_selected = selected; 148 | } else { 149 | selected = !layer._mapedit_selected; 150 | layer._mapedit_selected = selected; 151 | } 152 | if(typeof(Shiny) !== 'undefined' && Shiny.onInputChange && !init) { 153 | Shiny.onInputChange( 154 | '%s-mapedit_selected', 155 | { 156 | 'group': layer.options.group, 157 | 'id': layer.options.layerId, 158 | 'selected': selected 159 | } 160 | ) 161 | } 162 | return selected; 163 | }; 164 | 165 | // set up click handler on each layer with a group name 166 | lf.eachLayer(function(lyr){ 167 | if(lyr.on && lyr.options && lyr.options.layerId) { 168 | // start with all unselected ? 169 | toggle_state(lyr, false, init=true); 170 | toggle_style(lyr, style_obj[lyr._mapedit_selected]); 171 | 172 | lyr.on('click',function(e){ 173 | var selected = toggle_state(e.target); 174 | toggle_style(e.target, style_obj[String(selected)]); 175 | }); 176 | } 177 | }); 178 | } 179 | ", 180 | jsonlite::toJSON(styleFalse, auto_unbox=TRUE), 181 | jsonlite::toJSON(styleTrue, auto_unbox=TRUE), 182 | ns 183 | ) 184 | ) 185 | } 186 | -------------------------------------------------------------------------------- /R/select.R: -------------------------------------------------------------------------------- 1 | #' Interactively Select Map Features 2 | #' 3 | #' @param x features to select 4 | #' @param ... other arguments 5 | #' 6 | #' @example ./inst/examples/examples_select.R 7 | #' @export 8 | selectFeatures = function(x, ...) { 9 | UseMethod("selectFeatures") 10 | } 11 | 12 | 13 | #' @name selectFeatures 14 | #' @param mode one of "click" or "draw". 15 | #' @param op the geometric binary predicate to use for the selection. 16 | #' Can be any of \code{sf::geos_binary_pred}. In the spatial 17 | #' operation the drawn features will be evaluated as x and the supplied 18 | #' feature as y. Ignored if \code{mode = "click"}. 19 | #' @param map a background \code{leaflet} or \code{mapview} map 20 | #' to be used for editing. If \code{NULL} a blank 21 | #' mapview canvas will be provided. 22 | #' @param index \code{logical} with \code{index=TRUE} indicating return 23 | #' the index of selected features rather than the actual 24 | #' selected features 25 | #' @param viewer \code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 26 | #' NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 27 | #' open the app in the default browser, the browser window will automatically 28 | #' close when closing the app (by pressing "done" or "cancel") in most browsers. 29 | #' Firefox is an exception. See Details for instructions on how to enable this 30 | #' behaviour in Firefox. 31 | #' @param label \code{character} vector or \code{formula} for the 32 | #' content that will appear in label/tooltip. 33 | #' @param title \code{string} to customize the title of the UI window. The default 34 | #' is "Select features". 35 | #' 36 | #' @details 37 | #' When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 38 | #' the systems default browser is Firefox, the browser window will likely not 39 | #' automatically close when the app is closed (by pressing "done" or "cancel"). 40 | #' To enable automatic closing of tabs/windows in Firefox try the following: 41 | #' \itemize{ 42 | #' \item{input "about:config " to your firefox address bar and hit enter} 43 | #' \item{make sure your "dom.allow_scripts_to_close_windows" is true} 44 | #' } 45 | #' 46 | #' @export 47 | selectFeatures.sf = function( 48 | x = NULL, 49 | mode = c("click", "draw"), 50 | op = sf::st_intersects, 51 | map = NULL, 52 | index = FALSE, 53 | viewer = shiny::paneViewer(), 54 | label = NULL, 55 | title = "Select features", 56 | ... 57 | ) { 58 | 59 | nm = deparse(substitute(x)) 60 | x = checkAdjustProjection(x) 61 | x$edit_id = as.character(1:nrow(x)) 62 | 63 | mode = match.arg(mode) 64 | 65 | if (mode == "click") { 66 | 67 | if (is.null(map)) { 68 | map = initMap(proj4str = sf::st_crs(x)$proj4string) 69 | map = leafem::addFeatures( 70 | map, data = x, layerId = ~x$edit_id, label = label, ... 71 | ) 72 | ext = createExtent(x) 73 | map = leaflet::fitBounds( 74 | map, 75 | lng1 = ext[1], 76 | lat1 = ext[3], 77 | lng2 = ext[2], 78 | lat2 = ext[4] 79 | ) 80 | map = leafem::addHomeButton(map = map, ext = ext) 81 | } else { 82 | if(inherits(map, "mapview")) { 83 | map = map@map 84 | } 85 | map = leafem::addFeatures( 86 | map, data=x, layerId=~x$edit_id, label=label 87 | ) 88 | } 89 | 90 | ind = selectMap(map, viewer=viewer, title = title, ...) 91 | 92 | indx = ind$id[as.logical(ind$selected)] 93 | # todrop = "edit_id" 94 | 95 | # when index argument is TRUE return index rather than actual features 96 | if(index) { 97 | return(as.numeric(indx)) 98 | } 99 | 100 | # return selected features 101 | return(x[as.numeric(indx), !names(x) %in% "edit_id"]) 102 | 103 | } else { 104 | 105 | stopifnot(requireNamespace("sf")) 106 | 107 | drawn = editMap(mapview::mapView(x, map = map, layer.name = nm, ...), title = title) 108 | 109 | if (is.null(drawn$finished)) invisible(return(NULL)) 110 | 111 | if (!is.na(sf::st_crs(x))) { 112 | fin = sf::st_transform(drawn$finished, sf::st_crs(x)) 113 | } else { 114 | fin = drawn$finished 115 | sf::st_crs(fin) = NA 116 | } 117 | indx = unique(unlist(suppressMessages(op(fin, x)))) 118 | 119 | if(index) { 120 | return(as.numeric(indx)) 121 | } 122 | 123 | return(x[indx, ]) 124 | 125 | } 126 | } 127 | 128 | #' @name selectFeatures 129 | #' @export 130 | selectFeatures.Spatial = function(x, ...) { 131 | selectFeatures(x = sf::st_as_sf(x), ...) 132 | } 133 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, echo = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "README-" 12 | ) 13 | ``` 14 | 15 | # mapedit 16 | 17 | 18 | [![R-CMD-check](https://github.com/r-spatial/mapedit/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-spatial/mapedit/actions/workflows/R-CMD-check.yaml) 19 | [![cran checks](https://badges.cranchecks.info/worst/mapedit.svg)](https://cran.r-project.org/web/checks/check_results_mapedit.html) 20 | ![monthly](https://cranlogs.r-pkg.org/badges/mapedit) 21 | ![total](https://cranlogs.r-pkg.org/badges/grand-total/mapedit) 22 | [![CRAN](https://www.r-pkg.org/badges/version/mapedit?color=009999)](https://cran.r-project.org/package=mapedit) 23 | 24 | 25 | ### Status 26 | 27 | `mapedit` is still in active development. We would very much appreciate feedback, ideas, and use cases. The API has stabilized, and wee will use semantic versioning with Github tagged releases to track changes and progress. All changes will also be documented in NEWS.md. 28 | 29 | ### Blog Posts 30 | 31 | [Introduction to mapedit](https://r-spatial.org/r/2017/01/30/mapedit_intro.html) January 30, 2017 32 | 33 | 34 | [mapedit updates in 0.2.0](https://r-spatial.org/r/2017/06/09/mapedit_0-2-0.html) June 12, 2017 35 | 36 | 37 | [mapedit 0.5.0 and Leaflet.pm](https://r-spatial.org/r/2019/03/31/mapedit_leafpm.html) March 31, 2019 38 | 39 | 40 | 41 | ### Talks 42 | 43 | [Tim Appelhans at useR 2017](https://learn.microsoft.com/events/user-international-r-user-conferences/user-international-r-user-2017-conference/mapedit-interactive-manipulation-of-spatial-objects?term=tim%20appelhans) July 2017 44 | 45 | ### Install 46 | 47 | As the CRAN badge above indicates, `mapedit` has achieved CRAN status. To install, please use `install.packages`, or for the cutting edge, use `devtools::install_github`. 48 | 49 | ``` 50 | install.packages("mapedit") 51 | # cutting edge 52 | # remotes::install_github("r-spatial/mapedit") 53 | ``` 54 | 55 | ### Examples 56 | 57 | We can interactively CRD (create, update, delete) features on a map with `editMap`. 58 | 59 | ``` 60 | library(mapedit) 61 | library(leaflet) 62 | library(mapview) 63 | 64 | editMap(leaflet() %>% addTiles()) 65 | 66 | editMap( 67 | mapview(breweries91), 68 | targetLayerId = "breweries91" 69 | ) 70 | ``` 71 | 72 | `mapedit` also offers interactive selection of map features with `selectMap`. 73 | 74 | ``` 75 | library(mapedit) 76 | library(leaflet) 77 | library(mapview) 78 | 79 | selectMap( 80 | leaflet(breweries91) %>% 81 | addTiles() %>% 82 | addCircleMarkers(layerId = ~brewery) 83 | ) 84 | ``` 85 | 86 | ### Code of Conduct 87 | 88 | Please note that this project is released with a [Contributor Code of Conduct](https://github.com/r-spatial/mapedit/blob/master/CONDUCT.md). By participating in this project you agree to abide by its terms. 89 | 90 | 91 | ### Acknowledgment 92 | 93 | This project has been realized with financial [support](https://r-consortium.org/all-projects/2016-group-2.html#interactive-data-manipulation-in-mapview) from the 94 | 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # mapedit 5 | 6 | 7 | 8 | [![R-CMD-check](https://github.com/r-spatial/mapedit/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-spatial/mapedit/actions/workflows/R-CMD-check.yaml) 9 | [![cran 10 | checks](https://badges.cranchecks.info/worst/mapedit.svg)](https://cran.r-project.org/web/checks/check_results_mapedit.html) 11 | ![monthly](https://cranlogs.r-pkg.org/badges/mapedit) 12 | ![total](https://cranlogs.r-pkg.org/badges/grand-total/mapedit) 13 | [![CRAN](https://www.r-pkg.org/badges/version/mapedit?color=009999)](https://cran.r-project.org/package=mapedit) 14 | 15 | 16 | ### Status 17 | 18 | `mapedit` is still in active development. We would very much appreciate 19 | feedback, ideas, and use cases. The API has stabilized, and wee will use 20 | semantic versioning with Github tagged releases to track changes and 21 | progress. All changes will also be documented in NEWS.md. 22 | 23 | ### Blog Posts 24 | 25 | [Introduction to 26 | mapedit](https://r-spatial.org/r/2017/01/30/mapedit_intro.html) January 27 | 30, 2017 28 | 29 | [mapedit updates in 30 | 0.2.0](https://r-spatial.org/r/2017/06/09/mapedit_0-2-0.html) June 12, 31 | 2017 32 | 33 | [mapedit 0.5.0 and 34 | Leaflet.pm](https://r-spatial.org/r/2019/03/31/mapedit_leafpm.html) 35 | March 31, 2019 36 | 37 | ### Talks 38 | 39 | [Tim Appelhans at useR 40 | 2017](https://learn.microsoft.com/events/user-international-r-user-conferences/user-international-r-user-2017-conference/mapedit-interactive-manipulation-of-spatial-objects?term=tim%20appelhans) 41 | July 2017 42 | 43 | ### Install 44 | 45 | As the CRAN badge above indicates, `mapedit` has achieved CRAN status. 46 | To install, please use `install.packages`, or for the cutting edge, use 47 | `devtools::install_github`. 48 | 49 | install.packages("mapedit") 50 | # cutting edge 51 | # remotes::install_github("r-spatial/mapedit") 52 | 53 | ### Examples 54 | 55 | We can interactively CRD (create, update, delete) features on a map with 56 | `editMap`. 57 | 58 | library(mapedit) 59 | library(leaflet) 60 | library(mapview) 61 | 62 | editMap(leaflet() %>% addTiles()) 63 | 64 | editMap( 65 | mapview(breweries91), 66 | targetLayerId = "breweries91" 67 | ) 68 | 69 | `mapedit` also offers interactive selection of map features with 70 | `selectMap`. 71 | 72 | library(mapedit) 73 | library(leaflet) 74 | library(mapview) 75 | 76 | selectMap( 77 | leaflet(breweries91) %>% 78 | addTiles() %>% 79 | addCircleMarkers(layerId = ~brewery) 80 | ) 81 | 82 | ### Code of Conduct 83 | 84 | Please note that this project is released with a [Contributor Code of 85 | Conduct](https://github.com/r-spatial/mapedit/blob/master/CONDUCT.md). 86 | By participating in this project you agree to abide by its terms. 87 | 88 | ### Acknowledgment 89 | 90 | This project has been realized with financial 91 | [support](https://r-consortium.org/all-projects/2016-group-2.html#interactive-data-manipulation-in-mapview) 92 | from the 93 | 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Comments 2 | 3 | 2nd submission to fix invalid URL for Code of Conduct in the Readme.md 4 | 5 | 6 | ## Test environments 7 | * local OS X install, R 3.4.3 8 | * ubuntu 12.04 (on travis-ci), R 3.4.3 9 | * rhub::check_for_cran() 10 | 11 | ## R CMD check results 12 | 13 | 0 errors | 0 warnings | 1 note 14 | 15 | * NOTE 16 | Package which this enhances but not available for checking: 'geojsonio' 17 | 18 | ## Reverse dependencies 19 | 20 | There are no reverse dependencies. 21 | 22 | -------------------------------------------------------------------------------- /experiments/add_sf_to_df.R: -------------------------------------------------------------------------------- 1 | library(leaflet) 2 | library(mapview) 3 | library(mapedit) 4 | library(sf) 5 | library(DT) 6 | library(shiny) 7 | library(htmltools) 8 | 9 | script_zoom <- tags$script( 10 | HTML( 11 | " 12 | function findleaf() { 13 | return HTMLWidgets.find('.leaflet').getMap(); 14 | } 15 | 16 | function zoom(layerid) { 17 | var map = findleaf(); 18 | map.fitBounds(map._layers[layerid].getBounds()); 19 | } 20 | 21 | Shiny.addCustomMessageHandler( 22 | 'zoomselected', 23 | function(layerid) { 24 | debugger; 25 | zoom(layerid); 26 | } 27 | ) 28 | " 29 | ) 30 | ) 31 | 32 | make_an_sf <- function(dat) { 33 | ui <- tagList( 34 | script_zoom, 35 | fluidPage( 36 | fluidRow( 37 | column(6,DT::dataTableOutput("tbl",width="100%", height="400px")), 38 | column(6,editModUI("map")) 39 | ), 40 | fluidRow(actionButton("donebtn", "Done")) 41 | ) 42 | ) 43 | 44 | server <- function(input, output, session) { 45 | data_copy <- st_as_sf( 46 | dat, 47 | geometry = st_sfc(lapply(seq_len(nrow(dat)),function(i){st_point()})) 48 | ) 49 | 50 | # add column for leaflet id, since we will need to track layer id 51 | # to offer zoom to 52 | data_copy$leaflet_id <- NA 53 | 54 | edits <- callModule( 55 | editMod, 56 | leafmap = mapview()@map, 57 | id = "map" 58 | ) 59 | 60 | output$tbl <- DT::renderDataTable({ 61 | 62 | n <- ncol(data_copy) # used to hide geometry and leaflet_id columns 63 | 64 | DT::datatable( 65 | data_copy, 66 | options = list(scrollY="400px", 67 | columnDefs = list(list(visible=FALSE, targets=(n-1):n))), 68 | # could support multi but do single for now 69 | selection = "single", 70 | editable = TRUE 71 | ) 72 | }) 73 | 74 | # unfortunately I did not implement last functionality 75 | # for editMap, so do it the hard way 76 | # last seems useful, so I might circle back and add that 77 | EVT_DRAW <- "map_draw_new_feature" 78 | EVT_EDIT <- "map_draw_edited_features" 79 | EVT_DELETE <- "map_draw_deleted_features" 80 | 81 | nsm <- function(event="", id="map") { 82 | paste0(session$ns(id), "-", event) 83 | } 84 | 85 | addDrawObserve <- function(event) { 86 | observeEvent( 87 | input[[nsm(event)]], 88 | { 89 | evt <- input[[nsm(event)]] 90 | # for now if edit, just consider, first feature 91 | # of the FeatureCollection 92 | if(event == EVT_DELETE) { 93 | evt <- evt$features[1] 94 | } 95 | 96 | # get selected row 97 | selected <- isolate(input$tbl_rows_selected) 98 | 99 | skip = FALSE 100 | # ignore if selected is null 101 | # not great but good enough for poc 102 | if(is.null(selected)) {skip = TRUE} 103 | 104 | # ignore if no event 105 | #if(length(evt) == 0) {skip = TRUE} 106 | 107 | # replace if draw or edit 108 | if(skip==FALSE) { 109 | sf::st_geometry(data_copy[selected,]) <<- sf::st_geometry( 110 | mapedit:::st_as_sfc.geo_list(evt) 111 | ) 112 | data_copy[selected,]$leaflet_id <<- evt$properties$`_leaflet_id` 113 | } 114 | }) 115 | } 116 | 117 | addDrawObserve(EVT_DRAW) 118 | addDrawObserve(EVT_EDIT) 119 | 120 | observeEvent( 121 | input[[nsm(EVT_DELETE)]], 122 | { 123 | evt <- input[[nsm(EVT_DELETE)]] 124 | # get selected row 125 | selected <- isolate(input$tbl_rows_selected) 126 | 127 | skip = FALSE 128 | # ignore if selected is null 129 | # not great but good enough for poc 130 | if(is.null(selected)) {skip = TRUE} 131 | 132 | # ignore if no event 133 | #if(length(last) == 0) {skip = TRUE} 134 | 135 | # remove if delete 136 | if(skip==FALSE) { 137 | sf::st_geometry(data_copy[selected,]) <<- st_geometry(sf::st_sfc(st_point())) 138 | data_copy[selected,]$leaflet_id <<- NA 139 | } 140 | } 141 | ) 142 | 143 | 144 | # zoom to if feature available on selected row 145 | observeEvent( 146 | input$tbl_rows_selected, 147 | { 148 | selected <- input$tbl_rows_selected 149 | if(!is.null(selected)) { 150 | rowsel <- data_copy[selected, ] 151 | # simple check to see if feature available 152 | # and leaflet id populated 153 | if( 154 | all(!is.na(sf::st_coordinates(sf::st_geometry(rowsel)[[1]]))) && 155 | !is.na(rowsel$leaflet_id) 156 | ) { 157 | print(rowsel) 158 | session$sendCustomMessage("zoomselected", rowsel$leaflet_id) 159 | } 160 | } 161 | } 162 | ) 163 | 164 | # update table with entered notes 165 | proxy = dataTableProxy('tbl') 166 | 167 | observeEvent(input$tbl_cell_edit, { 168 | 169 | info = input$tbl_cell_edit 170 | 171 | str(info) 172 | 173 | i = info$row 174 | j = info$col 175 | v = info$value 176 | 177 | info$value <- as.character(info$value) 178 | 179 | data_copy[i, j] <<- DT::coerceValue(v, data_copy[i, j]) 180 | replaceData(proxy, data_copy, resetPaging = FALSE) # important 181 | 182 | }) 183 | 184 | # provide mechanism to return after all done 185 | observeEvent(input$donebtn, { 186 | # convert to sf 187 | 188 | stopApp(st_sf(data_copy,crs=4326)) 189 | }) 190 | } 191 | 192 | return(runApp(shinyApp(ui,server))) 193 | } 194 | 195 | 196 | # let's act like breweries does not have geometries 197 | brewsub <- breweries[,1:4,drop=TRUE] 198 | 199 | brewpub <- make_an_sf(brewsub) 200 | 201 | mapview(brewpub) 202 | -------------------------------------------------------------------------------- /experiments/crosstalk.R: -------------------------------------------------------------------------------- 1 | # devtools::install_github("rstudio/crosstalk") 2 | # devtools::install_github("rstudio/leaflet") 3 | 4 | library(crosstalk) 5 | library(leaflet) 6 | library(htmlwidgets) 7 | 8 | rand_lng = function(n = 10) rnorm(n, -93.65, .01) 9 | rand_lat = function(n = 10) rnorm(n, 42.0285, .01) 10 | 11 | pts <- SharedData$new( 12 | data.frame( 13 | lng = rand_lng(), 14 | lat = rand_lat() 15 | ), 16 | group = "grp1" 17 | ) 18 | 19 | 20 | lf <- leaflet(pts) %>% 21 | addTiles() %>% 22 | addMarkers() 23 | 24 | 25 | onRender( 26 | lf, 27 | " 28 | function(el,x) { 29 | debugger; 30 | var sl = new crosstalk.SelectionHandle('grp1'); 31 | sl.on('change', function(val){console.log(val);}) 32 | } 33 | " 34 | ) 35 | -------------------------------------------------------------------------------- /experiments/crosstalk_shiny.R: -------------------------------------------------------------------------------- 1 | # devtools::install_github("rstudio/crosstalk") 2 | # devtools::install_github("rstudio/leaflet") 3 | 4 | library(crosstalk) 5 | library(leaflet) 6 | library(shiny) 7 | library(dplyr) 8 | 9 | rand_lng = function(n = 10) rnorm(n, -93.65, .01) 10 | rand_lat = function(n = 10) rnorm(n, 42.0285, .01) 11 | 12 | pts <- SharedData$new( 13 | data.frame( 14 | id = 1:10, 15 | lng = rand_lng(), 16 | lat = rand_lat() 17 | ), 18 | key = ~id, 19 | group = "grp1" 20 | ) 21 | 22 | 23 | ui <- fluidPage( 24 | fluidRow( 25 | column(2, filter_select(id="filterselect", label="Points", sharedData=pts, group=~id)), 26 | column(6, leafletOutput("leaflet1")) 27 | ), 28 | h4("Selected points"), 29 | verbatimTextOutput("selectedpoints") 30 | ) 31 | 32 | server <- function(input, output, session) { 33 | 34 | pts <- SharedData$new( 35 | data.frame( 36 | id = 1:10, 37 | lng = rand_lng(), 38 | lat = rand_lat() 39 | ), 40 | key = ~id, 41 | group = "grp1" 42 | ) 43 | 44 | 45 | lf <- leaflet(pts) %>% 46 | addTiles() %>% 47 | addMarkers() 48 | 49 | not_rendered <- TRUE 50 | 51 | output$leaflet1 <- renderLeaflet({ 52 | if(req(not_rendered,cancelOutput=TRUE)) { 53 | not_rendered <- FALSE 54 | lf 55 | } 56 | }) 57 | 58 | output$selectedpoints <- renderPrint({ 59 | df <- pts$data(withSelection = TRUE) 60 | cat(nrow(df), "observation(s) selected\n\n") 61 | str(dplyr::glimpse(df)) 62 | }) 63 | } 64 | 65 | shinyApp(ui, server) 66 | -------------------------------------------------------------------------------- /experiments/draw_shiny_deleted.R: -------------------------------------------------------------------------------- 1 | library(leaflet) 2 | library(leaflet.extras) 3 | library(shiny) 4 | 5 | #using examples from ?leaflet 6 | rand_lng = function(n = 10) rnorm(n, -93.65, .01) 7 | rand_lat = function(n = 10) rnorm(n, 42.0285, .01) 8 | m = leaflet() %>% 9 | addTiles() %>% 10 | addPolygons(rand_lng(4), rand_lat(4), group = 'foo') %>% 11 | addPolygons(rand_lng(4), rand_lat(4), group = 'foo') %>% 12 | addDrawToolbar(targetGroup = "foo", editOptions = editToolbarOptions()) 13 | 14 | # do this in GlobalEnv only for example purposes 15 | deleted <- list() 16 | ui <- leafletOutput("leafmap") 17 | server <- function(input, output, session) { 18 | output$leafmap <- renderLeaflet({m}) 19 | 20 | observeEvent(input$leafmap_draw_deleted_features,{ 21 | str(input$leafmap_draw_deleted_features, max.level=2) 22 | deleted <<- c( 23 | deleted, 24 | input$leafmap_draw_deleted_features 25 | ) 26 | }) 27 | } 28 | shinyApp(ui, server) 29 | 30 | str(deleted, max.level=2) 31 | -------------------------------------------------------------------------------- /experiments/edit_map_draw_border.R: -------------------------------------------------------------------------------- 1 | library(sp) 2 | library(sf) 3 | library(leaflet) 4 | library(albersusa) 5 | library(mapedit) 6 | library(dplyr) 7 | 8 | usa_sf <- usa_composite() %>% st_as_sf() 9 | borders <- usa_sf %>% 10 | filter(usa_sf$iso_3166_2 %in% c("AZ","CA")) %>% 11 | leaflet() %>% 12 | addPolygons() %>% 13 | editMap() 14 | 15 | plot(borders$finished) 16 | -------------------------------------------------------------------------------- /experiments/edit_map_return_sf_tests.R: -------------------------------------------------------------------------------- 1 | library(geojsonio) 2 | 3 | file <- system.file("examples", "norway_maple.kml", package = "geojsonio") 4 | nwy_map <- geojson_read(as.location(file), what = "list") 5 | listviewer::jsonedit(nwy_map) 6 | 7 | pt <- nwy_map$features[[1]]$geometry 8 | class(pt) <- "geo_list" 9 | 10 | 11 | p_list <- lapply(list(c(3.2,4), c(3,4.6), c(3.8,4.4)), st_point) 12 | pt_sfc <- st_sfc(p_list) 13 | pt_sf <- st_sf(x = c("a", "b", "c"), pt_sfc) 14 | 15 | # use geojsonio to convert sf to geojson 16 | gj_pt_sf <- geojsonio::geojson_list(pt_sf) 17 | 18 | # start by trying to convert a single geojson feature to s 19 | feat <- gj_pt_sf$features[[1]] 20 | 21 | # manually translate one geojson feature 22 | one_feat <- st_sf( 23 | feat$properties, 24 | st_as_sfc.geo_list(feat$geometry) 25 | ) 26 | 27 | 28 | # now try to convert all of the geojson features 29 | feats <- lapply( 30 | gj_pt_sf$features, 31 | function(ft) { 32 | st_sf( 33 | ft$properties, 34 | st_as_sfc.geo_list(ft$geometry) 35 | ) 36 | } 37 | ) 38 | 39 | do.call(rbind, feats) 40 | 41 | 42 | 43 | convert_geojson_coords <- function(gj) { 44 | feats <- lapply( 45 | gj, 46 | function(ft) { 47 | ft <- fix_geojson_coords(ft) 48 | st_as_sfc.geo_list(ft$geometry) 49 | } 50 | ) 51 | 52 | sf::st_sf( 53 | features = do.call(sf::st_sfc, unlist(feats, recursive=FALSE)) 54 | ) 55 | } 56 | 57 | nwy_sf <- convert_geojson_coords(nwy_map$features) 58 | plot(nwy_sf) 59 | 60 | library(leaflet) 61 | library(mapedit) 62 | # draw something with mapedit::editMap 63 | # and try to convert to sf 64 | me_gj <- editMap(leaflet())$finished 65 | # coordinates from editMap not in proper form 66 | # so added a fix function 67 | me_sf <- convert_geojson_coords( 68 | lapply(me_gj,function(x) list(geometry = x$geometry)) 69 | ) 70 | plot(me_sf) 71 | 72 | # now let's try to build an st_as_sf.geo_list function 73 | # that we can apply to our editMap return 74 | # and other geojson 75 | nwy_sf2 <- lapply( 76 | nwy_map$features, 77 | st_as_sf.geo_list 78 | ) 79 | 80 | me_sf2 <- lapply( 81 | me_gj, 82 | st_as_sf.geo_list 83 | ) 84 | 85 | # ideally we convert these lists into st_sf 86 | # but we have a problem if all of the features 87 | # have different columns 88 | 89 | # the easiest solution would be to use dplyr 90 | # but would require a dependency on dplyr 91 | nwy_sf3 <- combine_list_of_sf(nwy_sf2) 92 | leaflet(nwy_sf3) %>% addMarkers(popup=~description) %>% addTiles() 93 | 94 | me_sf3 <- combine_list_of_sf(me_sf2) 95 | leaflet(me_sf3) %>% addPolygons(popup=~feature_type) %>% addTiles() 96 | 97 | 98 | # test with randgeo 99 | randgeo::geo_point(10) %>% 100 | {.$features} %>% 101 | lapply(function(x) st_as_sf.geo_list(x)) %>% 102 | combine_list_of_sf %>% 103 | leaflet() %>% 104 | addMarkers() %>% 105 | addTiles() 106 | 107 | 108 | # test with randgeo 109 | list( 110 | randgeo::geo_point(10), 111 | randgeo::geo_polygon(10) 112 | ) %>% 113 | {lapply(., function(x) x$features)} %>% 114 | unlist(recursive = FALSE) %>% 115 | lapply(function(x) st_as_sf.geo_list(x)) %>% 116 | combine_list_of_sf() %>% 117 | plot() 118 | -------------------------------------------------------------------------------- /experiments/experiment_split.R: -------------------------------------------------------------------------------- 1 | library(htmltools) 2 | library(leaflet) 3 | library(pipeR) 4 | 5 | lf <- leaflet(width="100%") %>% addTiles() 6 | 7 | css <- " 8 | html, body { 9 | height: 100%; 10 | } 11 | body { 12 | padding: 8px; 13 | background-color: #F6F6F6; 14 | box-sizing: border-box; 15 | } 16 | .split { 17 | -webkit-box-sizing: border-box; 18 | -moz-box-sizing: border-box; 19 | box-sizing: border-box; 20 | overflow-y: auto; 21 | overflow-x: hidden; 22 | } 23 | .content { 24 | border: 1px solid #C0C0C0; 25 | box-shadow: inset 0 1px 2px #e4e4e4; 26 | background-color: #fff; 27 | } 28 | .gutter { 29 | background-color: transparent; 30 | background-repeat: no-repeat; 31 | background-position: 50%; 32 | } 33 | .gutter.gutter-horizontal { 34 | cursor: col-resize; 35 | background-image: url('https://cdn.rawgit.com/nathancahill/Split.js/877632e1/grips/vertical.png'); 36 | } 37 | .gutter.gutter-vertical { 38 | cursor: row-resize; 39 | background-image: url('https://cdn.rawgit.com/nathancahill/Split.js/877632e1/grips/horizontal.png'); 40 | } 41 | .split.split-horizontal, .gutter.gutter-horizontal { 42 | height: 100%; 43 | float: left; 44 | } 45 | " 46 | 47 | tagList( 48 | tags$link(rel="stylesheet", href="https://cdnjs.cloudflare.com/ajax/libs/normalize/3.0.3/normalize.css"), 49 | tags$script(src="https://cdnjs.cloudflare.com/ajax/libs/split.js/1.2.0/split.min.js"), 50 | tags$style(css), 51 | tags$div( 52 | style = "height:410px;", 53 | tags$div( 54 | id = "map1", 55 | class = "split split-horizontal", 56 | tags$div(class="split content", lf) 57 | ), 58 | tags$div( 59 | id = "map2", 60 | class = "split split horizontal", 61 | tags$div(class="split content", lf) 62 | ) 63 | ), 64 | tags$script(' 65 | Split(["#map1", "#map2"], { 66 | gutterSize: 8, 67 | cursor: "col-resize", 68 | onDragEnd: function(evt){ 69 | $(".html-widget",$(event.target).parent().parent()).each(function(hw){ 70 | HTMLWidgets.find("#" + this.id).resize() 71 | }) 72 | } 73 | }) 74 | ') 75 | ) %>>% 76 | browsable() 77 | 78 | 79 | 80 | library(svglite) 81 | svg1 <- htmlSVG({contour(volcano)}, standalone=FALSE) 82 | 83 | tagList( 84 | tags$link(rel="stylesheet", href="https://cdnjs.cloudflare.com/ajax/libs/normalize/3.0.3/normalize.css"), 85 | tags$script(src="https://cdnjs.cloudflare.com/ajax/libs/split.js/1.2.0/split.min.js"), 86 | tags$style(css), 87 | tags$div( 88 | style = "height:410px;", 89 | tags$div( 90 | id = "map1", 91 | class = "split split-horizontal", 92 | tags$div(class="split content", lf) 93 | ), 94 | tags$div( 95 | id = "map2", 96 | class = "split split horizontal", 97 | tags$div(class="split content", svg1) 98 | ) 99 | ), 100 | tags$script(' 101 | Split(["#map1", "#map2"], { 102 | gutterSize: 8, 103 | cursor: "col-resize", 104 | onDragEnd: function(evt){ 105 | $(".html-widget",$(event.target).parent().parent()).each(function(hw){ 106 | HTMLWidgets.find("#" + this.id).resize() 107 | }) 108 | } 109 | }) 110 | ') 111 | ) %>>% 112 | browsable() 113 | 114 | -------------------------------------------------------------------------------- /experiments/flubber_playback.R: -------------------------------------------------------------------------------- 1 | library(sf) 2 | library(mapview) 3 | library(mapedit) 4 | library(geojsonio) 5 | library(htmltools) 6 | 7 | #ed <- editMap() 8 | #rec <- attr(ed, "recorder") 9 | 10 | #bbox <- unclass( 11 | # st_bbox( 12 | # mapedit:::combine_list_of_sf( 13 | # lapply(rec,function(x){x$feature}) 14 | # ) 15 | # ) 16 | #) 17 | 18 | bbox_rect <- geojson_json( 19 | st_polygon( 20 | list(matrix( 21 | c( 22 | c(bbox[1], bbox[4]), 23 | c(bbox[3], bbox[4]), 24 | c(bbox[3], bbox[2]), 25 | c(bbox[1], bbox[2]), 26 | c(bbox[1], bbox[4]) 27 | ), 28 | ncol=2, 29 | byrow=TRUE 30 | )) 31 | ) 32 | ) 33 | 34 | tl <- tagList( 35 | tags$head(tags$script(src="https://unpkg.com/flubber")), 36 | d3r::d3_dep_v4(offline = FALSE), 37 | tags$script(HTML( 38 | sprintf( 39 | " 40 | var feat = %s; 41 | var bbox = %s; 42 | var feat_lookup = {}; 43 | 44 | var proj = d3.geoMercator().fitSize( 45 | [800,400], 46 | bbox 47 | ); 48 | var path = d3.geoPath().projection(proj); 49 | 50 | var svg = d3.select('body').append('svg') 51 | .style('height', 400) 52 | .style('width', 800) 53 | .classed('map', true); 54 | 55 | 56 | function draw(ed, delay) { 57 | var path_f = svg 58 | .append('path') 59 | .datum(ed) 60 | .style('fill', 'none') 61 | .style('stroke', 'black') 62 | .style('opacity', 0.0001) 63 | .transition(2000) 64 | .delay(delay * 1000) 65 | .style('opacity', 1) 66 | .attr('d', path(ed.feature)); 67 | feat_lookup[ed.feature.features[0].properties.X_leaflet_id] = { 68 | pathd : path(ed.feature), 69 | pathsvg: path_f.node(0) 70 | } 71 | }; 72 | 73 | function edit(ed, delay) { 74 | var path_f = feat_lookup[ed.feature.features[0].properties.X_leaflet_id]; 75 | var interpolator = flubber.interpolate( 76 | path_f.pathd, 77 | path(ed.feature) 78 | ); 79 | 80 | d3.select(path_f.pathsvg) 81 | .transition(2000) 82 | .delay(delay * 1000) 83 | .attrTween('d', function(d) {return interpolator}); 84 | }; 85 | 86 | function del(ed, delay) { 87 | var path_f = feat_lookup[ed.feature.features[0].properties.X_leaflet_id]; 88 | d3.select(path_f.pathsvg) 89 | .transition(2000) 90 | .delay(delay * 1000) 91 | .style('opacity', 0.0001) 92 | .remove(); 93 | }; 94 | 95 | var actions = { 96 | 'map_draw_new_feature' : draw, 97 | 'map_draw_edited_features': edit, 98 | 'map_draw_deleted_features': del 99 | }; 100 | 101 | feat.forEach(function(ed, i) { 102 | actions[ed.evt](ed, i) 103 | }); 104 | /* 105 | var fpath = svg.append('g') 106 | .selectAll('path') 107 | .data([feat[0]]) 108 | .enter() 109 | .append('path') 110 | .attr('d', path) 111 | .style('stroke', 'black') 112 | .style('fill', 'none') 113 | .style('pointer-events', 'all'); 114 | 115 | feat.slice(1).reduce( 116 | function(left,right,i) { 117 | var interpolator = flubber.interpolate( 118 | path(feat[i]), 119 | path(right) 120 | ); 121 | 122 | return left 123 | .transition() 124 | .duration(2000) 125 | .attrTween('d', function(d) {return interpolator}); 126 | }, 127 | fpath 128 | ); 129 | */ 130 | ", 131 | jsonlite::toJSON( 132 | Map( 133 | function(x){ 134 | x$feature <-geojson_list(x$feature); 135 | x 136 | }, 137 | rec 138 | ), 139 | auto_unbox=TRUE, 140 | force=TRUE 141 | ), 142 | bbox_rect 143 | ) 144 | )) 145 | ) 146 | 147 | browsable(tl) 148 | -------------------------------------------------------------------------------- /experiments/flubber_playback.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-spatial/mapedit/d70bcd3af4877a27384fb101c5043ca7fff62fdd/experiments/flubber_playback.RData -------------------------------------------------------------------------------- /experiments/gadget_draw2.R: -------------------------------------------------------------------------------- 1 | # start toward a Shiny gadget for Leaflet and Leaflet.Draw 2 | # still missing many features but hopefully serves 3 | # as proof of concept 4 | 5 | #' Leaflet Draw Shiny Gadget 6 | #' 7 | #' @param lf leaflet map currently with \code{addDrawToolbar} already 8 | #' added. 9 | #' @param width,height valid \code{CSS} size for the gadget 10 | 11 | drawonme <- function(lf = NULL, height = NULL, width = NULL) { 12 | # modeled after chemdoodle gadget 13 | # https://github.com/zachcp/chemdoodle/blob/master/R/chemdoodle_sketcher_gadgets.R 14 | stopifnot(requireNamespace("miniUI"), requireNamespace("shiny")) 15 | ui <- miniUI::miniPage( 16 | miniUI::miniContentPanel(lf, height=NULL, width=NULL), 17 | miniUI::gadgetTitleBar("Draw Something", right = miniUI::miniTitleBarButton("done", "Done", primary = TRUE)) 18 | ) 19 | 20 | server <- function(input, output, session) { 21 | drawn <- list() 22 | edited <- list() 23 | 24 | shiny::observeEvent(input$undefined_draw_new_feature, { 25 | # we can clean this up 26 | drawn <<- c(drawn, list(input$undefined_draw_new_feature)) 27 | }) 28 | 29 | shiny::observeEvent(input$undefined_draw_edited_features, { 30 | edited <<- input$undefined_draw_edited_features 31 | # find the edited features and update drawn 32 | # start by getting the leaflet ids to do the match 33 | ids <- unlist(lapply(drawn, function(x){x$properties$`_leaflet_id`})) 34 | # now modify drawn to match edited 35 | lapply(edited$features, function(x){ 36 | loc <- match(x$properties$`_leaflet_id`, ids) 37 | drawn[loc] <<- list(x) 38 | }) 39 | }) 40 | 41 | shiny::observeEvent(input$done, { shiny::stopApp(drawn) }) 42 | shiny::observeEvent(input$cancel, { shiny::stopApp (NULL) }) 43 | } 44 | 45 | shiny::runGadget( 46 | ui, 47 | server, 48 | viewer = shiny::dialogViewer("Draw and Edit"), 49 | stopOnCancel = FALSE 50 | ) 51 | } 52 | 53 | 54 | # example use 55 | library(leaflet) 56 | library(leaflet.extras) 57 | library(mapview) 58 | 59 | lf <- mapview(breweries91)@map %>% 60 | addTiles() %>% 61 | addDrawToolbar(editOptions = editToolbarOptions()) 62 | 63 | drawn <- drawonme(lf) 64 | drawn 65 | 66 | Reduce( 67 | function(x,y) { 68 | x %>% addGeoJSON(y) 69 | }, 70 | drawn, 71 | init = lf 72 | ) 73 | 74 | library(lawn) 75 | l_pts <- lawn_featurecollection( 76 | as.list(unname(apply(breweries91@coords,MARGIN=1,lawn_point))) 77 | ) 78 | 79 | l_poly <- lawn_featurecollection( 80 | list(lawn_polygon(drawn[[1]]$geometry$coordinates)) 81 | ) 82 | 83 | l_in <- lawn_within(l_pts, l_poly) 84 | l_out <- lawn_featurecollection(Filter( 85 | function(pt) { 86 | !lawn_inside(pt, lawn_polygon(drawn[[1]]$geometry$coordinates)) 87 | }, 88 | as.list(unname(apply(breweries91@coords,MARGIN=1,lawn_point))) 89 | )) 90 | 91 | view(l_in) %>% 92 | addGeoJSON(drawn[[1]]) 93 | 94 | view(l_out) %>% 95 | addGeoJSON(drawn[[1]]) 96 | 97 | 98 | # try with sf 99 | library(sf) 100 | library(purrr) 101 | 102 | map(drawn, function(feat) { 103 | str(feat,max.level=1) 104 | eval( 105 | call( 106 | paste0("st_",tolower(feat$geometry$type)), 107 | list( 108 | matrix( 109 | unlist(feat$geometry$coordinates), 110 | byrow=TRUE, 111 | ncol=2 112 | ) 113 | ) 114 | ) 115 | ) 116 | }) 117 | 118 | 119 | 120 | # use example polygon from ?st_polygon 121 | # I don't think Leaflet.Draw handles holes 122 | outer = matrix(c(0,0,10,0,10,10,0,10,0,0),ncol=2, byrow=TRUE) 123 | hole1 = matrix(c(1,1,1,2,2,2,2,1,1,1),ncol=2, byrow=TRUE) 124 | hole2 = matrix(c(5,5,5,6,6,6,6,5,5,5),ncol=2, byrow=TRUE) 125 | pts = list(outer, hole1, hole2) 126 | pl1 <- st_polygon(pts) 127 | # make it geojson so we can use with drawonme 128 | pl1_g <- geojsonio::geojson_json(pl1) 129 | lf_pg <- leaflet() %>% 130 | addGeoJSONv2(pl1_g, layerId = "polygon") %>% 131 | addTiles() %>% 132 | addDrawToolbar(targetLayer="polygon", editOptions=editToolbarOptions()) 133 | drawonme(lf_pg) 134 | 135 | # just for fun demo geojson to sf 136 | jsonlite::fromJSON(pl1_g,simplifyVector=FALSE)$coordinates %>% 137 | lapply( 138 | function(x) unlist(x) %>% matrix(byrow=TRUE, ncol=2) 139 | ) %>% 140 | st_polygon() 141 | -------------------------------------------------------------------------------- /experiments/igraph_mapedit.r: -------------------------------------------------------------------------------- 1 | library(igraph) 2 | library(mapview) 3 | library(mapedit) 4 | library(sf) 5 | 6 | 7 | karate <- graph.famous("Zachary") 8 | igrf_layout <- layout.auto(karate) 9 | 10 | # see a default plot with our layout 11 | plot(karate, layout=igrf_layout) 12 | 13 | geom <- st_cast( 14 | st_sfc( 15 | st_multipoint(igrf_layout) 16 | ), 17 | "POINT" 18 | ) 19 | igrf_sf <- st_sf(geom) 20 | 21 | # plot with sf to confirm tranform occurred correctly 22 | plot(igrf_sf) 23 | 24 | # plot with leaflet 25 | lf <- leaflet( 26 | igrf_sf, 27 | options = leafletOptions( 28 | crs = leafletCRS(crsClass = "L.CRS.Simple") 29 | ) 30 | ) %>% 31 | addCircleMarkers(group = "network") 32 | 33 | new_layout <- lf %>% 34 | editMap("network") 35 | 36 | # this gets real tricky 37 | # but we will find a much easier way in mapedit 38 | # eventually 39 | library(shiny) 40 | app <- shinyApp( 41 | ui = editModUI("mapeditor"), 42 | server = function(input, output, session) { 43 | edits = callModule( 44 | editMod, 45 | "mapeditor", 46 | htmlwidgets::onRender( 47 | lf, 48 | " 49 | function(el,x) { 50 | var lf = this; 51 | setTimeout( 52 | function(){ 53 | Shiny.onInputChange( 54 | 'getpoints', 55 | Object.keys(lf.layerManager._byGroup.network) 56 | ) 57 | }, 58 | 500 59 | ) 60 | } 61 | " 62 | ), 63 | targetLayerId = "network" 64 | ) 65 | 66 | observeEvent(input$getpoints, {stopApp(input$getpoints)}) 67 | } 68 | ) 69 | 70 | leafids <- runApp(app) 71 | 72 | # now use our hacked method of id retrieval to identify points 73 | library(dplyr) 74 | 75 | layout_sf <- igrf_sf %>% 76 | mutate(leafid = as.numeric(leafids)) %>% 77 | { 78 | .[which(.$leafid %in% new_layout$edited$X_leaflet_id),]$geom <- new_layout$edited$feature 79 | . 80 | } 81 | 82 | mapview(layout_sf) 83 | 84 | plot(karate, layout=data.matrix(layout_df[,1:2])) 85 | -------------------------------------------------------------------------------- /experiments/mapedit_attribute_poc.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-spatial/mapedit/d70bcd3af4877a27384fb101c5043ca7fff62fdd/experiments/mapedit_attribute_poc.R -------------------------------------------------------------------------------- /experiments/merge_tests.R: -------------------------------------------------------------------------------- 1 | library(mapview) 2 | library(mapedit) 3 | library(sf) 4 | 5 | # for reproducibility and testing 6 | # a sample edit to test_sf 7 | test_sf <- structure(list(feature_type = c("polygon", "rectangle", "rectangle" 8 | ), id = c(77L, 89L, 94L), feature = structure(list(structure(list( 9 | structure(c(8.7702, 8.7701, 8.7704, 8.7702, 50.8151, 50.8149, 10 | 50.8149, 50.8151), .Dim = c(4L, 2L))), class = c("XY", "POLYGON", 11 | "sfg")), structure(list(structure(c(8.7705, 8.7705, 8.7709, 8.7709, 12 | 8.7705, 50.815, 50.8151, 50.8151, 50.815, 50.815), .Dim = c(5L, 13 | 2L))), class = c("XY", "POLYGON", "sfg")), structure(list(structure(c(8.7703, 14 | 8.7703, 8.7706, 8.7706, 8.7703, 50.8146, 50.8147, 50.8147, 50.8146, 15 | 50.8146), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg" 16 | ))), n_empty = 0L, class = c("sfc_POLYGON", "sfc"), precision = 0, crs = structure(list( 17 | epsg = 4326L, proj4string = "+proj=longlat +datum=WGS84 +no_defs"), .Names = c("epsg", 18 | "proj4string"), class = "crs"), bbox = structure(c(8.7701, 50.8146, 19 | 8.7709, 50.8151), .Names = c("xmin", "ymin", "xmax", "ymax")))), row.names = c(NA, 20 | 3L), class = c("sf", "data.frame"), sf_column = "feature", agr = structure(c(NA_integer_, 21 | NA_integer_), .Names = c("feature_type", "id"), .Label = c("constant", 22 | "aggregate", "identity"), class = "factor"), .Names = c("feature_type", 23 | "id", "feature")) 24 | 25 | # how we might delete with editMap 26 | # how we could edit with an id for the feature 27 | #del <- editMap( 28 | # leaflet() %>% addTiles() %>% addFeatures(test_sf, layerId=~id, group="toedit"), 29 | # targetLayerId = "toedit" 30 | #) 31 | 32 | del <- structure(list(X_leaflet_id = 41L, layerId = 94L, feature = structure(list( 33 | structure(list(structure(c(8.7703, 8.7703, 8.7706, 8.7706, 34 | 8.7703, 50.8146, 50.8147, 50.8147, 50.8146, 50.8146), .Dim = c(5L, 35 | 2L))), class = c("XY", "POLYGON", "sfg"))), n_empty = 0L, class = c("sfc_POLYGON", 36 | "sfc"), precision = 0, crs = structure(list(epsg = 4326L, proj4string = "+proj=longlat +datum=WGS84 +no_defs"), .Names = c("epsg", 37 | "proj4string"), class = "crs"), bbox = structure(c(8.7703, 50.8146, 38 | 8.7706, 50.8147), .Names = c("xmin", "ymin", "xmax", "ymax")))), .Names = c("X_leaflet_id", 39 | "layerId", "feature"), row.names = 1L, sf_column = "feature", agr = structure(c(NA_integer_, 40 | NA_integer_), class = "factor", .Label = c("constant", "aggregate", 41 | "identity"), .Names = c("X_leaflet_id", "layerId")), class = c("sf", 42 | "data.frame")) 43 | 44 | drwn <- structure(list(X_leaflet_id = c(71L, 90L, 100L, 112L), feature_type = c("polyline", 45 | "polygon", "polygon", "rectangle"), feature = structure(list( 46 | structure(c(8.7711, 8.771, 8.7709, 8.771, 8.7711, 8.7712, 47 | 50.8151, 50.815, 50.8149, 50.8149, 50.815, 50.815), .Dim = c(6L, 48 | 2L), class = c("XY", "LINESTRING", "sfg")), structure(list( 49 | structure(c(8.7707, 8.7706, 8.7707, 8.7707, 8.7707, 8.7707, 50 | 8.7707, 50.8149, 50.8148, 50.8148, 50.8148, 50.8149, 51 | 50.8149, 50.8149), .Dim = c(7L, 2L))), class = c("XY", 52 | "POLYGON", "sfg")), structure(list(structure(c(8.7708, 8.7707, 53 | 8.7709, 8.7708, 50.8148, 50.8147, 50.8147, 50.8148), .Dim = c(4L, 54 | 2L))), class = c("XY", "POLYGON", "sfg")), structure(list( 55 | structure(c(8.7709, 8.7709, 8.771, 8.771, 8.7709, 50.8147, 56 | 50.8148, 50.8148, 50.8147, 50.8147), .Dim = c(5L, 2L))), class = c("XY", 57 | "POLYGON", "sfg"))), n_empty = 0L, class = c("sfc_GEOMETRY", 58 | "sfc"), classes = c("LINESTRING", "POLYGON", "POLYGON", "POLYGON" 59 | ), precision = 0, crs = structure(list(epsg = 4326L, proj4string = "+proj=longlat +datum=WGS84 +no_defs"), .Names = c("epsg", 60 | "proj4string"), class = "crs"), bbox = structure(c(8.7706, 50.8147, 61 | 8.7712, 50.8151), .Names = c("xmin", "ymin", "xmax", "ymax")))), .Names = c("X_leaflet_id", 62 | "feature_type", "feature"), row.names = c(NA, 4L), sf_column = "feature", agr = structure(c(NA_integer_, 63 | NA_integer_), class = "factor", .Label = c("constant", "aggregate", 64 | "identity"), .Names = c("X_leaflet_id", "feature_type")), class = c("sf", 65 | "data.frame")) 66 | 67 | 68 | # for reproducibility 69 | # a sample edit to test_sf 70 | ed <- structure(list(X_leaflet_id = 33L, layerId = 77L, feature = structure(list( 71 | structure(list(structure(c(8.7702, 8.7701, 8.7702, 8.7704, 72 | 8.7702, 50.8151, 50.815, 50.8149, 50.8149, 50.8151), .Dim = c(5L, 73 | 2L))), class = c("XY", "POLYGON", "sfg"))), n_empty = 0L, class = c("sfc_POLYGON", 74 | "sfc"), precision = 0, crs = structure(list(epsg = 4326L, proj4string = "+proj=longlat +datum=WGS84 +no_defs"), .Names = c("epsg", 75 | "proj4string"), class = "crs"), bbox = structure(c(8.7701, 50.8149, 76 | 8.7704, 50.8151), .Names = c("xmin", "ymin", "xmax", "ymax")))), .Names = c("X_leaflet_id", 77 | "layerId", "feature"), row.names = 1L, sf_column = "feature", agr = structure(c(NA_integer_, 78 | NA_integer_), class = "factor", .Label = c("constant", "aggregate", 79 | "identity"), .Names = c("X_leaflet_id", "layerId")), class = c("sf", 80 | "data.frame")) 81 | 82 | mapedit:::merge_delete(test_sf, del) 83 | mapedit:::merge_add(test_sf, drwn) 84 | mapedit:::merge_edit(test_sf, ed) 85 | 86 | test_sf %>% 87 | mapedit:::merge_add(drwn) %>% 88 | mapedit:::merge_edit(ed) %>% 89 | mapedit:::merge_delete(del) 90 | 91 | mapview(mapedit:::merge_add(test_sf,drwn)) 92 | -------------------------------------------------------------------------------- /experiments/randgeo_edit.R: -------------------------------------------------------------------------------- 1 | \dontrun{ 2 | # demonstrate Leaflet.Draw on a layer 3 | 4 | # will use the very new randgeo 5 | # devtools::install_github("ropensci/randgeo") 6 | 7 | library(leaflet) 8 | library(leaflet.extras) 9 | library(randgeo) # see install instructions above 10 | # not working now due to error in addGeoJSON :( 11 | lf <- leaflet() %>% 12 | addTiles() %>% 13 | addGeoJSON( 14 | geo_polygon( 15 | count = 10, 16 | bbox = c(50,50,60,60), 17 | max_radial_length = 2 18 | ), 19 | layerId = "randgeo" 20 | ) %>% 21 | addDrawToolbar( 22 | targetLayer = "randgeo", 23 | editOptions = editToolbarOptions() 24 | ) %>% 25 | fitBounds(48,48,62,62) 26 | 27 | library(mapedit) 28 | editMap(lf) 29 | } 30 | -------------------------------------------------------------------------------- /experiments/select_crosstalk.R: -------------------------------------------------------------------------------- 1 | library(sf) 2 | library(leaflet) 3 | library(plotly) 4 | library(crosstalk) 5 | library(htmltools) 6 | 7 | boroughs<- st_read("http://services5.arcgis.com/GfwWNkhOj9bNBqoJ/arcgis/rest/services/nybb/FeatureServer/0/query?where=1=1&outFields=*&outSR=4326&f=geojson") 8 | boroughs$x <- seq(1:5) 9 | boroughs$y <- seq(2,10,2) 10 | 11 | boroughs_sd <- SharedData$new( 12 | boroughs, 13 | key=~BoroCode, 14 | # provide explicit group so we can easily refer to this later 15 | group = "boroughs" 16 | ) 17 | 18 | map <- leaflet(boroughs_sd) %>% 19 | addProviderTiles(providers$CartoDB.Positron) %>% 20 | addPolygons( 21 | data=boroughs, 22 | layerId = ~BoroCode, 23 | color = "#444444", 24 | weight = 1, 25 | smoothFactor = 0.5, 26 | opacity = 1.0, 27 | fillOpacity = 0.5, 28 | fillColor = ~colorQuantile("Greens", x)(x)#, 29 | # turn off highlight since it interferes with selection styling 30 | # if careful with styling could have both highlight and select 31 | # highlightOptions = highlightOptions(color = "white", weight = 2) 32 | ) 33 | 34 | # borrow from https://github.com/r-spatial/mapedit/blob/master/R/query.R#L73-L132 35 | # to select/deselect features but instead of Shiny.onInputChange 36 | # use crosstalk to manage state 37 | add_select_script <- function(lf, styleFalse, styleTrue, ns="") { 38 | ## check for existing onRender jsHook? 39 | 40 | htmlwidgets::onRender( 41 | lf, 42 | sprintf( 43 | " 44 | function(el,x) { 45 | var lf = this; 46 | var style_obj = { 47 | 'false': %s, 48 | 'true': %s 49 | } 50 | 51 | var crosstalk_group = '%s'; 52 | 53 | // instead of shiny input as our state manager 54 | // use crosstalk 55 | if(typeof(crosstalk) !== 'undefined' && crosstalk_group) { 56 | var ct_sel = new crosstalk.SelectionHandle() 57 | ct_sel.setGroup(crosstalk_group) 58 | ct_sel.on('change', function(x){ 59 | if(x.sender !== ct_sel) { //ignore select from this map 60 | lf.eachLayer(function(lyr){ 61 | if(lyr.options && lyr.options.layerId) { 62 | var id = String(lyr.options.layerId) 63 | if( 64 | !x.value || 65 | ( 66 | Array.isArray(x.value) && 67 | x.value.filter(function(d) { 68 | return d == id 69 | }).length === 0 70 | ) 71 | ) { 72 | toggle_state(lyr, false) 73 | toggle_style(lyr, style_obj.false) 74 | } 75 | if( 76 | Array.isArray(x.value) && 77 | x.value.filter(function(d) { 78 | return d == id 79 | }).length > 0 80 | ) { 81 | toggle_state(lyr, true) 82 | toggle_style(lyr, style_obj.true) 83 | } 84 | } 85 | }) 86 | } 87 | }) 88 | } 89 | 90 | // define our functions for toggling 91 | function toggle_style(layer, style_obj) { 92 | layer.setStyle(style_obj); 93 | }; 94 | function toggle_state(layer, selected, init) { 95 | if(typeof(selected) !== 'undefined') { 96 | layer._mapedit_selected = selected; 97 | } else { 98 | selected = !layer._mapedit_selected; 99 | layer._mapedit_selected = selected; 100 | } 101 | if(typeof(Shiny) !== 'undefined' && Shiny.onInputChange && !init) { 102 | Shiny.onInputChange( 103 | '%s-mapedit_selected', 104 | { 105 | 'group': layer.options.group, 106 | 'id': layer.options.layerId, 107 | 'selected': selected 108 | } 109 | ) 110 | } 111 | 112 | return selected; 113 | }; 114 | // set up click handler on each layer with a group name 115 | lf.eachLayer(function(lyr){ 116 | if(lyr.on && lyr.options && lyr.options.layerId) { 117 | // start with all unselected ? 118 | toggle_state(lyr, false, init=true); 119 | toggle_style(lyr, style_obj[lyr._mapedit_selected]); 120 | lyr.on('click',function(e){ 121 | var selected = toggle_state(e.target); 122 | toggle_style(e.target, style_obj[String(selected)]); 123 | 124 | if(ct_sel) { 125 | var ct_values = ct_sel.value; 126 | var id = lyr.options.layerId; 127 | if(selected) { 128 | if(!ct_values) { 129 | ct_sel.set([id, String(id)]) // do both since Plotly uses String id 130 | } 131 | // use filter instead of indexOf to allow inexact equality 132 | if( 133 | Array.isArray(ct_values) && 134 | ct_values.filter(function(d) { 135 | return d == id 136 | }).length === 0 137 | ) { 138 | ct_sel.set(ct_values.concat([id, String(id)])) // do both since Plotly uses String id 139 | } 140 | } 141 | 142 | if(ct_values && !selected) { 143 | ct_values.length > 1 ? 144 | ct_sel.set( 145 | ct_values.filter(function(d) { 146 | return d != id 147 | }) 148 | ) : 149 | ct_sel.set(null) // select all if nothing selected 150 | } 151 | } 152 | }); 153 | } 154 | }); 155 | } 156 | ", 157 | jsonlite::toJSON(styleFalse, auto_unbox=TRUE), 158 | jsonlite::toJSON(styleTrue, auto_unbox=TRUE), 159 | if(inherits(getMapData(map), "SharedData")) {getMapData(map)$groupName()} else {""}, 160 | ns 161 | ) 162 | ) 163 | } 164 | 165 | 166 | browsable( 167 | tagList( 168 | tags$div( 169 | style = "float:left; width: 49%;", 170 | add_select_script( 171 | map, 172 | styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4, color="black"), 173 | styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7, color="blue"), 174 | ns = "" 175 | ) 176 | ), 177 | tags$div( 178 | style = "float:left; width: 49%;", 179 | plot_ly(boroughs_sd, x = ~x, y = ~y) %>% 180 | add_markers(alpha = 0.5,text = ~paste('Borough: ', BoroName)) %>% 181 | highlight(on = "plotly_selected") 182 | ) 183 | ) 184 | ) 185 | 186 | 187 | # try it with DT datatable 188 | library(DT) 189 | 190 | # no reason to carry the load of the feature column 191 | # in the datatables 192 | # so we will modify the data to subtract the feature column 193 | # not necessary to use dplyr but select makes our life easy 194 | # also need to modify targets, colnames, and container 195 | dt <- datatable(boroughs_sd, width="100%") 196 | dt$x$data <- dplyr::select(dt$x$data, -geometry) 197 | dt$x$options$columnDefs[[1]]$targets <- seq_len(ncol(boroughs)-1) 198 | attr(dt$x, "colnames") <- attr(dt$x, "colnames")[which(attr(dt$x, "colnames") != "geometry")] 199 | dt$x$container <- gsub(x=dt$x$container, pattern="geometry\n", replacement="") 200 | dt 201 | 202 | 203 | browsable( 204 | tagList( 205 | tags$div( 206 | style = "float:left; width: 49%;", 207 | add_select_script( 208 | map, 209 | styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4, color="black"), 210 | styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7, color="blue"), 211 | ns = "" 212 | ) 213 | ), 214 | tags$div( 215 | style = "float:left; width: 49%;", 216 | dt 217 | ) 218 | ) 219 | ) 220 | 221 | 222 | # now try leaflet, plotly, and dt 223 | # this unfortunately does not work 224 | # exactly as we would like but plotly use of String key 225 | # seems to cause the problem 226 | # fixing Plotly is out of scope of this project 227 | # but I might take a look at some point to submit pull 228 | browsable( 229 | tagList( 230 | tags$div( 231 | style = "float:left; width: 32%;", 232 | add_select_script( 233 | map, 234 | styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4, color="black"), 235 | styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7, color="blue"), 236 | ns = "" 237 | ) 238 | ), 239 | tags$div( 240 | style = "float:left; width: 32%;", 241 | plot_ly(boroughs_sd, x = ~x, y = ~y) %>% 242 | add_markers(alpha = 0.5,text = ~paste('Borough: ', BoroName)) %>% 243 | highlight(on = "plotly_selected") 244 | ), 245 | tags$div( 246 | style = "float:left; width: 32%;", 247 | dt 248 | ) 249 | ) 250 | ) 251 | -------------------------------------------------------------------------------- /experiments/select_shiny_crosstalk.R: -------------------------------------------------------------------------------- 1 | library(maps) 2 | library(sp) 3 | library(maptools) 4 | library(sf) 5 | library(dplyr) 6 | 7 | library(leaflet) 8 | library(htmltools) 9 | library(crosstalk) 10 | 11 | usa <- map("state", fill = TRUE) 12 | IDs <- sapply(strsplit(usa$names, ":"), function(x) x[1]) 13 | usa <- map2SpatialPolygons(usa, IDs=IDs, proj4string=CRS("+proj=longlat +datum=WGS84")) 14 | 15 | # convert to simple features 16 | usa_sf <- st_as_sf(usa) 17 | usa_sf$state <- unlist(unique(lapply(usa@polygons,function(x){x@ID}))) 18 | # add area from R builtin data state.area 19 | usa_sf$area <- left_join( 20 | usa_sf, 21 | data.frame( 22 | state = tolower(state.name), 23 | area = state.area, 24 | stringsAsFactors = FALSE 25 | ) 26 | )$area 27 | 28 | # check our simple features 29 | plot(usa_sf) 30 | 31 | # map states with leaflet 32 | lf <- leaflet(usa_sf) %>% 33 | addPolygons(group = ~state) 34 | 35 | # modify Shiny leaflet click event to include shift and ctrl key 36 | tgs <- tagList( 37 | lf, 38 | htmlwidgets::onStaticRenderComplete( 39 | " 40 | var lf = HTMLWidgets.find('.leaflet').getMap(); 41 | var toggle_selected = function(group) { 42 | 43 | }; 44 | 45 | var toggle_opacity = function(group) { 46 | // change opacity in a crude way 47 | // assuming user just stuck with the defaults 48 | var layer = lf.layerManager.getLayerGroup(group); 49 | var opaqueness = 0.2; 50 | lf.layerManager 51 | .getLayerGroup(group) 52 | .eachLayer(function(x){opaqueness = Math.round(+$(x._path).css('fillOpacity')*10)/10}) 53 | opaqueness = opaqueness === 0.2 ? 0.6 : 0.2; 54 | layer.setStyle({fillOpacity:opaqueness}); 55 | }; 56 | 57 | $(document).on( 58 | 'shiny:inputchanged', 59 | function(e){ 60 | // filter for click events 61 | if(/click/.test(e.name)) { 62 | toggle_opacity(e.value.group); 63 | e.value = Object.assign( e.value, { 64 | ctrlKey: event.ctrlKey, 65 | shiftKey: event.shiftKey 66 | }) 67 | } 68 | } 69 | ) 70 | " 71 | ) 72 | ) 73 | 74 | library(shiny) 75 | # set this up in .GlobalEnv for now 76 | # but would be better in a gadget 77 | selections <- data.frame( 78 | state = usa_sf$state, 79 | selected = FALSE 80 | ) 81 | shinyApp( 82 | tgs, 83 | function(input, output){ 84 | id = "undefined" 85 | #if(!is.null(lf$elementId)) { 86 | # id <- lf$elementId 87 | #} 88 | click_evt = paste0(id, "_shape_click") 89 | 90 | observeEvent(input[[click_evt]], { 91 | print(input[[click_evt]]) 92 | selections[which(selections$state==input[[click_evt]]$group),"selected"] <<- c(selections, list(input[[click_evt]])) 93 | }) 94 | } 95 | ) 96 | 97 | 98 | # ugly hack to try to achieve crosstalk support 99 | # crosstalk and leaflet don't support addPolygons 100 | 101 | shinyApp( 102 | leafletOutput("leafmap"), 103 | function(input, output, session) { 104 | # use crosstalk SharedData with sf 105 | sd <- SharedData$new(usa_sf, key=~state, group="states") 106 | 107 | output$leafmap <- renderLeaflet({ 108 | leaflet(sd) %>% 109 | addPolygons(group = ~state) %>% 110 | htmlwidgets::onRender( 111 | " 112 | function(el,x) { 113 | var ct_select = new crosstalk.SelectionHandle('states'); 114 | 115 | ct_select.on('change', function(val){console.log(val)}); 116 | 117 | var lf = this; 118 | 119 | // define our functions for toggling 120 | function toggle_opacity(group) { 121 | // change opacity in a crude way 122 | // assuming user just stuck with the defaults 123 | var layer = lf.layerManager.getLayerGroup(group); 124 | var opaqueness = 0.2; 125 | if(layer.eachLayer) { 126 | layer.eachLayer(function(x){opaqueness = Math.round(+$(x._path).css('fillOpacity')*10)/10}) 127 | } 128 | opaqueness = opaqueness === 0.2 ? 0.6 : 0.2; 129 | layer.setStyle({fillOpacity:opaqueness}); 130 | return opaqueness; 131 | }; 132 | 133 | function toggle_state(group) { 134 | var selected = ct_select.value; 135 | if(Array.isArray(selected) && selected.length > 0) { 136 | var new_selection = selected.slice(); 137 | var loc = new_selection.indexOf(group); 138 | if(loc >= 0) { 139 | new_selection.splice(loc,1); 140 | ct_select.set(new_selection); 141 | } else { 142 | new_selection.push(group); 143 | ct_select.set(new_selection); 144 | } 145 | } else { 146 | ct_select.set([group]); 147 | } 148 | }; 149 | 150 | // set up click handler on each layer 151 | lf.eachLayer(function(lyr){ 152 | if(lyr.on && lyr.groupname) { 153 | lyr.on('click',function(e){ 154 | var group = this.groupname; 155 | var selected = toggle_opacity(group) === 0.6; 156 | toggle_state(group, selected); 157 | }) 158 | } 159 | }); 160 | } 161 | " 162 | ) 163 | }) 164 | 165 | observeEvent(input$leafmap_shape_click, { 166 | print(sd$data(withSelection=TRUE)) 167 | }) 168 | } 169 | ) 170 | -------------------------------------------------------------------------------- /experiments/sf_leafletdraw_intersect.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-spatial/mapedit/d70bcd3af4877a27384fb101c5043ca7fff62fdd/experiments/sf_leafletdraw_intersect.R -------------------------------------------------------------------------------- /inst/examples/examples_edit.R: -------------------------------------------------------------------------------- 1 | \dontrun{ 2 | # demonstrate Leaflet.Draw on a layer 3 | library(sf) 4 | library(mapview) 5 | library(leaflet.extras) 6 | library(mapedit) 7 | 8 | # ?sf::sf 9 | pol = st_sfc( 10 | st_polygon(list(cbind(c(0,3,3,0,0),c(0,0,3,3,0)))), 11 | crs = 4326 12 | ) 13 | mapview(pol) %>% 14 | editMap(targetLayerId = "pol") 15 | 16 | mapview(franconia[1:2,]) %>% 17 | editMap(targetLayerId = "franconia[1:2, ]") 18 | } 19 | -------------------------------------------------------------------------------- /inst/examples/examples_leafpm.R: -------------------------------------------------------------------------------- 1 | library(sf) 2 | library(mapview) 3 | 4 | #devtools::install_github("r-spatial/mapedit@leafpm") 5 | library(mapedit) 6 | #devtools::install_github("r-spatial/leafpm") 7 | library(leafpm) 8 | 9 | 10 | editFeatures(franconia[1:3,], editor = "leafpm") 11 | -------------------------------------------------------------------------------- /inst/examples/examples_select.R: -------------------------------------------------------------------------------- 1 | \dontrun{ 2 | library(mapedit) 3 | library(mapview) 4 | 5 | lf <- mapview() 6 | 7 | # draw some polygons that we will select later 8 | drawing <- lf %>% 9 | editMap() 10 | 11 | # little easier now with sf 12 | mapview(drawing$finished) 13 | 14 | # especially easy with selectFeatures 15 | selectFeatures(drawing$finished) 16 | 17 | 18 | # use @bhaskarvk USA Albers with leaflet code 19 | # https://bhaskarvk.github.io/leaflet/examples/proj4Leaflet.html 20 | #devtools::install_github("hrbrmstr/albersusa") 21 | library(albersusa) 22 | library(sf) 23 | library(leaflet) 24 | library(mapedit) 25 | 26 | spdf <- usa_sf() 27 | pal <- colorNumeric( 28 | palette = "Blues", 29 | domain = spdf$pop_2014 30 | ) 31 | 32 | bounds <- c(-125, 24 ,-75, 45) 33 | 34 | (lf <- leaflet( 35 | options= 36 | leafletOptions( 37 | worldCopyJump = FALSE, 38 | crs=leafletCRS( 39 | crsClass="L.Proj.CRS", 40 | code='EPSG:2163', 41 | proj4def=paste0( 42 | '+proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 ', 43 | '+b=6370997 +units=m +no_defs' 44 | ), 45 | resolutions = c(65536, 32768, 16384, 8192, 4096, 2048,1024, 512, 256, 128) 46 | ) 47 | ) 48 | ) %>% 49 | fitBounds(bounds[1], bounds[2], bounds[3], bounds[4]) %>% 50 | setMaxBounds(bounds[1], bounds[2], bounds[3], bounds[4]) %>% 51 | mapview::addFeatures( 52 | data=spdf, weight = 1, color = "#000000", 53 | # adding group necessary for identification 54 | layerId = ~iso_3166_2, 55 | fillColor=~pal(pop_2014), 56 | fillOpacity=0.7, 57 | label=~stringr::str_c(name,' ', format(pop_2014, big.mark=",")), 58 | labelOptions= labelOptions(direction = 'auto') 59 | ) 60 | ) 61 | 62 | 63 | # test out selectMap with albers example 64 | selectMap( 65 | lf, 66 | styleFalse = list(weight = 1), 67 | styleTrue = list(weight = 4) 68 | ) 69 | } 70 | -------------------------------------------------------------------------------- /inst/examples/shiny_modules.R: -------------------------------------------------------------------------------- 1 | \dontrun{ 2 | 3 | library(mapedit) 4 | library(mapview) 5 | library(shiny) 6 | 7 | # select as a module 8 | m = leaflet(breweries91) %>% 9 | addCircleMarkers(weight = 1, layerId = 1:nrow(breweries91)) 10 | 11 | ui <- tagList( 12 | selectModUI("test-mod"), 13 | DT::dataTableOutput("selected") 14 | ) 15 | server <- function(input, output, session) { 16 | selections <- callModule(selectMod, "test-mod", m) 17 | output$selected <- DT::renderDataTable({DT::datatable(selections())}) 18 | observe({str(selections())}) 19 | } 20 | shinyApp(ui, server) 21 | 22 | # edit as a module 23 | library(mapedit) 24 | library(mapview) 25 | library(shiny) 26 | 27 | m = mapview(breweries91)@map 28 | testsf = NULL 29 | ui <- tagList( 30 | editModUI("test-edit"), 31 | h1("What You Draw"), 32 | leafletOutput("edited") 33 | ) 34 | server <- function(input, output, session) { 35 | crud <- callModule(editMod, "test-edit", m, "breweries91") 36 | output$edited <- renderLeaflet({ 37 | req(crud()$finished) 38 | mapview(crud()$finished)@map 39 | }) 40 | } 41 | shinyApp(ui, server) 42 | 43 | 44 | # editMap module can easily be combined to make a selection tool 45 | # do selection of breweries with drawn polygons 46 | library(sf) 47 | library(mapview) 48 | library(mapedit) 49 | library(shiny) 50 | 51 | ui <- fluidPage( 52 | fluidRow( 53 | column(6,editModUI("brew-select")), 54 | column(6,leafletOutput("mapout")) 55 | ) 56 | ) 57 | server <- function(input,output,session) { 58 | m = mapview(breweries91)@map 59 | brew_sf <- st_as_sf(breweries91) 60 | drawn <- callModule(editMod, "brew-select", m) 61 | calc_sf <- reactiveValues() 62 | observe({ 63 | req(drawn()$finished) 64 | calc_sf$intersection <- st_intersection(drawn()$finished, brew_sf) 65 | }) 66 | output$mapout <- renderLeaflet({ 67 | req(calc_sf$intersection) 68 | (mapview(calc_sf$intersection) + mapview(drawn()$finished))@map 69 | }) 70 | } 71 | shinyApp(ui,server) 72 | 73 | } 74 | 75 | -------------------------------------------------------------------------------- /inst/posts/2017-01-22_interactivity.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Interactivity in R Geospatial Workflows" 3 | author: "Tim Appelhans and Kenton Russell" 4 | date: "January 27, 2017" 5 | output: html_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set(echo = TRUE) 10 | ``` 11 | 12 | The R ecosystem offers a powerful set of packages for geospatial analysis. For a comprehensive list see the [CRAN Task View: Analysis of Spatial Data](https://cran.r-project.org/web/views/Spatial.html). Yet, many geospatial workflows require interactivity for smooth uninterrupted completion. With new tools, such as htmlwidgets, shiny, and crosstalk, we can now inject this useful interactivity without leaving the R environment. In the first phase of the [`mapedit`](https://github.com/r-spatial/mapedit) project, we have focused on experimenting and creating proof of concepts for the following three objectives: 13 | 14 | 1. drawing, editing, and deleting features, 15 | 16 | 2. selecting and querying of features and map regions, 17 | 18 | 3. editing attributes. 19 | 20 | ## Install mapedit 21 | 22 | To run the code in the following discussion, please install with `devtools::install_github`. Please be aware that the current functionality is strictly a proof of concept, and the API will change rapidly and dramatically. 23 | 24 | ``` 25 | devtools::install_github("r-spatial/mapedit") 26 | ``` 27 | 28 | ## Drawing, Editing, Deleting Features 29 | 30 | We would like to set up an easy process for CRUD (create, read, update, and delete) of map features. The function `editMap` demonstrates a first step toward this goal. 31 | 32 | ### Proof of Concept 1 | Draw on Blank Map 33 | 34 | To see how we might add some features, let's start with a blank map, and then feel free to draw, edit, and delete with the `Leaflet.Draw` toolbar on the map. Once finished drawing simply press "Done". 35 | 36 | ``` 37 | library(leaflet) 38 | library(mapedit) 39 | library(mapview) 40 | 41 | what_we_created <- leaflet() %>% 42 | addTiles() %>% 43 | editMap() 44 | ``` 45 | 46 | `editMap` returns a `list` with drawn, edited, deleted, and finished features as [`GeoJSON`](https://tools.ietf.org/html/rfc7946). In this case, if we would like to see our finished creation we can focus on `what_we_created$finished`. Since this is `GeoJSON`, the easiest way to see what we just created will be to use the `addGeoJSON` function from `leaflet`. This works well with polylines, polygons, rectangles, and points, but circles will be treated as points without some additional code. In future versions of the API it is likely that `mapedit` will return [simple features gemometries](https://github.com/edzer/sfr) rather than geojson by default. 47 | 48 | ``` 49 | mapview(what_we_created$finished) 50 | ``` 51 | 52 | ### Proof of Concept 2 | Edit and Delete Existing Features 53 | 54 | As an extension of the first proof of concept, we might like to edit and/or delete existing features. Let's play Donald Trump for this exercise and use the border between Mexico and the United States for California and Arizona. For the sake of the example, let's use a simplified polyline as our border. As we have promised we want to build a wall, but if we could just move the border a little in some places, we might be able to ease construction. 55 | 56 | ``` 57 | library(sf) 58 | 59 | # simplified border for purpose of exercise 60 | border <- st_as_sfc( 61 | "LINESTRING(-109.050197582692 31.3535554844322, -109.050197582692 31.3535554844322, -111.071681957692 31.3723176640684, -111.071681957692 31.3723176640684, -114.807033520192 32.509681296831, -114.807033520192 32.509681296831, -114.741115551442 32.750242384668, -114.741115551442 32.750242384668, -117.158107738942 32.5652527715121, -117.158107738942 32.5652527715121)" 62 | ) %>% 63 | st_set_crs(4326) 64 | 65 | # plot quickly for visual inspection 66 | plot(border) 67 | ``` 68 | 69 | Since we are Trump, we can do what we want, so let's edit the line to our liking. We will use `mapview` for our interactive map since it by default gives us an OpenTopoMap layer and the `develop` branch includes preliminary simple features support. With our new border and fence, we will avoid the difficult mountains and get a little extra beachfront. 70 | 71 | ``` 72 | # use develop branch of mapview with simple features support 73 | # devtools::install_github("environmentalinformatics-marburg/mapview@develop") 74 | library(mapview) 75 | 76 | new_borders <- mapview(border)@map %>% 77 | editMap("border") 78 | ``` 79 | 80 | Now, we can quickly inspect our new borders and then send the coordinates to the wall construction company. 81 | 82 | ``` 83 | mapview(new_borders$drawn) 84 | ``` 85 | 86 | ### Disclaimers 87 | 88 | If you played enough with the border example, you might notice a couple of glitches and missing functionality. This is a good time for a reminder that this is alpha and intended as a proof of concept. Please provide feedback, so that we can insure a quality final product. In this case, the older version of `Leaflet.Draw` in RStudio Viewer has some bugs, so clicking an existing point creates a new one rather than allowing editing of that point. Also, the returned `list` from `editMap` has no knowledge of the provided features. 89 | 90 | ## Selecting Regions 91 | 92 | The newest version of `leaflet` provides [`crosstalk`](https://rstudio.github.io/crosstalk/) support, but support is currently limited to `addCircleMarkers`. This functionality is enhanced by the `sf` use of list columns and integration with `dplyr` verbs. Here is a quick example with the `breweries91` data from `mapview`. 93 | 94 | ``` 95 | library(crosstalk) 96 | library(mapview) 97 | library(sf) 98 | library(shiny) 99 | library(dplyr) 100 | 101 | # convert breweries91 from mapview into simple features 102 | # and add a Century column that we will use for selection 103 | brew_sf <- st_as_sf(breweries91) %>% 104 | mutate(century = floor(founded/100)*100) %>% 105 | filter(!is.na(century)) %>% 106 | mutate(id=1:n()) 107 | 108 | pts <- SharedData$new(brew_sf, key = ~id, group = "grp1") 109 | 110 | ui <- fluidPage( 111 | fluidRow( 112 | column(4, filter_slider(id="filterselect", label="Century Founded", sharedData=pts, column=~century, step=50)), 113 | column(6, leafletOutput("leaflet1")) 114 | ), 115 | h4("Selected points"), 116 | verbatimTextOutput("selectedpoints") 117 | ) 118 | 119 | server <- function(input, output, session) { 120 | # unfortunatly create SharedData again for scope 121 | pts <- SharedData$new(brew_sf, key = ~id, group = "grp1") 122 | lf <- leaflet(pts) %>% 123 | addTiles() %>% 124 | addMarkers() 125 | 126 | not_rendered <- TRUE 127 | # hack to only draw leaflet once 128 | output$leaflet1 <- renderLeaflet({ 129 | if(req(not_rendered,cancelOutput=TRUE)) { 130 | not_rendered <- FALSE 131 | lf 132 | } 133 | }) 134 | 135 | output$selectedpoints <- renderPrint({ 136 | df <- pts$data(withSelection = TRUE) 137 | cat(nrow(df), "observation(s) selected\n\n") 138 | str(dplyr::glimpse(df)) 139 | }) 140 | } 141 | 142 | shinyApp(ui, server) 143 | ``` 144 | 145 | With `mapedit`, we would like to enhance the geospatial `crosstalk` integration to extend beyond `leaflet::addCircleMarkers`. In addition, we would like to provide an interactive interface to the geometric operations of `sf`, such as `st_intersects()`, `st_difference()`, and `st_contains()`. 146 | 147 | ### Proof of Concept 3 148 | 149 | As a select/query proof of concept, assume we want to interactively select some US states for additional analysis. We will build off Bhaskar Karambelkar's leaflet projection [example](https://bhaskarvk.github.io/leaflet/examples/proj4Leaflet.html) using Bob Rudis [`albersusa`](https://github.com/hrbrmstr/albersusa) package. 150 | 151 | ``` 152 | # use @bhaskarvk USA Albers with leaflet code 153 | # https://bhaskarvk.github.io/leaflet/examples/proj4Leaflet.html 154 | #devtools::install_github("hrbrmstr/albersusa") 155 | library(albersusa) 156 | library(sf) 157 | library(leaflet) 158 | library(mapedit) 159 | 160 | spdf <- usa_composite() %>% st_as_sf() 161 | pal <- colorNumeric( 162 | palette = "Blues", 163 | domain = spdf$pop_2014 164 | ) 165 | 166 | bounds <- c(-125, 24 ,-75, 45) 167 | 168 | (lf <- leaflet( 169 | options= 170 | leafletOptions( 171 | worldCopyJump = FALSE, 172 | crs=leafletCRS( 173 | crsClass="L.Proj.CRS", 174 | code='EPSG:2163', 175 | proj4def='+proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 +b=6370997 +units=m +no_defs', 176 | resolutions = c(65536, 32768, 16384, 8192, 4096, 2048,1024, 512, 256, 128) 177 | ))) %>% 178 | fitBounds(bounds[1], bounds[2], bounds[3], bounds[4]) %>% 179 | setMaxBounds(bounds[1], bounds[2], bounds[3], bounds[4]) %>% 180 | addPolygons( 181 | data=spdf, weight = 1, color = "#000000", 182 | # adding group necessary for identification 183 | group = ~iso_3166_2, 184 | fillColor=~pal(pop_2014), 185 | fillOpacity=0.7, 186 | label=~stringr::str_c(name,' ', format(pop_2014, big.mark=",")), 187 | labelOptions= labelOptions(direction = 'auto')#, 188 | #highlightOptions = highlightOptions( 189 | # color='#00ff00', bringToFront = TRUE, sendToBack = TRUE) 190 | ) 191 | ) 192 | 193 | 194 | # test out selectMap with albers example 195 | selectMap( 196 | lf, 197 | styleFalse = list(weight = 1), 198 | styleTrue = list(weight = 4) 199 | ) 200 | ``` 201 | 202 | The `selectMap()` function will return a `data.frame` with an `id`/group column and a `selected` column. `selectMap()` will work with nearly all leaflet overlays and offers the ability to customize the styling of selected and unselected features. 203 | 204 | 205 | ## Editing Attributes 206 | 207 | A common task in geospatial analysis involves editing or adding feature attributes. While much of this can be accomplished in the R console, an interactive UI on a reference map can often help perform this task. Mapbox's [`geojson.io`](https://geojson.io) provides a good reference point for some of the features we would like to provide in `mapedit`. 208 | 209 | ### Proof of Concept 4 210 | 211 | As a proof of concept, we made a Shiny app that thinly wraps a slightly modified [`geojson.io`](https://github.com/timelyportfolio/geojson.io/tree/shiny). Currently, we will have to pretend that there is a mechanism to load R feature data onto the map, since this functionality does not yet exist. 212 | 213 | 214 | ``` 215 | library(shiny) 216 | edited_features <- runGitHub( 217 | "geojson.io", "timelyportfolio", ref="shiny" 218 | ) 219 | ``` 220 | 221 | 222 | ## Conclusion 223 | 224 | `mapedit` hopes to add useful interactivity to your geospatial workflows by leveraging powerful new functionality in R with the interactivity of HTML, JavaScript, and CSS. `mapedit` will be better with your feedback, requests, bug reports, use cases, and participation. We will report on progress periodically with blog posts on this site, and we will develop openly on the `mapedit` Github [repo](https://github.com/r-spatial/mapedit). 225 | -------------------------------------------------------------------------------- /inst/posts/2017-05-10_edit_sf.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Leveraging sf in editMap" 3 | author: "Tim Appelhans and Kenton Russell" 4 | date: "May 10, 2017" 5 | output: html_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set(echo = TRUE) 10 | ``` 11 | 12 | Intro to `sf` and links to posts and other articles. 13 | 14 | Other integrations of `sf` - mapview, leaflet, ggplot2, plotly, geojsonio 15 | 16 | ## Install mapedit 17 | 18 | To run the code in the following discussion, please install with `devtools::install_github`. Please be aware that the current functionality is strictly a proof of concept, and the API will change rapidly and dramatically. 19 | 20 | ``` 21 | devtools::install_github("r-spatial/mapedit") 22 | ``` 23 | 24 | ## editMap Returns sf 25 | 26 | ### Challenges 27 | 28 | ### Benefits 29 | 30 | 31 | 32 | ## Conclusion 33 | 34 | -------------------------------------------------------------------------------- /inst/posts/2020-01-24_geoattributes.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Introduction to Geo Attributes" 3 | date: "`r Sys.Date()`" 4 | output: rmarkdown::html_vignette 5 | vignette: > 6 | %\VignetteIndexEntry{Introduction to Geo Attributes} 7 | %\VignetteEngine{knitr::rmarkdown} 8 | %\VignetteEncoding{UTF-8} 9 | --- 10 | 11 | ```{r setup, include = FALSE} 12 | knitr::opts_chunk$set( 13 | collapse = TRUE, 14 | comment = "#>", 15 | eval = FALSE 16 | ) 17 | ``` 18 | 19 | 20 | ## Tests 21 | 22 | These tests are designed to step through and manually check different features of the application. For each test within the app you will create and modify geometry and attributes. Then using `mapview` check that the outputs are as expected. 23 | 24 | ### Start with no input 25 | 26 | 1. Launch app with no input 27 | 2. add a new row 28 | 3. add geometry to both rows 29 | 4. add a column 30 | 5. edit attributes 31 | 32 | 33 | ```{r} 34 | 35 | library(mapedit) 36 | 37 | sf1 <- editAttributes(zoomto = 'Montana') 38 | 39 | mapview::mapview(sf1) 40 | 41 | ``` 42 | 43 | 44 | ### Start with a `data.frame` 45 | 46 | 1. Launch app with `data.frame` 47 | 2. add geometry to each row 48 | 3. add a column 49 | 4. add a new row (ensure new row form clears after button click) 50 | 5. edit attributes 51 | 52 | ```{r} 53 | 54 | data <- data.frame( 55 | name = c('SiteA', 'SiteB'), 56 | type = factor(c('park', 'zoo'), levels = c('park', 'factory', 'zoo', 'warehouse')), 57 | size = c(35, 45), 58 | stringsAsFactors = FALSE 59 | ) 60 | 61 | sf2 <- editAttributes(data, zoomto = 'Montana') 62 | 63 | mapview::mapview(sf2) 64 | 65 | ``` 66 | 67 | 68 | 69 | ### Start with an existing `sf` object 70 | 71 | 1. Launch app with `sf` object 72 | 2. add a column 73 | 3. add a new row 74 | 4. edit attributes 75 | 5. edit geometry 76 | 77 | ```{r} 78 | 79 | sf3 <- editAttributes(sf2) 80 | 81 | mapview::mapview(sf3) 82 | 83 | ``` 84 | 85 | 86 | 87 | 88 | 89 | ### Add features or rows without using `New Row` button 90 | 91 | Use this option when features don't share any attributes 92 | 93 | 1. Launch app with `sf` object 94 | 2. add geometry feature without clicking `Row` button 95 | 3. edit attributes 96 | 97 | ```{r} 98 | 99 | sf4 <- editAttributes(sf2) 100 | 101 | mapview::mapview(sf4) 102 | 103 | ``` 104 | 105 | 106 | 107 | 108 | ### Delete Existing Features 109 | 110 | 1. Launch app with `sf` object 111 | 2. click on the bin icon 112 | 3. select feature to delete 113 | 114 | ```{r} 115 | 116 | sf5 <- editAttributes(sf2) 117 | 118 | mapview::mapview(sf5) 119 | ``` 120 | 121 | 122 | 123 | ### Create object with multiple geometry types 124 | 125 | 1. Launch app with no input 126 | 2. add geometry features without clicking `Row` button 127 | 128 | 129 | ```{r} 130 | 131 | sf6 <- editAttributes(zoomto = 'Montana') 132 | 133 | mapview::mapview(sf6) 134 | 135 | ``` 136 | 137 | 138 | 139 | ### Edit object with multiple geometry types 140 | 141 | Editing existing features from a multi-geometry input does not work with lines or points. 142 | 143 | 1. Launch app with previous input 144 | 2. edit geometry features 145 | 146 | 147 | ```{r} 148 | 149 | sf7 <- editAttributes(sf6) 150 | 151 | mapview::mapview(sf7) 152 | 153 | ``` 154 | 155 | 156 | 157 | 158 | ### Hide New Column Form 159 | 160 | 1. Launch app with previous input 161 | 2. check the new column form is missing 162 | 163 | 164 | ```{r} 165 | 166 | sf8 <- editAttributes(sf7, col_add = FALSE) 167 | 168 | mapview::mapview(sf8) 169 | 170 | ``` 171 | 172 | 173 | ### Don't Reset New Row form after click 174 | 175 | Use this option when creating features that have common attributes 176 | 177 | 1. Launch app with previous input 178 | 2. add rows using form (fields should not clear after button click) 179 | 180 | 181 | 182 | ```{r} 183 | 184 | sf9 <- editAttributes(sf8, reset = FALSE) 185 | 186 | mapview::mapview(sf9) 187 | 188 | ``` 189 | -------------------------------------------------------------------------------- /inst/rstudio/addins.dcf: -------------------------------------------------------------------------------- 1 | Name: Create Spatial Data 2 | Description: Create spatial data using mapedit 3 | Binding: createFeatures 4 | Interactive: true 5 | 6 | Name: Edit Spatial Data and Attributes 7 | Description: Create and edit spatial data and attributes 8 | Binding: editAttributes 9 | Interactive: true 10 | -------------------------------------------------------------------------------- /man/addToolbar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/addToolbar.R 3 | \name{addToolbar} 4 | \alias{addToolbar} 5 | \title{Add a (possibly customized) toolbar to a leaflet map} 6 | \usage{ 7 | addToolbar(leafmap, editorOptions, editor, targetLayerId) 8 | } 9 | \arguments{ 10 | \item{leafmap}{leaflet map to use for Selection} 11 | 12 | \item{editorOptions}{A list of options to be passed on to either 13 | \code{leaflet.extras::addDrawToolbar} or 14 | \code{leafpm::addPmToolbar}.} 15 | 16 | \item{editor}{Character string giving editor to be used for the 17 | current map. Either \code{"leafpm"} or 18 | \code{"leaflet.extras"}.} 19 | 20 | \item{targetLayerId}{\code{string} name of the map layer group to 21 | use with edit} 22 | } 23 | \value{ 24 | The leaflet map supplied to \code{leafmap}, now with an 25 | added toolbar. 26 | } 27 | \description{ 28 | Add a (possibly customized) toolbar to a leaflet map 29 | } 30 | -------------------------------------------------------------------------------- /man/createFeatures.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/addin.R 3 | \name{createFeatures} 4 | \alias{createFeatures} 5 | \title{mapedit create features Addin} 6 | \usage{ 7 | createFeatures(SF_OBJECT = NULL) 8 | } 9 | \arguments{ 10 | \item{SF_OBJECT}{sf Simple feature collection} 11 | } 12 | \value{ 13 | sf object and/or saved to file 14 | } 15 | \description{ 16 | Create and save spatial objects within the Rstudio IDE. Objects 17 | can then be saved to file types such as \code{.geojson} or \code{.shp}. 18 | Objects are also output to the console and can be assigned to a variable 19 | using \code{.Last.value}. If you wish to pass the output directly to a variable 20 | simply call the addin function, ie. \code{new_sf <- createFeatures()}. 21 | 22 | An existing sf \code{data.frame} can also be passed either indirectly by 23 | selecting text in RStudio with the name of the object, or directly by 24 | passing the existing sf object to \code{new_sf <- createFeatures(existing_sf)}. 25 | When passing an existing sf object you can only add and edit additional features, 26 | the existing features cannot be changed. 27 | } 28 | -------------------------------------------------------------------------------- /man/drawFeatures.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/draw.R 3 | \name{drawFeatures} 4 | \alias{drawFeatures} 5 | \title{Draw (simple) features on a map} 6 | \usage{ 7 | drawFeatures( 8 | map = NULL, 9 | sf = TRUE, 10 | record = FALSE, 11 | viewer = shiny::paneViewer(), 12 | title = "Draw Features", 13 | editor = c("leaflet.extras", "leafpm"), 14 | editorOptions = list(), 15 | ... 16 | ) 17 | } 18 | \arguments{ 19 | \item{map}{a background \code{leaflet} or \code{mapview} map 20 | to be used for editing. If \code{NULL} a blank 21 | mapview canvas will be provided.} 22 | 23 | \item{sf}{\code{logical} return simple features. The default is \code{TRUE}. 24 | If \code{sf = FALSE}, \code{GeoJSON} will be returned.} 25 | 26 | \item{record}{\code{logical} to record all edits for future playback.} 27 | 28 | \item{viewer}{\code{function} for the viewer. See Shiny \code{shiny::viewer}. 29 | NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 30 | open the app in the default browser, the browser window will automatically 31 | close when closing the app (by pressing "done" or "cancel") in most browsers. 32 | Firefox is an exception. See Details for instructions on how to enable this 33 | behaviour in Firefox.} 34 | 35 | \item{title}{\code{string} to customize the title of the UI window.} 36 | 37 | \item{editor}{\code{character} either "leaflet.extras" or "leafpm"} 38 | 39 | \item{editorOptions}{\code{list} of options suitable for passing to 40 | either \code{leaflet.extras::addDrawToolbar} or 41 | \code{leafpm::addPmToolbar}.} 42 | 43 | \item{...}{additional arguments passed on to \code{\link{editMap}}.} 44 | } 45 | \description{ 46 | Draw (simple) features on a map 47 | } 48 | \details{ 49 | When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 50 | the systems default browser is Firefox, the browser window will likely not 51 | automatically close when the app is closed (by pressing "done" or "cancel"). 52 | To enable automatic closing of tabs/windows in Firefox try the following: 53 | \itemize{ 54 | \item{input "about:config " to your firefox address bar and hit enter} 55 | \item{make sure your "dom.allow_scripts_to_close_windows" is true} 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /man/editAttributes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/editAttributes.R 3 | \name{editAttributes} 4 | \alias{editAttributes} 5 | \title{Edit Feature Attributes} 6 | \usage{ 7 | editAttributes( 8 | dat, 9 | zoomto = NULL, 10 | col_add = TRUE, 11 | reset = TRUE, 12 | provider = "Esri.WorldImagery", 13 | testing = FALSE 14 | ) 15 | } 16 | \arguments{ 17 | \item{dat}{input data source, can be a \code{data.frame} or an \verb{sf data.frame}, or it can be left empty. 18 | When nothing is passed to \code{dat} a basic \code{data.frame} is generated with \code{id} and \code{comment} fields.} 19 | 20 | \item{zoomto}{character area of interest. The area is defined using \link[tmaptools]{geocode_OSM}, 21 | which uses \href{https://nominatim.org/}{OSM Nominatim}. The area can be as ambiguous as a country, or 22 | as specific as a street address. You can test the area of interest using the application or the example 23 | code below.} 24 | 25 | \item{col_add}{boolean option to enable add columns form. Set to false if you don't want to allow a user to modify 26 | the data structure.} 27 | 28 | \item{reset}{boolean option to reset attribute input. Set to false if you don't want the attribute input to 29 | reset to NA after each added row. Use this option when features share common attributes} 30 | 31 | \item{provider}{A character string indicating the provider tile of choice, e.g. 'Esri.WorldImagery' (default)} 32 | 33 | \item{testing}{Only relevant for internal testing using shinytest.} 34 | } 35 | \value{ 36 | sf data.frame 37 | } 38 | \description{ 39 | Launches a \code{shiny} application where you can add and edit spatial geometry 40 | and attributes. Geometry is created or edited within the interactive map, while feature attributes 41 | can be added to and edited within the editable table. 42 | 43 | Starting with a \code{data.frame} or an \verb{sf data.frame}, a list of \verb{sf data.frames} or nothing 44 | at all. You can add columns, and rows and geometry for each row. Clicking on a row with geometry you can 45 | zoom across the map between features. 46 | 47 | When you are done, your edits are saved to an \verb{sf data.frame} for 48 | use in R or to be saved to anyformat you wish via \link[sf]{st_write}. 49 | 50 | The application can dynamically handle: character, numeric, integer, factor and date fields. 51 | 52 | When the input data set is an \verb{sf data.frame} the map automatically zooms to the extent of the \code{sf} object. 53 | 54 | When the input has no spatial data, you must tell the function where to zoom. The function uses 55 | \link[tmaptools]{geocode_OSM} to identify the coordinates of your area of interest. 56 | } 57 | \note{ 58 | Editing of feature geometries does not work for multi-geometry inputs. For this use case it is advisable to 59 | split the data set by geometry type and edit separately 60 | } 61 | \examples{ 62 | \dontrun{ 63 | 64 | # with no input 65 | data_sf <- editAttributes(zoomto = 'germany') 66 | 67 | # a data.frame input 68 | dat <- data.frame(name = c('SiteA', 'SiteB'), 69 | type = factor( 70 | c('park', 'zoo') 71 | , levels = c('park', 'factory', 'zoo', 'warehouse') 72 | ), 73 | size = c(35, 45)) 74 | 75 | data_sf <- editAttributes(dat, zoomto = 'berlin') 76 | 77 | # an sf data.frame input 78 | data_sf <- editAttributes(data_sf) 79 | 80 | # test zoomto area of interest 81 | zoomto_area <- tmaptools::geocode_OSM('paris') 82 | mapview(st_as_sfc(zoomto_area$bbox)) 83 | 84 | } 85 | } 86 | -------------------------------------------------------------------------------- /man/editFeatures.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/edit.R 3 | \name{editFeatures} 4 | \alias{editFeatures} 5 | \alias{editFeatures.sf} 6 | \alias{editFeatures.Spatial} 7 | \title{Interactively Edit Map Features} 8 | \usage{ 9 | editFeatures(x, ...) 10 | 11 | \method{editFeatures}{sf}( 12 | x, 13 | map = NULL, 14 | mergeOrder = c("add", "edit", "delete"), 15 | record = FALSE, 16 | viewer = shiny::paneViewer(), 17 | crs = 4326, 18 | label = NULL, 19 | title = "Edit Map", 20 | editor = c("leaflet.extras", "leafpm"), 21 | editorOptions = list(), 22 | ... 23 | ) 24 | 25 | \method{editFeatures}{Spatial}(x, ...) 26 | } 27 | \arguments{ 28 | \item{x}{features to edit} 29 | 30 | \item{...}{other arguments} 31 | 32 | \item{map}{a background \code{leaflet} or \code{mapview} map 33 | to be used for editing. If \code{NULL} a blank 34 | mapview canvas will be provided.} 35 | 36 | \item{mergeOrder}{\code{vector} or \code{character} arguments to specify the order 37 | of merge operations. By default, merges will proceed in the order 38 | of add, edit, delete.} 39 | 40 | \item{record}{\code{logical} to record all edits for future playback.} 41 | 42 | \item{viewer}{\code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 43 | NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 44 | open the app in the default browser, the browser window will automatically 45 | close when closing the app (by pressing "done" or "cancel") in most browsers. 46 | Firefox is an exception. See Details for instructions on how to enable this 47 | behaviour in Firefox.} 48 | 49 | \item{crs}{see \code{\link[sf]{st_crs}}.} 50 | 51 | \item{label}{\code{character} vector or \code{formula} for the 52 | content that will appear in label/tooltip.} 53 | 54 | \item{title}{\code{string} to customize the title of the UI window. The default 55 | is "Edit Map".} 56 | 57 | \item{editor}{\code{character} either "leaflet.extras" or "leafpm"} 58 | 59 | \item{editorOptions}{\code{list} of options suitable for passing to 60 | either \code{leaflet.extras::addDrawToolbar} or 61 | \code{leafpm::addPmToolbar}.} 62 | } 63 | \description{ 64 | Interactively Edit Map Features 65 | } 66 | \details{ 67 | When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 68 | the systems default browser is Firefox, the browser window will likely not 69 | automatically close when the app is closed (by pressing "done" or "cancel"). 70 | To enable automatic closing of tabs/windows in Firefox try the following: 71 | \itemize{ 72 | \item{input "about:config " to your firefox address bar and hit enter} 73 | \item{make sure your "dom.allow_scripts_to_close_windows" is true} 74 | } 75 | } 76 | \examples{ 77 | \dontrun{ 78 | library(mapedit) 79 | library(mapview) 80 | 81 | lf <- mapview() 82 | 83 | # draw some polygons that we will select later 84 | drawing <- lf \%>\% 85 | editMap() 86 | 87 | # little easier now with sf 88 | mapview(drawing$finished) 89 | 90 | # especially easy with selectFeatures 91 | selectFeatures(drawing$finished) 92 | 93 | 94 | # use @bhaskarvk USA Albers with leaflet code 95 | # https://bhaskarvk.github.io/leaflet/examples/proj4Leaflet.html 96 | #devtools::install_github("hrbrmstr/albersusa") 97 | library(albersusa) 98 | library(sf) 99 | library(leaflet) 100 | library(mapedit) 101 | 102 | spdf <- usa_sf() 103 | pal <- colorNumeric( 104 | palette = "Blues", 105 | domain = spdf$pop_2014 106 | ) 107 | 108 | bounds <- c(-125, 24 ,-75, 45) 109 | 110 | (lf <- leaflet( 111 | options= 112 | leafletOptions( 113 | worldCopyJump = FALSE, 114 | crs=leafletCRS( 115 | crsClass="L.Proj.CRS", 116 | code='EPSG:2163', 117 | proj4def=paste0( 118 | '+proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 ', 119 | '+b=6370997 +units=m +no_defs' 120 | ), 121 | resolutions = c(65536, 32768, 16384, 8192, 4096, 2048,1024, 512, 256, 128) 122 | ) 123 | ) 124 | ) \%>\% 125 | fitBounds(bounds[1], bounds[2], bounds[3], bounds[4]) \%>\% 126 | setMaxBounds(bounds[1], bounds[2], bounds[3], bounds[4]) \%>\% 127 | mapview::addFeatures( 128 | data=spdf, weight = 1, color = "#000000", 129 | # adding group necessary for identification 130 | layerId = ~iso_3166_2, 131 | fillColor=~pal(pop_2014), 132 | fillOpacity=0.7, 133 | label=~stringr::str_c(name,' ', format(pop_2014, big.mark=",")), 134 | labelOptions= labelOptions(direction = 'auto') 135 | ) 136 | ) 137 | 138 | 139 | # test out selectMap with albers example 140 | selectMap( 141 | lf, 142 | styleFalse = list(weight = 1), 143 | styleTrue = list(weight = 4) 144 | ) 145 | } 146 | } 147 | -------------------------------------------------------------------------------- /man/editMap.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/edit.R 3 | \name{editMap} 4 | \alias{editMap} 5 | \alias{editMap.leaflet} 6 | \alias{editMap.mapview} 7 | \alias{editMap.NULL} 8 | \title{Interactively Edit a Map} 9 | \usage{ 10 | editMap(x, ...) 11 | 12 | \method{editMap}{leaflet}( 13 | x = NULL, 14 | targetLayerId = NULL, 15 | sf = TRUE, 16 | ns = "mapedit-edit", 17 | record = FALSE, 18 | viewer = shiny::paneViewer(), 19 | crs = 4326, 20 | title = "Edit Map", 21 | editor = c("leaflet.extras", "leafpm"), 22 | editorOptions = list(), 23 | ... 24 | ) 25 | 26 | \method{editMap}{mapview}( 27 | x = NULL, 28 | targetLayerId = NULL, 29 | sf = TRUE, 30 | ns = "mapedit-edit", 31 | record = FALSE, 32 | viewer = shiny::paneViewer(), 33 | crs = 4326, 34 | title = "Edit Map", 35 | editor = c("leaflet.extras", "leafpm"), 36 | editorOptions = list(), 37 | ... 38 | ) 39 | 40 | \method{editMap}{`NULL`}(x, editor = c("leaflet.extras", "leafpm"), editorOptions = list(), ...) 41 | } 42 | \arguments{ 43 | \item{x}{\code{leaflet} or \code{mapview} map to edit} 44 | 45 | \item{...}{other arguments for \code{leafem::addFeatures()} when 46 | using \code{editMap.NULL} or \code{selectFeatures}} 47 | 48 | \item{targetLayerId}{\code{string} name of the map layer group to use with edit} 49 | 50 | \item{sf}{\code{logical} return simple features. The default is \code{TRUE}. 51 | If \code{sf = FALSE}, \code{GeoJSON} will be returned.} 52 | 53 | \item{ns}{\code{string} name for the Shiny \code{namespace} to use. The \code{ns} 54 | is unlikely to require a change.} 55 | 56 | \item{record}{\code{logical} to record all edits for future playback.} 57 | 58 | \item{viewer}{\code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 59 | NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 60 | open the app in the default browser, the browser window will automatically 61 | close when closing the app (by pressing "done" or "cancel") in most browsers. 62 | Firefox is an exception. See Details for instructions on how to enable this 63 | behaviour in Firefox.} 64 | 65 | \item{crs}{see \code{\link[sf]{st_crs}}.} 66 | 67 | \item{title}{\code{string} to customize the title of the UI window. The default 68 | is "Edit Map".} 69 | 70 | \item{editor}{\code{character} either "leaflet.extras" or "leafpm"} 71 | 72 | \item{editorOptions}{\code{list} of options suitable for passing to 73 | either \code{leaflet.extras::addDrawToolbar} or 74 | \code{leafpm::addPmToolbar}.} 75 | } 76 | \value{ 77 | \code{sf} simple features or \code{GeoJSON} 78 | } 79 | \description{ 80 | Interactively Edit a Map 81 | } 82 | \details{ 83 | When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 84 | the systems default browser is Firefox, the browser window will likely not 85 | automatically close when the app is closed (by pressing "done" or "cancel"). 86 | To enable automatic closing of tabs/windows in Firefox try the following: 87 | \itemize{ 88 | \item{input "about:config " to your firefox address bar and hit enter} 89 | \item{make sure your "dom.allow_scripts_to_close_windows" is true} 90 | } 91 | } 92 | \examples{ 93 | \dontrun{ 94 | library(leaflet) 95 | library(mapedit) 96 | editMap(leaflet() \%>\% addTiles()) 97 | } 98 | \dontrun{ 99 | # demonstrate Leaflet.Draw on a layer 100 | library(sf) 101 | library(mapview) 102 | library(leaflet.extras) 103 | library(mapedit) 104 | 105 | # ?sf::sf 106 | pol = st_sfc( 107 | st_polygon(list(cbind(c(0,3,3,0,0),c(0,0,3,3,0)))), 108 | crs = 4326 109 | ) 110 | mapview(pol) \%>\% 111 | editMap(targetLayerId = "pol") 112 | 113 | mapview(franconia[1:2,]) \%>\% 114 | editMap(targetLayerId = "franconia[1:2, ]") 115 | } 116 | } 117 | -------------------------------------------------------------------------------- /man/editMod.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/modules.R 3 | \name{editMod} 4 | \alias{editMod} 5 | \title{Shiny Module Server for Geo Create, Edit, Delete} 6 | \usage{ 7 | editMod( 8 | input, 9 | output, 10 | session, 11 | leafmap, 12 | targetLayerId = NULL, 13 | sf = TRUE, 14 | record = FALSE, 15 | crs = 4326, 16 | editor = c("leaflet.extras", "leafpm"), 17 | editorOptions = list() 18 | ) 19 | } 20 | \arguments{ 21 | \item{input}{Shiny server function input} 22 | 23 | \item{output}{Shiny server function output} 24 | 25 | \item{session}{Shiny server function session} 26 | 27 | \item{leafmap}{leaflet map to use for Selection} 28 | 29 | \item{targetLayerId}{\code{character} identifier of layer to edit, delete} 30 | 31 | \item{sf}{\code{logical} to return simple features. \code{sf=FALSE} will return 32 | \code{GeoJSON}.} 33 | 34 | \item{record}{\code{logical} to record all edits for future playback.} 35 | 36 | \item{crs}{see \code{\link[sf]{st_crs}}.} 37 | 38 | \item{editor}{\code{character} either "leaflet.extras" or "leafpm"} 39 | 40 | \item{editorOptions}{\code{list} of options suitable for passing to 41 | either \code{leaflet.extras::addDrawToolbar} or 42 | \code{leafpm::addPmToolbar}.} 43 | } 44 | \value{ 45 | server function for Shiny module 46 | } 47 | \description{ 48 | Shiny Module Server for Geo Create, Edit, Delete 49 | } 50 | -------------------------------------------------------------------------------- /man/editModUI.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/modules.R 3 | \name{editModUI} 4 | \alias{editModUI} 5 | \title{Shiny Module UI for Geo Create, Edit, Delete} 6 | \usage{ 7 | editModUI(id, ...) 8 | } 9 | \arguments{ 10 | \item{id}{\code{character} id for the the Shiny namespace} 11 | 12 | \item{...}{other arguments to \code{leafletOutput()}} 13 | } 14 | \value{ 15 | ui for Shiny module 16 | } 17 | \description{ 18 | Shiny Module UI for Geo Create, Edit, Delete 19 | } 20 | -------------------------------------------------------------------------------- /man/mapedit-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mapedit.R 3 | \docType{package} 4 | \name{mapedit-package} 5 | \alias{mapedit} 6 | \alias{mapedit-package} 7 | \title{mapedit: interactive editing and selection for geospatial data} 8 | \description{ 9 | mapedit, a RConsortium funded project, provides interactive 10 | tools to incorporate in geospatial workflows that require editing or selection 11 | of spatial data. 12 | } 13 | \section{Edit}{ 14 | 15 | \itemize{ 16 | \item{\code{\link{editMap}}} 17 | \item{\code{\link{editFeatures}}} 18 | \item{Shiny edit module \code{\link{editModUI}}, \code{\link{editMod}}} 19 | } 20 | 21 | #' @section Edit: 22 | \itemize{ 23 | \item{\code{\link{selectMap}}} 24 | \item{\code{\link{selectFeatures}}} 25 | \item{Shiny edit module \code{\link{selectModUI}}, \code{\link{selectMod}}} 26 | } 27 | } 28 | 29 | \seealso{ 30 | Useful links: 31 | \itemize{ 32 | \item \url{https://github.com/r-spatial/mapedit} 33 | \item Report bugs at \url{https://github.com/r-spatial/mapedit/issues} 34 | } 35 | 36 | } 37 | \author{ 38 | \strong{Maintainer}: Tim Appelhans \email{tim.appelhans@gmail.com} 39 | 40 | Authors: 41 | \itemize{ 42 | \item Kenton Russell 43 | \item Lorenzo Busetto 44 | } 45 | 46 | Other contributors: 47 | \itemize{ 48 | \item Josh O'Brien [contributor] 49 | \item Jakob Gutschlhofer [contributor] 50 | \item Matt Johnson [contributor] 51 | \item Eli Pousson (\href{https://orcid.org/0000-0001-8280-1706}{ORCID}) [contributor] 52 | } 53 | 54 | } 55 | -------------------------------------------------------------------------------- /man/merge_add.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/merge.R 3 | \name{merge_add} 4 | \alias{merge_add} 5 | \title{Merge 'sf' Adds} 6 | \usage{ 7 | merge_add(orig = NULL, drawn = NULL, by = NULL) 8 | } 9 | \arguments{ 10 | \item{orig}{\code{sf} with the original or source data to which 11 | adds should apply} 12 | 13 | \item{drawn}{\code{sf} with sf data to add to orig} 14 | 15 | \item{by}{not used in merge_add. This argument only exists 16 | for symmetry with the other merge functions.} 17 | } 18 | \description{ 19 | Internal function used with \code{editFeatures} to apply adds or drawn 20 | to a \code{sf} object. 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /man/merge_delete.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/merge.R 3 | \name{merge_delete} 4 | \alias{merge_delete} 5 | \title{Merge 'sf' Deletes} 6 | \usage{ 7 | merge_delete(orig = NULL, deletes = NULL, by = c(id = "layerId")) 8 | } 9 | \arguments{ 10 | \item{orig}{\code{sf} with the original or source data to which 11 | deletes should apply} 12 | 13 | \item{deletes}{\code{sf} with sf data to delete} 14 | 15 | \item{by}{named \code{vector} with the name of the vector representing 16 | the column in orig that we will use to match and the value of 17 | the vector representing the column in deletes that we will 18 | use to match. The argument is intended to work like 19 | the \code{*join} functions in \code{dplyr}. Note, this function 20 | will only use the first name 21 | and first value of the vector for matching.} 22 | } 23 | \description{ 24 | Internal function used with \code{editFeatures} to apply deletes 25 | to a \code{sf} object. 26 | } 27 | \keyword{internal} 28 | -------------------------------------------------------------------------------- /man/merge_edit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/merge.R 3 | \name{merge_edit} 4 | \alias{merge_edit} 5 | \title{Merge 'sf' Edits} 6 | \usage{ 7 | merge_edit(orig = NULL, edits = NULL, by = c(id = "layerId")) 8 | } 9 | \arguments{ 10 | \item{orig}{\code{sf} with the original or source data to which 11 | deletes should apply} 12 | 13 | \item{edits}{\code{sf} with sf data to edit} 14 | 15 | \item{by}{named \code{vector} with the name of the vector representing 16 | the column in orig that we will use to match and the value of 17 | the vector representing the column in edits that we will 18 | use to match. The argument is intended to work like 19 | the \code{*join} functions in \code{dplyr}. Note, this function 20 | will only use the first name 21 | and first value of the vector for matching.} 22 | } 23 | \description{ 24 | Internal function used with \code{editFeatures} to apply edits 25 | to a \code{sf} object. 26 | } 27 | \keyword{internal} 28 | -------------------------------------------------------------------------------- /man/pipe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helpers.R 3 | \name{\%>\%} 4 | \alias{\%>\%} 5 | \title{Pipe operator} 6 | \usage{ 7 | lhs \%>\% rhs 8 | } 9 | \value{ 10 | \code{NULL} (this is the magrittr pipe operator) 11 | } 12 | \description{ 13 | See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/playback.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/playback.R 3 | \name{playback} 4 | \alias{playback} 5 | \title{Playback a Recorded 'mapedit' Session on Leaflet Map} 6 | \usage{ 7 | playback(x, origsf = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{a recorded mapedit session from \code{editFeatures(..., record=TRUE)}} 11 | } 12 | \description{ 13 | Playback a Recorded 'mapedit' Session on Leaflet Map 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/processOpts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/addToolbar.R 3 | \name{processOpts} 4 | \alias{processOpts} 5 | \title{Prepare arguments for addDrawToolbar or addPmToolbar} 6 | \usage{ 7 | processOpts(fun, args) 8 | } 9 | \arguments{ 10 | \item{fun}{Function used by editor package (leafpm or 11 | leaflet.extras) to set defaults} 12 | 13 | \item{args}{Either a (possibly nested) list of named options of 14 | the form suitable for passage to \code{fun} or (if the chosen 15 | editor is \code{"leaflet.extras"}) \code{FALSE}.} 16 | } 17 | \value{ 18 | An object suitable for passing in as the supplied argument 19 | to either \code{leaflet.extras::addDrawToolbar} or 20 | \code{leafpm::addPmToolbar}. 21 | } 22 | \description{ 23 | Prepare arguments for addDrawToolbar or addPmToolbar 24 | } 25 | -------------------------------------------------------------------------------- /man/selectFeatures.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/select.R 3 | \name{selectFeatures} 4 | \alias{selectFeatures} 5 | \alias{selectFeatures.sf} 6 | \alias{selectFeatures.Spatial} 7 | \title{Interactively Select Map Features} 8 | \usage{ 9 | selectFeatures(x, ...) 10 | 11 | \method{selectFeatures}{sf}( 12 | x = NULL, 13 | mode = c("click", "draw"), 14 | op = sf::st_intersects, 15 | map = NULL, 16 | index = FALSE, 17 | viewer = shiny::paneViewer(), 18 | label = NULL, 19 | title = "Select features", 20 | ... 21 | ) 22 | 23 | \method{selectFeatures}{Spatial}(x, ...) 24 | } 25 | \arguments{ 26 | \item{x}{features to select} 27 | 28 | \item{...}{other arguments} 29 | 30 | \item{mode}{one of "click" or "draw".} 31 | 32 | \item{op}{the geometric binary predicate to use for the selection. 33 | Can be any of \code{sf::geos_binary_pred}. In the spatial 34 | operation the drawn features will be evaluated as x and the supplied 35 | feature as y. Ignored if \code{mode = "click"}.} 36 | 37 | \item{map}{a background \code{leaflet} or \code{mapview} map 38 | to be used for editing. If \code{NULL} a blank 39 | mapview canvas will be provided.} 40 | 41 | \item{index}{\code{logical} with \code{index=TRUE} indicating return 42 | the index of selected features rather than the actual 43 | selected features} 44 | 45 | \item{viewer}{\code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 46 | NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 47 | open the app in the default browser, the browser window will automatically 48 | close when closing the app (by pressing "done" or "cancel") in most browsers. 49 | Firefox is an exception. See Details for instructions on how to enable this 50 | behaviour in Firefox.} 51 | 52 | \item{label}{\code{character} vector or \code{formula} for the 53 | content that will appear in label/tooltip.} 54 | 55 | \item{title}{\code{string} to customize the title of the UI window. The default 56 | is "Select features".} 57 | } 58 | \description{ 59 | Interactively Select Map Features 60 | } 61 | \details{ 62 | When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 63 | the systems default browser is Firefox, the browser window will likely not 64 | automatically close when the app is closed (by pressing "done" or "cancel"). 65 | To enable automatic closing of tabs/windows in Firefox try the following: 66 | \itemize{ 67 | \item{input "about:config " to your firefox address bar and hit enter} 68 | \item{make sure your "dom.allow_scripts_to_close_windows" is true} 69 | } 70 | } 71 | \examples{ 72 | \dontrun{ 73 | library(mapedit) 74 | library(mapview) 75 | 76 | lf <- mapview() 77 | 78 | # draw some polygons that we will select later 79 | drawing <- lf \%>\% 80 | editMap() 81 | 82 | # little easier now with sf 83 | mapview(drawing$finished) 84 | 85 | # especially easy with selectFeatures 86 | selectFeatures(drawing$finished) 87 | 88 | 89 | # use @bhaskarvk USA Albers with leaflet code 90 | # https://bhaskarvk.github.io/leaflet/examples/proj4Leaflet.html 91 | #devtools::install_github("hrbrmstr/albersusa") 92 | library(albersusa) 93 | library(sf) 94 | library(leaflet) 95 | library(mapedit) 96 | 97 | spdf <- usa_sf() 98 | pal <- colorNumeric( 99 | palette = "Blues", 100 | domain = spdf$pop_2014 101 | ) 102 | 103 | bounds <- c(-125, 24 ,-75, 45) 104 | 105 | (lf <- leaflet( 106 | options= 107 | leafletOptions( 108 | worldCopyJump = FALSE, 109 | crs=leafletCRS( 110 | crsClass="L.Proj.CRS", 111 | code='EPSG:2163', 112 | proj4def=paste0( 113 | '+proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 ', 114 | '+b=6370997 +units=m +no_defs' 115 | ), 116 | resolutions = c(65536, 32768, 16384, 8192, 4096, 2048,1024, 512, 256, 128) 117 | ) 118 | ) 119 | ) \%>\% 120 | fitBounds(bounds[1], bounds[2], bounds[3], bounds[4]) \%>\% 121 | setMaxBounds(bounds[1], bounds[2], bounds[3], bounds[4]) \%>\% 122 | mapview::addFeatures( 123 | data=spdf, weight = 1, color = "#000000", 124 | # adding group necessary for identification 125 | layerId = ~iso_3166_2, 126 | fillColor=~pal(pop_2014), 127 | fillOpacity=0.7, 128 | label=~stringr::str_c(name,' ', format(pop_2014, big.mark=",")), 129 | labelOptions= labelOptions(direction = 'auto') 130 | ) 131 | ) 132 | 133 | 134 | # test out selectMap with albers example 135 | selectMap( 136 | lf, 137 | styleFalse = list(weight = 1), 138 | styleTrue = list(weight = 4) 139 | ) 140 | } 141 | } 142 | -------------------------------------------------------------------------------- /man/selectMap.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/query.R 3 | \name{selectMap} 4 | \alias{selectMap} 5 | \alias{selectMap.leaflet} 6 | \title{Interactively Select Map Features} 7 | \usage{ 8 | selectMap(x, ...) 9 | 10 | \method{selectMap}{leaflet}( 11 | x = NULL, 12 | styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4), 13 | styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7), 14 | ns = "mapedit-select", 15 | viewer = shiny::paneViewer(), 16 | title = "Select features", 17 | ... 18 | ) 19 | } 20 | \arguments{ 21 | \item{x}{\code{leaflet} or \code{mapview} map to use for selection} 22 | 23 | \item{...}{other arguments} 24 | 25 | \item{styleFalse, styleTrue}{names \code{list} of CSS styles used 26 | for selected (\code{styleTrue}) and deselected (\code{styleFalse})} 27 | 28 | \item{ns}{\code{string} name for the Shiny \code{namespace} to use. The \code{ns} 29 | is unlikely to require a change.} 30 | 31 | \item{viewer}{\code{function} for the viewer. See Shiny \code{\link[shiny]{viewer}}. 32 | NOTE: when using \code{browserViewer(browser = getOption("browser"))} to 33 | open the app in the default browser, the browser window will automatically 34 | close when closing the app (by pressing "done" or "cancel") in most browsers. 35 | Firefox is an exception. See Details for instructions on how to enable this 36 | behaviour in Firefox.} 37 | 38 | \item{title}{\code{string} to customize the title of the UI window. The default 39 | is "Select features".} 40 | } 41 | \description{ 42 | Interactively Select Map Features 43 | } 44 | \details{ 45 | When setting \code{viewer = browserViewer(browser = getOption("browser"))} and 46 | the systems default browser is Firefox, the browser window will likely not 47 | automatically close when the app is closed (by pressing "done" or "cancel"). 48 | To enable automatic closing of tabs/windows in Firefox try the following: 49 | \itemize{ 50 | \item{input "about:config " to your firefox address bar and hit enter} 51 | \item{make sure your "dom.allow_scripts_to_close_windows" is true} 52 | } 53 | } 54 | \examples{ 55 | \dontrun{ 56 | library(mapedit) 57 | library(mapview) 58 | 59 | lf <- mapview() 60 | 61 | # draw some polygons that we will select later 62 | drawing <- lf \%>\% 63 | editMap() 64 | 65 | # little easier now with sf 66 | mapview(drawing$finished) 67 | 68 | # especially easy with selectFeatures 69 | selectFeatures(drawing$finished) 70 | 71 | 72 | # use @bhaskarvk USA Albers with leaflet code 73 | # https://bhaskarvk.github.io/leaflet/examples/proj4Leaflet.html 74 | #devtools::install_github("hrbrmstr/albersusa") 75 | library(albersusa) 76 | library(sf) 77 | library(leaflet) 78 | library(mapedit) 79 | 80 | spdf <- usa_sf() 81 | pal <- colorNumeric( 82 | palette = "Blues", 83 | domain = spdf$pop_2014 84 | ) 85 | 86 | bounds <- c(-125, 24 ,-75, 45) 87 | 88 | (lf <- leaflet( 89 | options= 90 | leafletOptions( 91 | worldCopyJump = FALSE, 92 | crs=leafletCRS( 93 | crsClass="L.Proj.CRS", 94 | code='EPSG:2163', 95 | proj4def=paste0( 96 | '+proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 ', 97 | '+b=6370997 +units=m +no_defs' 98 | ), 99 | resolutions = c(65536, 32768, 16384, 8192, 4096, 2048,1024, 512, 256, 128) 100 | ) 101 | ) 102 | ) \%>\% 103 | fitBounds(bounds[1], bounds[2], bounds[3], bounds[4]) \%>\% 104 | setMaxBounds(bounds[1], bounds[2], bounds[3], bounds[4]) \%>\% 105 | mapview::addFeatures( 106 | data=spdf, weight = 1, color = "#000000", 107 | # adding group necessary for identification 108 | layerId = ~iso_3166_2, 109 | fillColor=~pal(pop_2014), 110 | fillOpacity=0.7, 111 | label=~stringr::str_c(name,' ', format(pop_2014, big.mark=",")), 112 | labelOptions= labelOptions(direction = 'auto') 113 | ) 114 | ) 115 | 116 | 117 | # test out selectMap with albers example 118 | selectMap( 119 | lf, 120 | styleFalse = list(weight = 1), 121 | styleTrue = list(weight = 4) 122 | ) 123 | } 124 | } 125 | -------------------------------------------------------------------------------- /man/selectMod.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/modules.R 3 | \name{selectMod} 4 | \alias{selectMod} 5 | \title{Shiny Module Server for Geo Selection} 6 | \usage{ 7 | selectMod( 8 | input, 9 | output, 10 | session, 11 | leafmap, 12 | styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4), 13 | styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7) 14 | ) 15 | } 16 | \arguments{ 17 | \item{input}{Shiny server function input} 18 | 19 | \item{output}{Shiny server function output} 20 | 21 | \item{session}{Shiny server function session} 22 | 23 | \item{leafmap}{leaflet map to use for Selection} 24 | 25 | \item{styleFalse}{named \code{list} of valid \code{CSS} for non-selected features} 26 | 27 | \item{styleTrue}{named \code{list} of valid \code{CSS} for selected features} 28 | } 29 | \value{ 30 | server function for Shiny module 31 | } 32 | \description{ 33 | Shiny Module Server for Geo Selection 34 | } 35 | -------------------------------------------------------------------------------- /man/selectModUI.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/modules.R 3 | \name{selectModUI} 4 | \alias{selectModUI} 5 | \title{Shiny Module UI for Geo Selection} 6 | \usage{ 7 | selectModUI(id, ...) 8 | } 9 | \arguments{ 10 | \item{id}{\code{character} id for the the Shiny namespace} 11 | 12 | \item{...}{other arguments to \code{leafletOutput()}} 13 | } 14 | \value{ 15 | ui for Shiny module 16 | } 17 | \description{ 18 | Shiny Module UI for Geo Selection 19 | } 20 | -------------------------------------------------------------------------------- /mapedit.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | ProjectId: 8daccbf2-6aa3-4f67-a3f6-c98559a9c117 3 | 4 | RestoreWorkspace: No 5 | SaveWorkspace: No 6 | AlwaysSaveHistory: Default 7 | 8 | EnableCodeIndexing: Yes 9 | UseSpacesForTab: Yes 10 | NumSpacesForTab: 2 11 | Encoding: UTF-8 12 | 13 | RnwWeave: Sweave 14 | LaTeX: pdfLaTeX 15 | 16 | AutoAppendNewline: Yes 17 | StripTrailingWhitespace: Yes 18 | 19 | BuildType: Package 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageBuildArgs: --no-manual 22 | PackageCheckArgs: --as-cran 23 | PackageRoxygenize: rd,collate,namespace 24 | --------------------------------------------------------------------------------