0

intro
I am pretty agile in R, but my java skills are non-existent. Therefor I'm throwing myself at your mercy to answer this, hopefully not too complex, question (or I will have a hard time figuring out the answers ;-)).

Running the code below requires you to download three leaflet plugins from github (links in the comments inside the code). They should be placed in a folder ./script, relative to where you are running the code.

sample data
I have excel-sheets with multiple routes. For sake of simplicity, I already read in a file using the following code, so I do not have to share the excel-file online:

# read excel file
bestand <- "./data/CBM_Schuttorf_Buren.xlsx"
bladen <- readxl::excel_sheets(bestand)
xldata <- lapply(bladen, function(x) {
  readxl::read_excel(path = bestand, sheet = x,
                     col_types = c(rep(c("numeric", "text"), 2), rep("numeric", 2)))
})
names(xldata) <- bladen

This results in the following object, which you will need to continue the code with

bladen <- c("A1L", "A1R")

xldata <- list(A1L = structure(list(route = c(1, 1, 2, 2, 2, 3, 3, 3), 
    routeType = c("stremming", "stremming", "omleiding", "omleiding", 
    "omleiding", "omleiding", "omleiding", "omleiding"), punt = c(1, 
    2, 1, 2, 3, 1, 2, 3), puntType = c("start", "eind", "start", 
    "via", "eind", "start", "via", "eind"), lat = c(52.341823, 
    52.284989, 52.340234, 52.193045, 52.302415, 52.349596, 52.193045, 
    52.302415), lon = c(7.254037, 6.74575, 7.271095, 7.102321, 
    6.715246, 7.258845, 7.102321, 6.715246)), class = c("tbl_df", 
"tbl", "data.frame"), row.names = c(NA, -8L)), A1R = structure(list(
    route = c(1, 1, 2, 2, 2, 3, 3, 3), routeType = c("stremming", 
    "stremming", "omleiding", "omleiding", "omleiding", "omleiding", 
    "omleiding", "omleiding"), punt = c(1, 2, 1, 2, 3, 1, 2, 
    3), puntType = c("start", "eind", "start", "via", "eind", 
    "start", "via", "eind"), lat = c(52.284267, 52.341886, 52.303024, 
    52.19279, 52.354846, 52.303024, 52.19279, 52.339145), lon = c(6.754951, 
    7.251379, 6.713831, 7.104181, 7.258402, 6.713831, 7.104181, 
    7.285606)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, 
-8L)))

my problem
The sample data is a simplified issue. There are only two list entries, A1L and A1R. In my production data there will be many more entries.
What i want as a result, is a dynamic version of the code below. Here I hardcoded the Layergroups A1L and A1R everywhere. ButWhile this works as a proof-of-concept, this is not workable in production.

As mentioned before, I need the functionality of several leaflet pluging, so I relied heavily on the htmlwidgets::onRender()- funciton to get down what I need. This is also my Achilles-heel, since I am a complete n00b in javascript.

desired output
I am open for all suggestions that can replicate the results of the code below, without hardcoding the filtering/Layergroups..

note: the arrows on the end of the polyline only show when the leaflet is shown in the browser. They do not show inside the rstudio viewer (took me some frustration to find that one out ;-) )

click here for my output

enter image description here

my code

library(tidyverse)
library(readxl)
library(osrm)
library(leaflet)
library(geojsonsf)

# below commented out, xldata is already provided

# # read excel file
# bestand <- "./data/myfile.xlsx"
# bladen <- readxl::excel_sheets(bestand)
# xldata <- lapply(bladen, function(x) {
#   readxl::read_excel(path = bestand, sheet = x,
#                      col_types = c(rep(c("numeric", "text"), 2), rep("numeric", 2)))
# })
# names(xldata) <- bladen

# split individual routes (will become polylines later on)
routes <- lapply(xldata, function(x) split(x, f = x$route))

# create real routes, using  osm routing
df <- 
  dplyr::bind_rows(
    lapply(seq.int(routes), function(i) {
    dplyr::bind_rows(
      lapply(seq.int(lengths(routes)[i]), function(j) {
          temp <- osrmRoute(loc = as.data.frame(routes[[i]][[j]][, c("lon", "lat")]),
                        overview = "full", returnclass = "sf") %>%
            mutate(naam = paste0(bladen[i], "_", routes[[i]][[j]][1,2], routes[[i]][[j]][1,1])) %>%
            mutate(groep = bladen[i]) %>%
            mutate(groepVol = paste0("groups.",bladen[i])) %>%
            mutate(type = ifelse(grepl("stremming", naam), "stremming", "omleiding"))
      }))
    })
  )
df

