R:找出每个点最接近的5个点

3

我正在使用R编程语言。

假设我有以下两个数据框:

set.seed(123)

df_1 <- data.frame(
  name_1 = c("john", "david", "alex", "kevin", "trevor", "xavier", "tom", "michael", "troy", "kelly", "chris", "henry", "taylor", "ryan", "peter"),
  lon = rnorm(15, mean = -74.0060, sd = 0.01),
  lat = rnorm(15, mean = 40.7128, sd = 0.01)
)

df_2 <- data.frame(
  name_2 = c("matthew", "tyler", "sebastian", "julie", "anna", "tim", "david", "nigel", "sarah", "steph", "sylvia", "boris", "theo", "malcolm"),
  lon = rnorm(14, mean = -74.0060, sd = 0.01),
  lat = rnorm(14, mean = 40.7128, sd = 0.01)
)

我的问题:对于df_1中的每个人,我试图找出与该人最接近(haversine距离)的5个人,并记录各种距离统计信息(例如平均值、中位数、最大值、最小值和标准差)。

这是我的尝试:

首先,我定义了距离函数:

   library(geosphere)
haversine_distance <- function(lon1, lat1, lon2, lat2) {
  distHaversine(c(lon1, lat1), c(lon2, lat2))
}

然后,我计算了df_1中每个人与df_2中所有人之间的距离:

# Create a matrix to store results
distances <- matrix(nrow = nrow(df_1), ncol = nrow(df_2))

# calculate the distances
for (i in 1:nrow(df_1)) {
    for (j in 1:nrow(df_2)) {
        distances[i, j] <- haversine_distance(df_1$lon[i], df_1$lat[i], df_2$lon[j], df_2$lat[j])
    }
}

# Create final
final <- data.frame(
    name_1 = rep(df_1$name_1, each = nrow(df_2)),
    lon_1 = rep(df_1$lon, each = nrow(df_2)),
    lat_1 = rep(df_1$lat, each = nrow(df_2)),
    name_2 = rep(df_2$name_2, nrow(df_1)),
    lon_2 = rep(df_2$lon, nrow(df_1)),
    lat_2 = rep(df_2$lat, nrow(df_1)),
    distance = c(distances)
)

最后,对于df_1中的每个人,我保留了5个最小距离并记录了距离统计信息:

# Keep only first 5 rows for each unique value of final$name_1
final <- final[order(final$name_1, final$distance), ]
final <- final[ave(final$distance, final$name_1, FUN = seq_along) <= 5, ]


# Calculate summary statistics for each unique person in final$name_1
final_summary <- aggregate(distance ~ name_1,
                           data = final,
                           FUN = function(x) c(min = min(x),
                                               max = max(x),
                                               mean = mean(x),
                                               median = median(x),
                                               sd = sd(x)))
final_summary <- do.call(data.frame, final_summary)
names(final_summary)[-(1)] <- c("min_distance", "max_distance", "mean_distance", "median_distance", "sd_distance")


final_summary$closest_people <- tapply(final$name_2,
                                       final$name_1,
                                       FUN = function(x) paste(sort(x), collapse = ", "))


# break closest_people column into multiple columns
n <- 5
closest_people_split <- strsplit(final_summary$closest_people, ", ")
final_summary[paste0("closest_", seq_len(n))] <- do.call(rbind, closest_people_split)

最终结果如下:

  name_1 min_distance max_distance mean_distance median_distance sd_distance                          closest_people closest_1 closest_2 closest_3 closest_4 closest_5
1   alex     342.8375    1158.1408      717.0810        650.9167    358.7439     boris, david, matthew, nigel, sarah     boris     david   matthew     nigel     sarah
2  chris     195.4891    1504.8199      934.6618        895.8301    489.5175     boris, david, malcolm, nigel, steph     boris     david   malcolm     nigel     steph
3  david     549.4500     830.2758      716.3839        807.6626    143.9571      matthew, sarah, steph, sylvia, tim   matthew     sarah     steph    sylvia       tim
4  henry     423.1875     975.1733      639.5657        560.1101    223.2389    anna, boris, matthew, sebastian, tim      anna     boris   matthew sebastian       tim
5   john     415.8956    1174.1631      849.4313        965.2928    313.2616      boris, julie, matthew, theo, tyler     boris     julie   matthew      theo     tyler
6  kelly     489.7949     828.5550      657.5908        658.7015    120.6485 david, julie, matthew, sebastian, steph     david     julie   matthew sebastian     steph
我的问题:虽然这段代码似乎没有错误,但我有一种感觉,当df_1和df_2的大小开始增长时,这段代码将开始花费很长时间运行。因此,我正在寻找提高代码效率的方法 - 请问有人可以建议如何修复较大数据框的问题吗?
谢谢!
1个回答

3
这个问题可以采用 data.table 的方法来解决,具体如下:
funcs <- function(d,n) {
  c(setNames(lapply(c(min,max,mean,median,sd), \(f) f(d)), c("min", "max", "mean", "median", "sd")),
    list("names" = paste0(n, collapse=", "))
  )
}

