简体   繁体   中英

Color gpx track bsaed on elevation using leaflet or plotly in R shiny

I'm trying to plot a gpx track in a Shiny application such that the gpx plot color is based on the elevation (altitude) at any given point. My sample gpx files contain anywhere between 4,000 and 10,000 points (coordinate pairs). The elevation can show minimal variation (flat track near sea level) or variation upto 1600m (hiking trails).

** Desired Output **

Sample from https://iosphere.github.io/Leaflet.hotline/demo/ using plugins in Leaflet. More details here: https://github.com/iosphere/Leaflet.hotline/ There's no R code available and I don't know how to integrate plugins for leaflet in R.

在此处输入图像描述

** Reading Data **

dat <- plotKML::readGPX(my_gpx_file) # sample file link below
track <- as.data.table(dat$tracks[[1]][[1]])
track[, ele := as.numeric(ele)]

** With Plotly **

The scattermapbox option only plots markers which can be colored based on a column but the output markers are not connected by lines (expected)

plot_mapbox(data = track, mode = 'scattermapbox') %>%
  add_markers(x = ~lon, y = ~lat, color = ~ele, hoverinfo = 'none') %>%
  layout(
    mapbox = list(
      zoom = 10,
      center = list(lon = track[, mean(lon)], lat = track[, mean(lat)])
    )
  )

在此处输入图像描述

switching to add_trace(..., mode = 'lines+markers') retains the marker color from above screenshot but colors the line with a uniform standard blue. If set to add_trace(..., mode = 'lines') the plot disappears (ie does not render):

在此处输入图像描述

** Using Leaflet **

With a basic call using addPolyLines :

leaflet(track) %>%
  fitBounds(lng1 = min(track$lon), lat1 = min(track$lat),
            lng2 = max(track$lon), lat2 = max(track$lat)) %>%
  clearShapes() %>%
  clearControls() %>%
  addProviderTiles(
    provider = providers$Thunderforest,
    options = list(variant = 'transport',
                   apikey = my_api_key)
  ) %>%
  addPolylines(lng = ~lon,
               lat = ~lat)

在此处输入图像描述

Using color = ~ele in the addPolylines call doesn't work (plot vanishes) but the tiles remain. I've tried using colorNumeric , colorRamp as well with the same results. The call was modified to addPolylines(..., color = ~colorFunc(ele)) where colorFunc could be:

colorFunc <- colorNumeric(
  palette = c('#000000', '#B20000') ,
  domain = track$ele
)

or

colorFunc <- colorRamp(
  colors = c('#FDFDFD', '#B20000'), 
  bias = 5, 
  interpolate = 'linear'
  )

colorRamp showed a variation in the output for different values of elevation whereas colorNumeric always defaulted to the high color ( #B20000 ). colorRampPalette worked for some folks but didn't change my output here.

I've seen several answers on SO and other forums but none of them worked out for me.

  1. Leaflet colours for polylines
  2. How to plot polylines in multiple colors in R?
  3. Adding color to polylines in leaflet in R
  4. https://gis.stackexchange.com/questions/90193/color-code-a-leaflet-polyline-based-on-additional-values-eg-altitude-speed

** Data **

sample data below (50 points only). You can download a sample file here: https://ridewithgps.com/routes/28431977

structure(list(lat = c(45.54214, 45.54205, 45.54183, 45.54148, 
45.54103, 45.54081, 45.54041, 45.54036, 45.5403499, 45.53998, 
45.53985, 45.53954, 45.5394, 45.53918, 45.53898, 45.53893, 45.53893, 
45.53882, 45.53882, 45.53884, 45.53888, 45.5390299, 45.53926, 
45.53937, 45.53976, 45.54013, 45.54032, 45.54045, 45.54048, 45.54055, 
45.5406199, 45.54071, 45.5409099, 45.54103, 45.54131, 45.54162, 
45.54197, 45.54247, 45.5427, 45.5428, 45.5441, 45.5443799, 45.54557, 
45.54627, 45.54639, 45.54656, 45.54667, 45.54685, 45.54706, 45.54714
), lon = c(-73.55111, -73.55079, -73.55008, -73.5489, -73.54741, 
-73.54671, -73.54546, -73.54528, -73.54524, -73.54394, -73.54346, 
-73.54244, -73.54192, -73.54115, -73.54048, -73.54029, -73.54029, 
-73.54025, -73.54025, -73.54021, -73.54013, -73.53994, -73.53964, 
-73.53954, -73.53937, -73.53905, -73.5389, -73.53877, -73.53871, 
-73.53827, -73.53814, -73.53812, -73.53824, -73.53825, -73.5381, 
-73.5378, -73.53758, -73.53713, -73.53706, -73.53701, -73.53625, 
-73.536, -73.53537, -73.53502, -73.53498, -73.5349899, -73.53504, 
-73.53528, -73.53529, -73.53527), ele = c(23.7, 23.3, 22.8, 21.9, 
21.6, 21.8, 21.9, 22.1, 22.1, 21.2, 20, 17.7, 16.6, 15.3, 14.8, 
14.8, 14.8, 14.7, 14.7, 14.7, 14.7, 14.8, 14.8, 14.8, 14.3, 13.6, 
13.4, 13.2, 13.1, 12.6, 12.5, 12.4, 12.6, 12.6, 12.4, 12.2, 12.4, 
12.3, 12.2, 12.2, 12.3, 12.4, 12.7, 12.9, 12.9, 12.9, 12.9, 13.2, 
13.2, 13.2)), row.names = c(NA, -50L), class = c("data.table", 
"data.frame"), .internal.selfref = <pointer: 0x7f91fb8096e0>)

Here is my go at things...

inspiration from: https://gist.github.com/helgasoft/799fac40f6fa2561c61cd1404521573a

library(plotKML)  #for reading gpx
library(dplyr)    #for setting ele to numeric
library(leaflet)
library(htmltools)
library(htmlwidgets)

#load gpx file, convert data to lat-lon-ele data.frame
mydata <- plotKML::readGPX( "./temp/19_aout_2018_-_au_complet.gpx" )$tracks[[1]][[1]] %>%
  dplyr::mutate( ele = as.numeric( ele ) )
#download the needed js-file to C:/temp (create c:/Temp first if necessairy)
download.file("https://raw.githubusercontent.com/iosphere/Leaflet.hotline/master/dist/leaflet.hotline.js", 
              'C:/Temp/leaflet.hotline.js', mode="wb")
#load the plugin
hotlinePlugin <- htmltools::htmlDependency(
  name = 'Leaflet.hotline',
  version = "0.4.0",
  src = c(file = normalizePath('C:/Temp')),
  script = "leaflet.hotline.js"
  )
#register plugin
registerPlugin <- function( map, plugin ) {
  map$dependencies <- c( map$dependencies, list( plugin ) )
  map
}
#draw leaflet
leaflet() %>% addTiles() %>%
  fitBounds( min(mydata$lon), min(mydata$lat), max(mydata$lon), max(mydata$lat) ) %>%
  registerPlugin(hotlinePlugin) %>%
  onRender("function(el, x, data) {
    data = HTMLWidgets.dataframeToD3(data);
    data = data.map(function(val) { return [val.lat, val.lon, val.ele]; });
    L.hotline(data, {min: 15, max: 70}).addTo(this);
  }", data = mydata )

在此处输入图像描述

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM