Merge pull request #70 from trafficonese/divicon

Divicon
trafficonese · Sep 1, 2024 · 12d9dea · 12d9dea
2 parents b3f2b86 + 6d352f6
commit 12d9dea
Show file tree

Hide file tree

Showing 9 changed files with 656 additions and 1 deletion.
diff --git a/NAMESPACE b/NAMESPACE
@@ -5,6 +5,7 @@ export(addAntpath)
 export(addArrowhead)
 export(addClusterCharts)
 export(addContextmenu)
+export(addDivicon)
 export(addEasyprint)
 export(addGIBS)
 export(addHeightgraph)

diff --git a/NEWS.md b/NEWS.md
@@ -3,11 +3,11 @@
 * Fix for roxygen2 > 7.0.0. #1491
 * The opened sidebar tab is returned as Shiny input using the `sidebar_tabs` ID.
 * allow `...` in `antpathOptions` to be able to set the pane (e.g.: `renderer= JS('L.svg({pane: "my-pane"})')`)
+* New Function `addDivicon` adds `DivIcon` markers to Leaflet maps with support for custom HTML and CSS classes. See the example in `./inst/examples/divicons_html_app.R`
 * Added custom `clusterCharts` using `Leaflet.markercluster` and `d3` for piechart and barcharts.
 * Added `addClusterCharts` to enable **pie** and **bar** charts in Marker clusters using `Leaflet.markercluster`, `d3` and `L.DivIcon`, with support for customizable category styling and various aggregation methods like **sum, min, max, mean**, and **median**.
 * Switched from `geojsonsf` to `yyjsonr` (*heightgraph*, *timeslider*, *clustercharts*)
 
-
 # leaflet.extras2 1.2.2
 
 * Added `enableContextmenu` and `disableContextmenu`

diff --git a/R/divicon.R b/R/divicon.R
@@ -0,0 +1,89 @@
+diviconDependency <- function() {
+  list(
+    htmltools::htmlDependency(
+      "lfx-divicon", version = "1.0.0",
+      src = system.file("htmlwidgets/lfx-divicon", package = "leaflet.extras2"),
+      script = "lfx-divicon-bindings.js",
+      all_files = TRUE
+    )
+  )
+}
+
+#' Add DivIcon Markers to a Leaflet Map
+#'
+#' Adds customizable DivIcon markers to a Leaflet map. The function can accept either spatial
+#' data (lines or points) in the form of a Simple Feature (sf) object or numeric vectors
+#' 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 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
+#' @examples
+#' library(sf)
+#' library(leaflet)
+#' library(leaflet.extras2)
+#'
+#' # Sample data
+#' 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))
+#'
+#' leaflet()  %>%
+#'   addTiles() %>%
+#'   addDivicon(data = df
+#'              , html = ~paste0(
+#'                '<div class="custom-html">',
+#'                '<div class="title">', Name, '</div>',
+#'                '<div class="subtitle">MaxWind: ', MaxWind, '</div>',
+#'                '</div>'
+#'              )
+#'              , label = ~Name
+#'              , layerId = ~ID
+#'              , group = "Divicons"
+#'              , popup = ~paste("ID: ", ID, "<br>",
+#'                               "Name: ", Name, "<br>",
+#'                               "MaxWind:", MaxWind, "<br>",
+#'                               "MinPress:", MinPress)
+#'              , options = markerOptions(draggable = TRUE)
+#'   )
+addDivicon <- function (map, lng = NULL, lat = NULL, layerId = NULL, group = NULL,
+                        popup = NULL, popupOptions = NULL, label = NULL,
+                        labelOptions = NULL,
+                        className = NULL, html = NULL,
+                        options = markerOptions(), clusterOptions = NULL,
+                        clusterId = NULL, divOptions = list(), data = getMapData(map)) {
+  if (missing(labelOptions))
+    labelOptions <- labelOptions()
+  map$dependencies <- c(map$dependencies,
+                        diviconDependency())
+  if (!is.null(clusterOptions))
+    map$dependencies <- c(map$dependencies, leafletDependencies$markerCluster())
+
+  pts <- derivePoints(data, lng, lat, missing(lng), missing(lat),
+                      "addDivicon")
+  invokeMethod(map, data, "addDivicon", pts$lat, pts$lng,
+               layerId, group, options,
+               className, html,
+               popup, popupOptions,
+               label, labelOptions,
+               clusterId, clusterOptions,
+               divOptions,
+               getCrosstalkOptions(data)) %>%
+    expandLimits(pts$lat, pts$lng)
+}
+
+
+getCrosstalkOptions <- utils::getFromNamespace("getCrosstalkOptions", "leaflet")
+
+
+
diff --git a/_pkgdown.yml b/_pkgdown.yml
@@ -25,6 +25,11 @@ reference:
     - menuItem
     - mapmenuItems
     - markermenuItems
