From 34facab288581ee254480a957cb8005d5137ec28 Mon Sep 17 00:00:00 2001 From: Sebastian Gatscha Date: Tue, 3 Sep 2024 01:52:43 +0200 Subject: [PATCH] add test, docs --- R/divicon.R | 8 +- R/layergroupcollision.R | 62 +++++--- inst/examples/layergroupcollision_app.R | 52 ++----- .../layergroup-binding.js | 143 ++---------------- man/LayerroupCollision.Rd | 76 +++++----- man/addDivicon.Rd | 10 +- tests/testthat/test-layergroupcollision.R | 95 ++++++++++++ 7 files changed, 212 insertions(+), 234 deletions(-) create mode 100644 tests/testthat/test-layergroupcollision.R diff --git a/R/divicon.R b/R/divicon.R index 0f1daa3..d785ef6 100644 --- a/R/divicon.R +++ b/R/divicon.R @@ -17,13 +17,11 @@ diviconDependency <- function() { #' for latitude and longitude coordinates. It allows for the application of custom HTML #' content and CSS classes to each marker, providing high flexibility in marker design. #' -#' @param map The Leaflet map object to which the DivIcon markers will be added. #' @inheritParams leaflet::addAwesomeMarkers -#' @param className A single CSS class or a vector of CSS classes to apply to the DivIcon markers. -#' @param html A single HTML string or a vector of HTML strings to display within the DivIcon markers. +#' @param className A single CSS class or a vector of CSS classes. +#' @param html A single HTML string or a vector of HTML strings. #' @param divOptions A list of extra options for Leaflet DivIcon. -#' @param options A list of extra options for the markers. -#' See \code{\link[leaflet]{markerOptions}} for more details. +#' #' @family DivIcon Functions #' @return The modified Leaflet map object. #' @export diff --git a/R/layergroupcollision.R b/R/layergroupcollision.R index 152a57c..37a33cd 100644 --- a/R/layergroupcollision.R +++ b/R/layergroupcollision.R @@ -12,30 +12,60 @@ layergroupCollisionDependency <- function() { ) } -#' Add LayerroupCollision Plugin -#' Needs data to be ordered, as frst elements will have priority. -#' @return A leaflet map object +#' Add LayerGroup Collision Plugin to Leaflet Map +#' +#' @description Integrates the LayerGroup Collision plugin into a Leaflet map, +#' which hides overlapping markers and only displays the first added marker in a +#' collision group. Markers must be static; dynamic changes, dragging, and +#' deletions are not supported. + +#' The function transforms spatial data into GeoJSON format and uses `L.DivIcon`, +#' allowing you to pass HTML content and CSS classes to style the markers. +#' +#' @param group the name of the group. It needs to be single string. +#' @return A leaflet map object with the LayerGroup Collision plugin added. #' @export #' -#' @inheritParams leaflet::addAwesomeMarkers -#' @references \url{https://github.com/Geovation/labelgun} +#' @inheritParams addDivicon +#' @references \url{https://github.com/MazeMap/Leaflet.LayerGroup.Collision} #' #' @name LayerroupCollision +#' @examples +#' library(leaflet) +#' library(sf) +#' library(leaflet.extras2) +#' +#' df <- sf::st_as_sf(atlStorms2005) +#' df <- suppressWarnings(st_cast(df, "POINT")) +#' df <- df[sample(1:nrow(df), 150, replace = F),] +#' df$classes = sample(x = 1:5, nrow(df), replace = TRUE) +#' +#' leaflet() %>% +#' addProviderTiles("CartoDB.Positron") %>% +#' leaflet::addLayersControl(overlayGroups = c("Labels")) %>% +#' addLayerGroupCollision(data = df +#' , html = ~paste0( +#' '
', +#' '
', Name, '
', +#' '
MaxWind: ', MaxWind, '
', +#' '
' +#' ) +#' , className = ~paste0("my-label my-label-", classes) +#' , group = "Labels" +#' ) addLayerGroupCollision <- function( - map, layerId = NULL, group = NULL, - popup = NULL, popupOptions = NULL, label = NULL, - labelOptions = NULL, + map, group = NULL, className = NULL, html = NULL, - options = markerOptions(), - margin = 5, data = getMapData(map) -) { + margin = 5, data = getMapData(map)) { map$dependencies <- c(map$dependencies, layergroupCollisionDependency()) - ## Make Geojson ########### + ## Make Geojson and Assign Class & HTML columns ########### if (!inherits(data, "sf")) { data <- sf::st_as_sf(data) } + data$className__ <- evalFormula(className, data) + data$html__ <- evalFormula(html, data) geojson <- yyjsonr::write_geojson_str(data) class(geojson) <- c("geojson", "json") @@ -45,12 +75,8 @@ addLayerGroupCollision <- function( "addLayerGroupCollision" ) invokeMethod( - map, data, "addLayerGroupCollision", geojson, - layerId, group, options, - className, html, - popup, popupOptions, - label, labelOptions, - margin + map, NULL, "addLayerGroupCollision", + geojson, group, margin ) %>% expandLimits(pts$lat, pts$lng) } diff --git a/inst/examples/layergroupcollision_app.R b/inst/examples/layergroupcollision_app.R index 811f360..8eb7d2d 100644 --- a/inst/examples/layergroupcollision_app.R +++ b/inst/examples/layergroupcollision_app.R @@ -4,46 +4,29 @@ library(sf) library(leaflet.extras2) options("shiny.autoreload" = TRUE) -# data <- sf::st_as_sf(breweries91) -# data <- sf::st_as_sf(mapview::trails[1:100,]) -# data <- st_transform(data, 4326) -# data <- st_cast(data, "POINT") -# data <- data[1:300,] - df <- sf::st_as_sf(atlStorms2005) df <- suppressWarnings(st_cast(df, "POINT")) df <- df[sample(1:nrow(df), 150, replace = F),] -# df$classes = sample(x = c("myclass1","myclass2","myclass3"), nrow(df), replace = TRUE) -df$classes = sample(x = 1:10, nrow(df), replace = TRUE) -df$ID <- paste0("ID_", 1:nrow(df)) -df$scalerank <- sample(x = 1:10, nrow(df), replace = TRUE) +df$classes = sample(x = 1:5, nrow(df), replace = TRUE) ## Ordering is important -df <- df[order(df$scalerank, decreasing = FALSE),] +df <- df[order(df$classes, decreasing = FALSE),] ui <- fluidPage( ## CSS-style ############ tags$head(tags$style(" - .city-label { + .my-label { background: white; border: 1px solid #888; position: relative; display: inline-block; white-space: nowrap; } - - .city-label-0 { font-size: 30px; top: -27px; } - .city-label-1 { font-size: 25px; top: -26px; } - .city-label-2 { font-size: 24px; top: -25px; } - .city-label-3 { font-size: 22px; top: -24px; } - .city-label-4 { font-size: 16px; top: -23px; } - .city-label-5 { font-size: 15px; top: -22px; } - .city-label-6 { font-size: 14px; top: -21px; } - .city-label-7 { font-size: 13px; top: -20px; } - .city-label-8 { font-size: 12px; top: -19px; } - .city-label-9 { font-size: 11px; top: -18px; } - .city-label-10{ font-size: 10px; top: -17px; } - + .my-label-1 { font-size: 28px; background-color: red; top: -26px; } + .my-label-2 { font-size: 24px; background-color: orange; top: -25px; } + .my-label-3 { font-size: 22px; background-color: yellow; top: -24px; } + .my-label-4 { font-size: 16px; background-color: green; top: -23px; } + .my-label-5 { font-size: 15px; background-color: lightgreen; top: -22px; } ")), leafletOutput("map", height = 800) ) @@ -53,25 +36,16 @@ server <- function(input, output, session) { output$map <- renderLeaflet({ leaflet() %>% addProviderTiles("CartoDB.Positron") %>% - leaflet::addLayersControl(overlayGroups = c("Divicons","markers")) %>% - # addMarkers(data = df, label = ~Name, - # , group = "markers") %>% + leaflet::addLayersControl(overlayGroups = c("Labels")) %>% addLayerGroupCollision(data = df , html = ~paste0( '
', - '
', Name, '
', - '
MaxWind: ', MaxWind, '
', + '
', Name, '
', + '
MaxWind: ', MaxWind, '
', '
' ) - , className = ~paste0("city-label city-label-", classes) - , label = ~Name - , layerId = ~ID - , group = "Divicons" - , popup = ~paste("ID: ", ID, "
", - "Name: ", Name, "
", - "MaxWind:", MaxWind, "
", - "MinPress:", MinPress) - , options = markerOptions(draggable = TRUE) + , className = ~paste0("my-label my-label-", classes) + , group = "Labels" ) }) diff --git a/inst/htmlwidgets/lfx-layergroupcollision/layergroup-binding.js b/inst/htmlwidgets/lfx-layergroupcollision/layergroup-binding.js index 072c13c..34dddb1 100644 --- a/inst/htmlwidgets/lfx-layergroupcollision/layergroup-binding.js +++ b/inst/htmlwidgets/lfx-layergroupcollision/layergroup-binding.js @@ -1,139 +1,28 @@ /* global LeafletWidget, $, L, Shiny, HTMLWidgets */ LeafletWidget.methods.addLayerGroupCollision = function( - data, layerId, group, options, - className, html, popup, popupOptions, - label, labelOptions, margin) { - + data, group, margin) { var collisionLayer = L.LayerGroup.collision({margin: margin}); - console.log("collisionLayer"); console.log(collisionLayer) - // Manually parse the GeoJSON and create the L.Markers one by one - // Note that 'cities' is defined in the natural earth data files. - console.log("data"); console.log(data) for (var i=0; i < data.features.length; i++) { - var feat = data.features[i]; - var labelClass = 'city-label city-label-' + feat.properties.strklasse_numeric; -// Note that the markers are not interactive because MSIE on a WinPhone will take *ages* -// to run addEventListener() on them. - var marker = L.marker(L.GeoJSON.coordsToLatLng(feat.geometry.coordinates), { - icon: L.divIcon({ - html: - "" + - feat.properties.strnummer + - "" - }) - ,interactive: false // Post-0.7.3 - ,clickable: false // 0.7.3 - }); + // Note that the markers are not interactive because MSIE on a WinPhone will take *ages* + // to run addEventListener() on them. + var marker = new L.marker( + L.GeoJSON.coordsToLatLng(feat.geometry.coordinates), { + icon: L.divIcon({ + html: + "" + + feat.properties["html__"] + + "" + }) + , interactive: false // Post-0.7.3 + , clickable: false // 0.7.3 + }); + collisionLayer.addLayer(marker); } - collisionLayer.addTo(this); + this.layerManager.addLayer(collisionLayer, "collison", null, group); }; -/* -(function() { - var collisionLayer = L.LayerGroup.collision({margin:5}); - - // Make a Dataframe - let df = new LeafletWidget.DataFrame() - .col("lat", lat) - .col("lng", lng) - .col("layerId", layerId) - .col("group", group) - .col("popup", popup) - .col("popupOptions", popupOptions) - .col("label", label) - .col("labelOptions", labelOptions) - .col("className", className) - .col("html", html) - .cbind(options) - .cbind(crosstalkOptions || {}); - - // Add Cluster - let clusterGroup = this.layerManager.getLayer("cluster", clusterId), - cluster = clusterOptions !== null; - if (cluster && !clusterGroup) { - clusterGroup = L.markerClusterGroup.layerSupport(clusterOptions); - if(clusterOptions.freezeAtZoom) { - let freezeAtZoom = clusterOptions.freezeAtZoom; - delete clusterOptions.freezeAtZoom; - clusterGroup.freezeAtZoom(freezeAtZoom); - } - clusterGroup.clusterLayerStore = new LeafletWidget.ClusterLayerStore(clusterGroup); - } - let extraInfo = cluster ? { clusterId: clusterId } : {}; - - for (let i = 0; i < df.nrow(); i++) { - if($.isNumeric(df.get(i, "lat")) && $.isNumeric(df.get(i, "lng"))) { - (function() { - - let thisId = df.get(i, "layerId"); - let thisGroup = cluster ? null : df.get(i, "group"); - - // Create a new marker with DivIcon - var divIconOptions = Object.assign({}, divOptions, { - className: df.get(i, "className"), - html: df.get(i, "html") - }); - var divmarker = new L.Marker( - [df.get(i, "lat"), df.get(i, "lng")], - Object.assign({}, options, { - icon: new L.DivIcon(divIconOptions) - })); - - collisionLayer.addLayer(divmarker); - - if (cluster) { - clusterGroup.clusterLayerStore.add(divmarker, thisId); - } else { - this.layerManager.addLayer(divmarker, "marker", thisId, thisGroup, df.get(i, "ctGroup", true), df.get(i, "ctKey", true)); - } - - // Bind popup to the marker if popup content is provided - let popup = df.get(i, "popup"); - let popupOptions = df.get(i, "popupOptions"); - if (popup !== null) { - if (popupOptions !== null){ - divmarker.bindPopup(popup, popupOptions); - } else { - divmarker.bindPopup(popup); - } - } - - // Assign label (tooltip) to marker if label content is provided - let label = df.get(i, "label"); - let labelOptions = df.get(i, "labelOptions"); - if (label !== null) { - if (labelOptions !== null) { - if(labelOptions.permanent) { - divmarker.bindTooltip(label, labelOptions).openTooltip(); - } else { - divmarker.bindTooltip(label, labelOptions); - } - } else { - divmarker.bindTooltip(label); - } - } - - // Add the marker to the map's layer manager - this.layerManager.addLayer(divmarker, "marker", thisId, thisGroup); - - // Add Listener - divmarker.on("click", LeafletWidget.methods.mouseHandler(this.id, thisId, thisGroup, "marker_click", extraInfo), this); - divmarker.on("mouseover", LeafletWidget.methods.mouseHandler(this.id, thisId, thisGroup, "marker_mouseover", extraInfo), this); - divmarker.on("mouseout", LeafletWidget.methods.mouseHandler(this.id, thisId, thisGroup, "marker_mouseout", extraInfo), this); - divmarker.on("dragend", LeafletWidget.methods.mouseHandler(this.id, thisId, thisGroup, "marker_dragend", extraInfo), this); - - }).call(this); - } - } - if (cluster) { - this.layerManager.addLayer(clusterGroup, "cluster", clusterId, group); - } - collisionLayer.addTo(this); - }).call(this); - -*/ diff --git a/man/LayerroupCollision.Rd b/man/LayerroupCollision.Rd index 7e462c6..cf3e34e 100644 --- a/man/LayerroupCollision.Rd +++ b/man/LayerroupCollision.Rd @@ -3,22 +3,13 @@ \name{LayerroupCollision} \alias{LayerroupCollision} \alias{addLayerGroupCollision} -\title{Add LayerroupCollision Plugin -Needs data to be ordered, as frst elements will have priority.} +\title{Add LayerGroup Collision Plugin to Leaflet Map} \usage{ addLayerGroupCollision( map, - layerId = NULL, group = NULL, - popup = NULL, - popupOptions = NULL, - label = NULL, - labelOptions = NULL, className = NULL, html = NULL, - options = markerOptions(), - clusterOptions = NULL, - clusterId = NULL, margin = 5, data = getMapData(map) ) @@ -26,46 +17,51 @@ addLayerGroupCollision( \arguments{ \item{map}{the map to add awesome Markers to.} -\item{layerId}{the layer id} +\item{group}{the name of the group. It needs to be single string.} -\item{group}{the name of the group the newly created layers should belong to -(for \code{\link[leaflet]{clearGroup}} and \code{\link[leaflet]{addLayersControl}} purposes). -Human-friendly group names are permitted--they need not be short, -identifier-style names. Any number of layers and even different types of -layers (e.g. markers and polygons) can share the same group name.} +\item{className}{A single CSS class or a vector of CSS classes.} -\item{popup}{a character vector of the HTML content for the popups (you are -recommended to escape the text using \code{\link[htmltools]{htmlEscape}()} -for security reasons)} - -\item{popupOptions}{A Vector of \code{\link[leaflet]{popupOptions}} to provide popups} - -\item{label}{a character vector of the HTML content for the labels} - -\item{labelOptions}{A Vector of \code{\link[leaflet]{labelOptions}} to provide label -options for each label. Default \code{NULL}} - -\item{options}{a list of extra options for tile layers, popups, paths -(circles, rectangles, polygons, ...), or other map elements} - -\item{clusterOptions}{if not \code{NULL}, markers will be clustered using -\href{https://github.com/Leaflet/Leaflet.markercluster}{Leaflet.markercluster}; - you can use \code{\link[leaflet]{markerClusterOptions}()} to specify marker cluster -options} - -\item{clusterId}{the id for the marker cluster layer} +\item{html}{A single HTML string or a vector of HTML strings.} \item{data}{the data object from which the argument values are derived; by default, it is the \code{data} object provided to \code{leaflet()} initially, but can be overridden} } \value{ -A leaflet map object +A leaflet map object with the LayerGroup Collision plugin added. } \description{ -Add LayerroupCollision Plugin -Needs data to be ordered, as frst elements will have priority. +Integrates the LayerGroup Collision plugin into a Leaflet map, +which hides overlapping markers and only displays the first added marker in a +collision group. Markers must be static; dynamic changes, dragging, and +deletions are not supported. +The function transforms spatial data into GeoJSON format and uses `L.DivIcon`, +allowing you to pass HTML content and CSS classes to style the markers. +} +\examples{ +library(leaflet) +library(sf) +library(leaflet.extras2) + +df <- sf::st_as_sf(atlStorms2005) +df <- suppressWarnings(st_cast(df, "POINT")) +df <- df[sample(1:nrow(df), 150, replace = F),] +df$classes = sample(x = 1:5, nrow(df), replace = TRUE) + +leaflet() \%>\% + addProviderTiles("CartoDB.Positron") \%>\% + leaflet::addLayersControl(overlayGroups = c("Labels")) \%>\% + addLayerGroupCollision(data = df + , html = ~paste0( + '
', + '
', Name, '
', + '
MaxWind: ', MaxWind, '
', + '
' + ) + , className = ~paste0("my-label my-label-", classes) + , group = "Labels" + ) } \references{ -\url{https://github.com/Geovation/labelgun} +\url{https://github.com/MazeMap/Leaflet.LayerGroup.Collision} } diff --git a/man/addDivicon.Rd b/man/addDivicon.Rd index 32f7c1d..ef22b11 100644 --- a/man/addDivicon.Rd +++ b/man/addDivicon.Rd @@ -24,7 +24,7 @@ addDivicon( ) } \arguments{ -\item{map}{The Leaflet map object to which the DivIcon markers will be added.} +\item{map}{the map to add awesome Markers to.} \item{lng}{a numeric vector of longitudes, or a one-sided formula of the form \code{~x} where \code{x} is a variable in \code{data}; by default (if not @@ -55,12 +55,12 @@ for security reasons)} \item{labelOptions}{A Vector of \code{\link[leaflet]{labelOptions}} to provide label options for each label. Default \code{NULL}} -\item{className}{A single CSS class or a vector of CSS classes to apply to the DivIcon markers.} +\item{className}{A single CSS class or a vector of CSS classes.} -\item{html}{A single HTML string or a vector of HTML strings to display within the DivIcon markers.} +\item{html}{A single HTML string or a vector of HTML strings.} -\item{options}{A list of extra options for the markers. -See \code{\link[leaflet]{markerOptions}} for more details.} +\item{options}{a list of extra options for tile layers, popups, paths +(circles, rectangles, polygons, ...), or other map elements} \item{clusterOptions}{if not \code{NULL}, markers will be clustered using \href{https://github.com/Leaflet/Leaflet.markercluster}{Leaflet.markercluster}; diff --git a/tests/testthat/test-layergroupcollision.R b/tests/testthat/test-layergroupcollision.R new file mode 100644 index 0000000..b6272ac --- /dev/null +++ b/tests/testthat/test-layergroupcollision.R @@ -0,0 +1,95 @@ +library(testthat) +library(sf) +library(leaflet) + +# Sample data for testing +df <- sf::st_as_sf(atlStorms2005) +df <- suppressWarnings(st_cast(df, "POINT")) +df <- df[sample(1:nrow(df), 50, replace = FALSE), ] +df$classes <- sample(x = c("myclass1", "myclass2", "myclass3"), + nrow(df), replace = TRUE) +df$ID <- paste0("ID_", 1:nrow(df)) +df$lon <- st_coordinates(df)[, 1] +df$lat <- st_coordinates(df)[, 2] + +# Function to generate map object for reuse in tests +generate_test_map <- function() { + leaflet() %>% + addTiles() +} + +# Test 1: Basic functionality of addLayerGroupCollision +test_that("addLayerGroupCollision works", { + map <- generate_test_map() %>% + addLayerGroupCollision( + data = df, + group = "Myclass", + className = ~ paste("class", classes), + html = ~ paste0("
", ID, "
") + ) + + expect_is(map, "leaflet") + expect_true(any(sapply(map$dependencies, + function(dep) dep$name == "lfx-layergroupcollision"))) + expect_length(map$dependencies[[length(map$dependencies)]]$script, 3) + expect_identical(map$x$calls[[2]]$method, "addLayerGroupCollision") + expect_is(map$x$calls[[2]]$args[[1]], "geojson") + expect_identical(map$x$calls[[2]]$args[[2]], "Myclass") + expect_identical(map$x$calls[[2]]$args[[3]], 5) # Default margin +}) + +# Test 2: Handling of custom margin +test_that("addLayerGroupCollision handles custom margin", { + map <- generate_test_map() %>% + addLayerGroupCollision( + data = df, + margin = 10 + ) + + expect_is(map, "leaflet") + expect_identical(map$x$calls[[2]]$method, "addLayerGroupCollision") + expect_identical(map$x$calls[[2]]$args[[3]], 10) # Custom margin +}) + +# Test 3: Adding HTML and className with custom values +test_that("addLayerGroupCollision assigns HTML and className correctly", { + map <- generate_test_map() %>% + addLayerGroupCollision( + data = df, + className = ~ paste("myclass", classes), + html = ~ paste0("
", ID, "
") + ) + + expect_is(map, "leaflet") + expect_identical(map$x$calls[[2]]$method, "addLayerGroupCollision") + expect_null(map$x$calls[[2]]$args[[2]]) + expect_identical(map$x$calls[[2]]$args[[3]], 5) +}) + +# Test 4: Verifying map data transformation to GeoJSON +test_that("addLayerGroupCollision transforms spatial data to GeoJSON", { + map <- generate_test_map() %>% + addLayerGroupCollision( + data = df + ) + + geojson <- map$x$calls[[2]]$args[[1]] + expect_true(inherits(geojson, "geojson")) +}) + +# Test 5: Error handling for invalid data +test_that("addLayerGroupCollision handles invalid data gracefully", { + expect_error({ + map <- generate_test_map() %>% + addLayerGroupCollision( + data = NULL + ) + }) + + expect_error({ + map <- generate_test_map() %>% + addLayerGroupCollision( + data = data.frame() + ) + }) +})