R中的传单中的聚类标记的聚合加权线串

问题描述

我正在尝试绘制位置和加权的连接线串.当我放大或缩小时，标记的聚类调整得很好.群集的所示标签是标记的聚集node_val.

I'm trying to plot locations and weighted connecting linestrings. When I zoom in or out the clustering of the markers adjusts fine. The shown labels of the clusters are the aggregated node_val of the markers.

我想对线串做类似的操作，这样

I would like to do similar with the linestrings, so that

1. 该图未显示连接单个标记的蓝线，而是连接了标记簇的线，并且
2. 连接标记簇的新线串的宽度取决于wgt变量.

1. the plot does not show the blue lines connecting the single markers, but instead lines connecting the clusters of markers, and
2. the new linestrings that connect the clusters of markers are customized in width dependent on the wgt variable.

我希望下面的代码能够演示该问题:

I hope the code below demonstrates the problem:

library(dplyr)
library(leaflet)
library(sf)

set.seed(123)
N <- 1000
N_conn <- 100

# data frame for points
df_points <- data.frame(id = 1:N,
                        lng = sample(c(11.579657, 16.370654), N, TRUE) + rnorm(N, 0, 0.5),
                        lat = sample(c(48.168889, 48.208087), N, TRUE) + rnorm(N, 0, 0.5),
                        node_val = sample(10, N, TRUE))


# data frame for connections
df_conn <- data.frame(id_from = sample(N_conn, replace = TRUE),
                      id_to   = sample(N_conn, replace = TRUE),
                      wgt  = abs(rnorm(N_conn)))

# drop connections where from and to ids are identical
df_conn <- subset(df_conn, id_from != id_to)

# add the coordinates for the connections (merging is not neccessary due to ordering of synth data)
df_conn$lat_from <- df_points[df_conn$id_from, "lat"]
df_conn$lng_from <- df_points[df_conn$id_from, "lng"]
df_conn$lat_to   <- df_points[df_conn$id_to, "lat"]
df_conn$lng_to   <- df_points[df_conn$id_to, "lng"]


sf_conn_from <- df_conn %>% 
  st_as_sf(coords=c("lng_from", "lat_from"))

sf_conn_to <- df_conn %>% 
  st_as_sf(coords=c("lng_to", "lat_to"))

sf_conn <- st_combine(cbind(sf_conn_from, sf_conn_to)) %>% 
  st_cast("LINESTRING")

st_crs(sf_conn) <- 4326

leaflet(df_points) %>% 
  addTiles() %>% 
  addMarkers(options = markerOptions(node_val = ~node_val), 
             label = quakes$mag,
             clusterOptions = markerClusterOptions(
               iconCreateFunction=JS("function (cluster) {    
                var markers = cluster.getAllChildMarkers();
                var sum = 0; 
                for (i = 0; i < markers.length; i++) {
                  sum += Number(markers[i].options.node_val);
                  //sum += 1;
                }
                sum = Math.round(sum);
                return new L.DivIcon({ html: '<div><span>' + sum + '</span></div>',
                  className: 'marker-cluster marker-cluster-medium', 
                  iconSize: new L.Point(40,40)});
              }")
             )) %>% 
  leafem::addFeatures(data = sf_conn,
                      color = 'blue',#~pal(rel_full$N_scale),#
                      weight = 1) 

感谢以下两个问题的贡献者:

Thanks to the contributers of these two questions:

• >传单R，如何使聚类图标的外观与孩子的统计有关?
• 发光的传单会添加大量分离的折线

• leaflet R, how to make appearance of clustered icon related to statistics of the children?
• Shiny leaflet add large amount of separated polylines

推荐答案

这是调整行权重的部分解决方案，我不禁对这些行进行聚类:(

This is a partial solution for adjusting the weighting of the lines, I can't help clustering those lines :(

library(dplyr)
library(leaflet)
library(sf)

set.seed(123)
N <- 1000
N_conn <- 100

# data frame for points
df_points <- data.frame(id = 1:N,
                        lng = sample(c(11.579657, 16.370654), N, TRUE) + rnorm(N, 0, 0.5),
                        lat = sample(c(48.168889, 48.208087), N, TRUE) + rnorm(N, 0, 0.5),
                        node_val = sample(10, N, TRUE))


# data frame for connections
df_conn <- data.frame(id_from = sample(N_conn, replace = TRUE),
                      id_to   = sample(N_conn, replace = TRUE),
                      wgt  = abs(rnorm(N_conn)))

# drop connections where from and to ids are identical
df_conn <- subset(df_conn, id_from != id_to)

# add the coordinates for the connections (merging is not neccessary due to ordering of synth data)
df_conn$lat_from <- df_points[df_conn$id_from, "lat"]
df_conn$lng_from <- df_points[df_conn$id_from, "lng"]
df_conn$lat_to   <- df_points[df_conn$id_to, "lat"]
df_conn$lng_to   <- df_points[df_conn$id_to, "lng"]

geom <- lapply(1:nrow(df_conn),
  function(i)
    rbind(
      as.numeric(df_conn[i, c("lng_from","lat_from")]),
      as.numeric(df_conn[i, c("lng_to","lat_to")])
    )
) %>%
  st_multilinestring() %>%
  st_sfc(crs = 4326) %>%
  st_cast("LINESTRING")

sf_conn <- st_sf(df_conn,
                 geometry=geom)

#Modify weighting
sf_conn$cut=exp(sf_conn$wgt-1)



leaflet(df_points) %>%
  addTiles() %>%
  addMarkers(
    options = markerOptions(node_val = ~ node_val),
    label = quakes$mag,
    clusterOptions = markerClusterOptions(
      iconCreateFunction = JS(
        "function (cluster) {
                var markers = cluster.getAllChildMarkers();
                var sum = 0;
                for (i = 0; i < markers.length; i++) {
                  sum += Number(markers[i].options.node_val);
                  //sum += 1;
                }
                sum = Math.round(sum);
                return new L.DivIcon({ html: '<div><span>' + sum + '</span></div>',
                  className: 'marker-cluster marker-cluster-medium',
                  iconSize: new L.Point(40,40)});
              }"
      )
    )
  ) %>%   addPolylines(weight = sf_conn$cut,
                       data = sf_conn,
                       col = "blue")

这篇关于R中的传单中的聚类标记的聚合加权线串的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！