# get boundaries for map
grens <- sf::st_bbox(df) %>% as.vector()
# create named list of geojson routes
plotdata <- lapply(split(df, f = df$naam), sf_geojson)
#  PLUGIN SECTION
# from: https://github.com/slutske22/leaflet-arrowheads
arrowHead <- htmlDependency(
  "leaflet-arrowheads",
  "0.1.2",
  src = normalizePath(".\\script"),
  #src = "./script",
  script = "leaflet-arrowheads.js"
)
# from https://github.com/makinacorpus/Leaflet.GeometryUtil
geometryutil <- htmlDependency(
  "leaflet.geometryutil",
  "0.1.2",
  src = normalizePath(".\\script"),
  #src = "./script",
  script = "leaflet.geometryutil.js"
)
registerPlugin <- function(map, plugin) {
  map$dependencies <- c(map$dependencies, list(plugin))
  map
}
# plot the map and layers
leaflet() %>%
  #register plugins
  registerPlugin(arrowHead) %>%
  registerPlugin(geometryutil) %>%
  # add basemap
  addProviderTiles(providers$CartoDB.Positron) %>%
  # set map boundaries
  fitBounds( grens[1], grens[2], grens[3], grens[4]) %>%
  onRender("function(el, x, data) {
    // funciton to define line color based on 
    //  feature.properties.type
    function getColor(d) {
      return d == 'stremming' ? 'red' :
             d == 'omleiding' ? 'seagreen' :
                                'black';
    }
    // funciton to define line dash based on 
    //  feature.properties.type
    function getDash(d) {
      return d == 'stremming' ? '20' :
             d == 'omleiding' ? '' :
                                '';
    }
    // function to set style of polylines
    function newstyle(feature) {
      return {
          color: getColor(feature.properties.type),
          weight: 10,
          opacity: 1,
          dashArray: getDash(feature.properties.type),
          fillOpacity: 0.7
      };
    }
    ///////////////////////////////////////
    //would like to make the code below this dynamic 
    //based on the groep-property in the JSON object
    //so A1L and A1R groups (and thereby the filtering)
    //are read in directly from the data object df 
    ///////////////////////////////////////
    // filtering
    function A1L(feature) {if (feature.properties.groep === 'A1L') return true} 
    function A1R(feature) {if (feature.properties.groep === 'A1R') return true}
    // crteation of layergroups
    var groups = {
            A1L: new L.LayerGroup(),
            A1R: new L.LayerGroup()
    };
    // create layers and add to groups
    var A1L = L.geoJSON(data, { 
      filter: A1L,
      style: newstyle,
      arrowheads: {frequency: 'endonly', yawn: 45, size: '30px', fill: true}
    })
    .on('mouseover', function (e) {e.target.setStyle({weight: 15, opacity: 1 });})
    .on('mouseout', function (e) {e.target.setStyle({weight: 10, opacity: 0.75});})
    .addTo(groups.A1L);
    var A1R = L.geoJSON(data, { 
      filter: A1R,
      style: newstyle,
      arrowheads: {frequency: 'endonly', yawn: 45, size: '30px', fill: true}
    })
    .on('mouseover', function (e) {e.target.setStyle({weight: 15, opacity: 1 });})
    .on('mouseout', function (e) {e.target.setStyle({weight: 10, opacity: 0.75});})
    .addTo(groups.A1R);

     var baseLayers = {
      'A1L': A1L,
      'A1R': A1R
    };
    
    var layerControl = L.control.layers(baseLayers, null, {collapsed: false}).addTo(this);
    baseLayers['A1L'].addTo(this);
    
    }", data = sf_geojson(df))

what I have tried so far

I found something that might be the solution here, but I lack the java skills to:

  1. see if this is indeed the way to go, and if so:
  2. how can this be implementd inside my code.
Wimpel
  • 26,031
  • 1
  • 20
  • 37

1 Answers1

0

After >1 day of fruitless effort, I finally found an answer I could work with.

It is now working as desired, here is my answer for anyone looking for this possibility (and I found some in the past 24 h ;-) )

# plot the map and layers
leaflet() %>%
  #register plugins
  registerPlugin(arrowHead) %>%
  registerPlugin(geometryutil) %>%
  registerPlugin(groupedlayercontrol) %>%
  # add basemap
  addProviderTiles(providers$CartoDB.Positron) %>%
  # set map boundaries
  fitBounds( grens[1], grens[2], grens[3], grens[4]) %>%
  onRender("function(el, x, data) {
    // read data from the named list passd to onRender
    // data.name_from_list
    var routes = data.routes;
    var groups = data.groups;
    var types = groups;
    
    // function to define line color based on 
    //  feature.properties.type
    function getColor(d) {
      return d == 'stremming' ? 'red' :
             d == 'omleiding' ? 'seagreen' :
                                'black';
    }
    // funciton to define line dash based on 
    //  feature.properties.type
    function getDash(d) {
      return d == 'stremming' ? '20' :
             d == 'omleiding' ? '' :
                                '';
    }
    // function to set style of polylines
    function newstyle(feature) {
      return {
          color: getColor(feature.properties.type),
          weight: 10,
          opacity: 1,
          dashArray: getDash(feature.properties.type),
          fillOpacity: 0.7
      };
    }
    
    // layerControl optioesn for groupedOverlays
    var options = {
      exclusiveGroups: ['Stremming'],
      groupCheckboxes: false,
      collapsed: false
    };
    // add empty layercontrol
    var layerControl = L.control.groupedLayers(null, null, options).addTo(this);
    
    // iterate over types, filter by that type, and format the layer for that feature type
    types.forEach(function(type) {
      var layer = L.geoJson(routes, {
            filter: function(feature, layer) {
              return feature.properties.groep == type;
            },
            style: newstyle,
            arrowheads: {frequency: 'endonly', yawn: 45, size: '30px', fill: true}
          })
          .on('mouseover', function (e) {e.target.setStyle({weight: 15, opacity: 1 });})
          .on('mouseout', function (e) {e.target.setStyle({weight: 10, opacity: 0.75});})
      
      // all done with the layer, add it to the control
      layerControl.addOverlay(layer, type, 'Stremming');
    });
    
    }", data = list(routes = sf_geojson(df), groups = bladen))
Wimpel
  • 26,031
  • 1
  • 20
  • 37