需要加快我在 R 中的距离函数

Question

我正在计算一个距离矩阵，用于一些聚类。距离矩阵大小将产生 4.6 gb，所以我需要一个非常快速的代码来计算它！

我已经读到最好的方法是“矢量化”我的函数，但是我并不擅长使用 R 编程，目前我想出了一个具有 2 个嵌套循环的解决方案！

距离函数以 2 个地理坐标和 2 个字符串作为输入，并按以下方式计算距离：

require(Imap)

mydist <- function (lat1,lon1,lingua1,lat2,lon2,lingua2,DT){
  delta=0.1
  gamma=3
  d=sqrt(delta*gdist(lon1,lat1,lon2,lat2)^2 + gamma*(DT[language1 %in% lingua1 & language2 %in%lingua2]$distance)^2)
}

它从我存储了所有可能的字符串距离的 data.table DT 中读取我的两个字符串的距离

分配矩阵的函数是：

require(bigmemory)

distmatrix <- function(twit2,DT){
  N=dim(twit2)[1]
  distmat = big.matrix(N,N)
  for(i in 1:N){
    for(j in 1:N){
      distmat[i,j]=mydist(twit2[i,]$longitude,twit2[i,]$latitude,twit2[i,]$language,twit2[j,]$longitude,twit2[j,]$latitude,twit2[j,]$language,DT)
    }
  }
  return(distmat)
}

编辑：我正在研究另一种方法，即使用库（化石），其中实现了测地距离计算的矢量版本

另外，我已将 DT 移至 DT2，它现在是一个方阵

library(fossil)

lingdist <- function(lang1,lang2, DT2){
  list=colnames(DT2)
  i=which(list==lang1)
  j=which(list==lang2)
  return(DT2[i,j])
}

distmatrix <- function(twit2,DT2){
  N=dim(twit2)[1]
  long<-as.vector(twit2$longitude)
  lat <-as.vector(twit2$latitude)
  lang<-as.vector(twit2$language)
  distmat = t(as.matrix(earth.dist(as.matrix(cbind(long,lat)))))
  for(i in 1:N) {
    for (j in i:N) {
      distmat[i,j]=sqrt(distmat[i,j]*distmat[i,j] + lingdist(lang[i],lang[j],DT2))
    }
  }
  return(distmat)
}

使用“小”输入（最多 5k 行）实现了 20 倍的显着加速，但无法为我的整个数据帧（24k 行）分配 distmat

你知道如何解决它吗？

EDIT2：这是我的数据库的一个小版本

dput(DT2[1:5,1:5])
structure(c(0, 0.808204378308, 0.873223132147, 0.885209298235, 
0.849854297278, 0.808204378308, 0, 0.881177373275, 0.854352223232, 
0.854317529225, 0.873223132147, 0.881177373275, 0, 0.834454614055, 
0.861541199715, 0.885209298235, 0.854352223232, 0.834454614055, 
0, 0.76583938666, 0.849854297278, 0.854317529225, 0.861541199715, 
0.76583938666, 0), .Dim = c(5L, 5L), .Dimnames = list(c("1", 
"2", "3", "4", "5"), c("AA.SEMITIC.ARABIC_GULF_SPOKEN", "Alt.TURKIC.TURKISH", 
"An.MESO-PHILIPPINE.TAGALOG", "IE.BALTIC.LITHUANIAN", "IE.CELTIC.WELSH"
)))

 dput(twit4[1:40,])