library(data.table)

setDT(cross_join(df_1, df_2))[
  ,dist:=distHaversine(c(lon.x, lat.x), c(lon.y, lat.y)), .(name_1, name_2)
][order(dist), .SD[1:5, funcs(dist, name_2)], name_1]

输出:

     name_1       min       max      mean    median        sd                                  names
 1:  taylor  170.5171  746.6206  470.0857  439.8022 227.39141    david, tim, nigel, sarah, sebastian
 2:   peter  195.4891 1455.0204  834.2543  830.2758 539.69009     steph, boris, matthew, anna, david
 3:     tom  243.6729  530.4778  426.2490  447.8639 110.26649    tim, sebastian, julie, nigel, david
 4:    ryan  342.8375 1243.7473  970.0721 1052.6759 367.08513 tyler, julie, sebastian, sylvia, nigel
 5:   henry  394.8684  894.5358  647.1996  670.9220 236.69562     anna, matthew, david, steph, boris
 6:    john  423.1875 1948.9521 1106.4374 1052.8789 674.69139     boris, steph, matthew, anna, david
 7:   kelly  491.6430 1130.9239  717.7716  658.7015 248.96974     sylvia, tyler, sarah, nigel, julie
 8:  trevor  520.1834  650.9167  609.4363  631.9494  52.96026    nigel, sarah, julie, tim, sebastian
 9:    troy  549.4500 1035.0599  782.8799  828.5550 220.72034      tyler, sylvia, sarah, nigel, theo
10: michael  581.9209 1504.5642 1057.1773 1012.5247 378.81712      theo, tyler, sylvia, sarah, nigel
11:   david  602.9369  941.3102  752.1558  715.3872 159.37550      nigel, sarah, david, sylvia, anna
12:   kevin  638.9259  834.5504  715.5252  644.2898 102.23793     matthew, anna, david, nigel, steph
13:  xavier  972.9730 1767.1953 1369.5604 1396.8569 371.03190    julie, sebastian, tim, tyler, david
14:   chris 1389.1659 2106.7084 1644.0448 1455.8430 316.31565     julie, tyler, sebastian, tim, theo
15:    alex 1765.7750 2428.5429 2013.7843 1828.6055 294.37805     julie, tyler, sebastian, tim, theo

另一种使用 dplyr 的方法是使用 cross_joinrowwise() 获取距离,然后使用 slice_head(n=5, by=name_1) 来获取由 name_1 确定的五个最小距离,然后以通常的方式重新构建或汇总数据:
cross_join(df_1, df_2) %>%
  rowwise() %>% 
  mutate(dist=distHaversine(c(lon.x, lat.x), c(lon.y, lat.y))) %>% 
  ungroup() %>% 
  arrange(dist) %>%
  slice_head(n = 5, by=name_1) %>% 
  reframe(
    min_distance = min(dist),
    max_distance = max(dist),
    mean_distance=mean(dist),
    median_distance=median(dist),
    sd_distance = sd(dist),
    names = paste0(name_2, collapse=","),
    .by=name_1
  )

输出:

# A tibble: 15 × 7
   name_1  min_distance max_distance mean_distance median_distance sd_distance names                             
   <chr>          <dbl>        <dbl>         <dbl>           <dbl>       <dbl> <chr>                             
 1 taylor          171.         747.          470.            440.       227.  david,tim,nigel,sarah,sebastian   
 2 peter           195.        1455.          834.            830.       540.  steph,boris,matthew,anna,david    
 3 tom             244.         530.          426.            448.       110.  tim,sebastian,julie,nigel,david   
 4 ryan            343.        1244.          970.           1053.       367.  tyler,julie,sebastian,sylvia,nigel
 5 henry           395.         895.          647.            671.       237.  anna,matthew,david,steph,boris    
 6 john            423.        1949.         1106.           1053.       675.  boris,steph,matthew,anna,david    
 7 kelly           492.        1131.          718.            659.       249.  sylvia,tyler,sarah,nigel,julie    
 8 trevor          520.         651.          609.            632.        53.0 nigel,sarah,julie,tim,sebastian   
 9 troy            549.        1035.          783.            829.       221.  tyler,sylvia,sarah,nigel,theo     
10 michael         582.        1505.         1057.           1013.       379.  theo,tyler,sylvia,sarah,nigel     
11 david           603.         941.          752.            715.       159.  nigel,sarah,david,sylvia,anna     
12 kevin           639.         835.          716.            644.       102.  matthew,anna,david,nigel,steph    
13 xavier          973.        1767.         1370.           1397.       371.  julie,sebastian,tim,tyler,david   
14 chris          1389.        2107.         1644.           1456.       316.  julie,tyler,sebastian,tim,theo    
15 alex           1766.        2429.         2014.           1829.       294.  julie,tyler,sebastian,tim,theo   

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文,
原文链接