+  - title: DivIcons
+    contents:
+    - matches("DivIcon")
+    - matches("Divicon")
+    - matches("divicon")
   - title: Clustercharts with d3
     contents:
     - matches("ClusterCharts")

diff --git a/inst/examples/divicons_app.R b/inst/examples/divicons_app.R
@@ -0,0 +1,77 @@
+library(sf)
+library(shiny)
+library(leaflet)
+library(leaflet.extras2)
+# options("shiny.autoreload" = TRUE)
+
+df <- sf::st_as_sf(atlStorms2005)
+df <- suppressWarnings(st_cast(df, "POINT"))
+df <- df[sample(1:nrow(df), 50, replace = F),]
+df$classes = sample(x = c("myclass1","myclass2","myclass3"), nrow(df), replace = TRUE)
+df$ID <- paste0("ID_", 1:nrow(df))
+
+## UI ##################
+ui <- fluidPage(
+  ## CSS-style ############
+  tags$head(tags$style("
+    .globalclass {
+      width: inherit !important;
+      height: inherit !important;
+      font-size: 10px;
+      border-radius: 90%;
+      padding: 4px;
+    }
+    .myclass1 {
+      background-color: yellow;
+    }
+    .myclass2 {
+      background-color: orange;
+    }
+    .myclass3 {
+      background-color: green;
+    }
+    ")),
+  ## CSS-style END ############
+  leafletOutput("map", height = 600),
+  splitLayout(cellWidths = paste0(rep(20,4), "%"),
+              div(h4("Click Event"), verbatimTextOutput("click")),
+              div(h4("Mouseover Event"), verbatimTextOutput("mouseover")),
+              div(h4("Mouseout Event"), verbatimTextOutput("mouseout")),
+              div(h4("Dragend Event"), verbatimTextOutput("dragend"))
+  )
+)
+
+## SERVER ##################
+server <- function(input, output, session) {
+  output$map <- renderLeaflet({
+    leaflet()  %>%
+      addTiles() %>%
+      addMarkers(data = df, group="normalmarker",
+                 clusterId = "someclusterid2",
+                 clusterOptions = markerClusterOptions()) %>%
+      addDivicon(data = df
+                 , html = ~Name
+                 , className = ~paste("globalclass", classes)
+                 , label = ~Name
+                 , layerId = ~ID
+                 , group = "Divicons"
+                 , popup = ~paste("ID: ", ID, "<br>",
+                              "Name: ", Name, "<br>",
+                              "MaxWind:", MaxWind, "<br>",
+                              "MinPress:", MinPress)
+                 , options = markerOptions(draggable = TRUE)
+                 , divOptions = list(
+                                     popupAnchor = c(10, 0),
+                                     iconSize = 10)
+                 # , clusterId = "someclusterid"
+                 # , clusterOptions = markerClusterOptions()
+      ) %>%
+      hideGroup("normalmarker") %>%
+      addLayersControl(overlayGroups = c("Divicons","normalmarker"))
+  })
+  output$click <- renderPrint({input$map_marker_click})
+  output$mouseover <- renderPrint({input$map_marker_mouseover})
+  output$mouseout <- renderPrint({input$map_marker_mouseout})
+  output$dragend <- renderPrint({input$map_marker_dragend})
+}
+shinyApp(ui, server)
diff --git a/inst/examples/divicons_html_app.R b/inst/examples/divicons_html_app.R
@@ -0,0 +1,118 @@
+library(sf)
+library(shiny)
+library(leaflet)
+library(leaflet.extras2)
+
+# Sample data
+df <- sf::st_as_sf(atlStorms2005)
+df <- suppressWarnings(st_cast(df, "POINT"))
+df <- df[sample(1:nrow(df), 50, replace = F),]
+df$classes = sample(x = c("myclass1","myclass2","myclass3"), nrow(df), replace = TRUE)
+df$ID <- paste0("ID_", 1:nrow(df))
+
+## UI ##################
+ui <- fluidPage(
+  ## CSS-style ############
+  tags$head(tags$style("
+    .globalclass {
+      width: 80px !important;
+      height: 80px !important;
+      margin-top: -40px !important;
+      margin-left: -40px !important;
+      font-size: 12px;
+      text-align: center;
+      border-radius: 50%;
+      color: black;
+      padding: 5px;
+      box-shadow: 0px 0px 10px rgba(0, 0, 0, 0.5);
+      background-size: cover;
+      background-repeat: no-repeat;
+      background-position: center center;
+    }
+    .myclass1 {
+      background-color: #FF5733;
+    }
+    .myclass2 {
+      background-color: #33FF57;
+    }
+    .myclass3 {
+      background-color: #3357FF;
+    }
+    .custom-html {
+      display: flex;
+      align-items: center;
+      justify-content: center;
+      flex-direction: column;
+    }
+    .custom-html img {
+      border-radius: 50%;
+      width: 20px;
+      height: 20px;
+      margin-bottom: 5px;
+    }
+    .custom-html .title {
+      font-weight: bold;
+    }
+    .custom-html .subtitle {
+      font-size: 10px;
+    }
+  ")),
+  ## CSS-style END ############
+  leafletOutput("map", height = 600),
+  splitLayout(cellWidths = paste0(rep(20,4), "%"),
+              div(h4("Click Event"), verbatimTextOutput("click")),
+              div(h4("Mouseover Event"), verbatimTextOutput("mouseover")),
+              div(h4("Mouseout Event"), verbatimTextOutput("mouseout")),
+              div(h4("Dragend Event"), verbatimTextOutput("dragend"))
+  )
+)
+
+## SERVER ##################
+server <- function(input, output, session) {
+  # Function to get image URL based on class
+  getImageUrls <- function(classes) {
+    urls <- c(
+      "myclass1" = "https://cdn-icons-png.flaticon.com/512/1355/1355883.png",
+      "myclass2" = "https://cdn-icons-png.flaticon.com/512/1356/1356623.png",
+      "myclass3" = "https://cdn-icons-png.flaticon.com/512/1357/1357674.png"
+    )
+    return(urls[classes])
+  }
+
+  output$map <- renderLeaflet({
+    leaflet()  %>%
+      addTiles() %>%
+      # addMarkers(data = df, group="normalmarker",
+      #            clusterId = "someclusterid2",
+      #            clusterOptions = markerClusterOptions()) %>%
+      addDivicon(data = df
+                 , html = ~paste0(
+                   '<div class="custom-html">',
+                   '<img src="', getImageUrls(classes), '">',
+                   '<div class="title">', Name, '</div>',
+                   '<div class="subtitle">MaxWind: ', MaxWind, '</div>',
+                   '</div>'
+                 )
+                 , className = ~paste("globalclass", classes)
+                 , label = ~Name
+                 , layerId = ~ID
+                 , group = "Divicons"
+                 , popup = ~paste("ID: ", ID, "<br>",
+                              "Name: ", Name, "<br>",
+                              "MaxWind:", MaxWind, "<br>",
+                              "MinPress:", MinPress)
+                 , options = markerOptions(draggable = TRUE)
+                 # , clusterId = "someclusterid"
+                 # , clusterOptions = markerClusterOptions()
+      ) %>%
+      addLabelgun("Divicons", 1) %>%
+      hideGroup("normalmarker") %>%
+      addLayersControl(overlayGroups = c("Divicons","normalmarker"))
+  })
+  output$click <- renderPrint({input$map_marker_click})
+  output$mouseover <- renderPrint({input$map_marker_mouseover})
+  output$mouseout <- renderPrint({input$map_marker_mouseout})
+  output$dragend <- renderPrint({input$map_marker_dragend})
+}
+
+shinyApp(ui, server)