structure(list(day = c(0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L), nil = c(28L, 
28L, 28L, 28L, 28L, 28L, 28L, 28L, 28L, 28L, 28L, 28L, 71L, 71L, 
20L, 5L, 24L, 49L, 50L, 28L, 28L, 22L, 22L, 21L, 21L, 24L, 20L, 
20L, 20L, 20L, 20L, 20L, 20L, 20L, 20L, 20L, 20L, 20L, 20L, 24L
), longitude = c(9.2235078, 9.22355903, 9.22362504, 9.22318987, 
9.22355654, 9.22361992, 9.22348964, 9.22366317, 9.22383346, 9.2238841, 
9.22374533, 9.22351081, 9.1361611, 9.1361805, 9.2144687, 9.1871549, 
9.2504309, 9.14652258, 9.16928, 9.22321188, 9.22387642, 9.2237509, 
9.22372656, 9.22278207, 9.2225214, 9.2470243, 9.22405217, 9.22404052, 
9.22405638, 9.22396956, 9.22402622, 9.2239671, 9.2239646, 9.22400299, 
9.22400299, 9.22403204, 9.22396816, 9.22404027, 9.22407831, 9.246786
), latitude = c(45.45206021, 45.45202558, 45.4523043, 45.45211746, 
45.45204048, 45.45232425, 45.45207132, 45.45205533, 45.45218499, 
45.45216514, 45.45220716, 45.45214255, 45.5053803, 45.5053559, 
45.4871762, 45.4539539, 45.4660934, 45.45278042, 45.455855, 45.45882439, 
45.46055371, 45.47414199, 45.47947343, 45.48080458, 45.48119442, 
45.4658805, 45.49167007, 45.49168084, 45.49160813, 45.49164877, 
45.49165014, 45.49163468, 45.49165405, 45.49169004, 45.49169004, 
45.49160814, 45.49164155, 45.49161845, 45.49160889, 45.4660437
), language = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 4L, 4L, 1L, 8L, 4L, 4L, 8L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), .Label = c("AA.SEMITIC.ARABIC_GULF_SPOKEN", 
"AA.SEMITIC.HEBREW", "Alt.TURKIC.TURKISH", "An.MESO-PHILIPPINE.TAGALOG", 
"AuA.VIET-MUONG.VIETNAMESE", "IE.ARMENIAN.EASTERN_ARMENIAN", 
"IE.BALTIC.LATVIAN", "IE.BALTIC.LITHUANIAN", "IE.CELTIC.WELSH", 
"IE.GERMANIC.DANISH", "IE.GERMANIC.DUTCH", "IE.GERMANIC.ICELANDIC", 
"IE.GERMANIC.NORWEGIAN_BOKMAAL", "IE.GERMANIC.STANDARD_GERMAN", 
"IE.GERMANIC.SWEDISH", "IE.GREEK.GREEK", "IE.INDIC.HINDI", "IE.IRANIAN.PERSIAN", 
"IE.ROMANCE.FRENCH", "IE.ROMANCE.PORTUGUESE", "IE.ROMANCE.ROMANIAN", 
"IE.ROMANCE.SPANISH", "IE.SLAVIC.BOSNIAN", "IE.SLAVIC.BULGARIAN", 
"IE.SLAVIC.CROATIAN", "IE.SLAVIC.POLISH", "IE.SLAVIC.RUSSIAN", 
"IE.SLAVIC.SERBOCROATIAN", "IE.SLAVIC.SLOVAK", "IE.SLAVIC.SLOVENIAN", 
"IE.SLAVIC.UKRAINIAN", "Jap.JAPANESE.JAPANESE", "Kor.KOREAN.KOREAN", 
"Krt.KARTVELIAN.GEORGIAN", "Oth.CREOLES_AND_PIDGINS.HAITIAN_CREOLE", 
"ST.CHINESE.CANTONESE", "TK.KAM-TAI.THAI", "Ura.FINNIC.ESTONIAN", 
"Ura.FINNIC.FINNISH", "Ura.UGRIC.HUNGARIAN"), class = "factor")), .Names = c("day", 
"nil", "longitude", "latitude", "language"), row.names = c("2", 
"6", "7", "8", "13", "15", "16", "20", "25", "29", "30", "32", 
"84", "86", "195", "266", "322", "467", "495", "521", "524", 
"534", "542", "546", "550", "580", "624", "640", "668", "676", 
"679", "699", "742", "751", "754", "768", "779", "800", "803", 
"857"), class = "data.frame")

Answer 1

这是迄今为止我发现的最快的替代方案，基于data.table。它要求数据以长格式组织，以便数据集中的每一行都有起点（lat long）和目标（lat long）的组合。

4 个简单步骤

# load library
 library(geosphere)
 library(data.table)

### STEP 1. reshape your matrix with languange distances to long format
setDT(DT)[, language := names(DT)]
DT_long <- melt.data.table(DT,  id.vars="language", variable.name = "language2", value.name = "lingdist")


### STEP 2. Get all possible combinations of origin and destination in long format
df <- expand.grid.df(twit4, twit4)
names(df)[c(3,4,5,8,9,10)] <- c("long_orig", "lat_orig", "language", "long_dest", "lat_dest","language2")


### STEP 3. Efficiently merge the two datasets
setkey(DT_long, "language", "language2")
setkey(df, "language", "language2")
df <- df[DT_long, nomatch=0]


### STEP 4. Calculate distances
df[ , dist := lingdist + distGeo(matrix(c(long_orig, lat_orig), ncol = 2), 
                                 matrix(c(long_dest, lat_dest), ncol = 2))/1000]

这个解决方案应该比较快。这里的瓶颈是 expand.grid.df 操作，这可能是代码中需要更多时间的部分，特别是在处理大型数据集时。我很确定必须有一个更快的替代expand.grid.df。当我找到一个时，我会更新这个答案。