使用传单或绘图在高程上绘制颜色 gpx 轨迹

Question

我正在尝试在 Shiny 应用程序中绘制 gpx 轨迹，以便 gpx 绘图颜色基于任何给定点的海拔（高度）。我的示例 gpx 文件包含 4,000 到 10,000 个点（坐标对）之间的任何位置。海拔可以显示出最小的变化（接近海平面的平坦轨道）或高达 1600m 的变化（远足小径）。

** 所需输出 **

来自 https://iosphere.github.io/Leaflet.hotline/demo/ 的示例，使用 Leaflet 中的插件。更多详细信息请参见：https://github.com/iosphere/Leaflet.hotline/ 没有可用的 R 代码，我不知道如何在 R 中集成传单插件。

** 读取数据 **

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

** 与情节 **

scattermapbox

选项仅绘制可以基于列着色的标记，但输出标记不通过线连接（预期）

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)])
    )
  )

切换到

add_trace(..., mode = 'lines+markers')

保留上面屏幕截图中的标记颜色，但用统一的标准蓝色为线条着色。如果设置为

add_trace(..., mode = 'lines')

绘图就会消失（即不渲染）：

** 使用传单 **

使用

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)

在

color = ~ele

调用中使用

addPolylines

不起作用（绘图消失），但图块仍然存在。我也尝试过使用

colorNumeric

、

colorRamp

以及相同的结果。该调用已修改为

addPolylines(..., color = ~colorFunc(ele))

，其中

colorFunc

可以是：

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

或

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

colorRamp

显示不同海拔值的输出变化，而

colorNumeric

始终默认为高颜色 (

#B20000

)。

colorRampPalette

对一些人有用，但没有改变我在这里的输出。

我在 SO 和其他论坛上看到了几个答案，但没有一个适合我。

1. 折线的传单颜色
2. 如何在R中绘制多种颜色的折线？
3. 在 R 中为传单中的折线添加颜色
4. https://gis.stackexchange.com/questions/90193/color-code-a-leaflet-polyline-based-on-additional-values-e-g-altitude-speed

** 数据 **

下面的示例数据（仅 50 分）。您可以在此处下载示例文件：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>)

Answer 1

这是我的做法...

灵感来自： 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 )