【问题标题】：Speed up for loop in R, calculating pairwise dissimilarities加速 R 中的 for 循环，计算成对差异
【发布时间】：2016-06-15 19:49:55
【问题描述】：

我正在尝试使用一些自定义的差异度量来计算仅由名义变量组成的数据集中的所有观测值之间的所有成对差异。

数据看起来像

set.seed(3424)

(mydata <- data.table(paste(sample(letters[1:5], 5, replace=T), 
                        sample(LETTERS[1:5], 5, replace=T), 
                        sep = ","), 
                  paste(sample(LETTERS[1:5], 5, replace=T), 
                        sample(LETTERS[1:5], 5, replace=T), 
                        sep = ","), 
                  paste(sample(letters[1:5], 5, replace=T), 
                        sample(letters[1:5], 5, replace=T), 
                        sep = ",")))

    V1  V2  V3
1: a,A E,E b,b
2: e,D C,A d,d
3: d,B B,C d,d
4: c,B A,E b,d
5: a,B C,D d,a


library(data.table)
library(dplyr)
library(stringr)

metric <- function(pair){
    intersection <- 0
    union <- 0
    for(i in 1:ncol(mydata)){
        A <- pair[[1]][[i]]
        B <- pair[[2]][[i]]
        if(sum(is.na(A),is.na(B))==1)
            union = union + 1
        if(sum(is.na(A),is.na(B))==0){
            intersection <- intersection + length(intersect(A,B))/length(union(A,B))
            union = union + 1
        }
    }
    1 - intersection/union
}

diss <- matrix(nrow = nrow(mydata), ncol = nrow(mydata))

for(i in 1:(nrow(mydata)-1)){
    print(i)                     ## to check progress ##
    for(j in (i+1):nrow(mydata)){
        pair <- rbind(mydata[i], mydata[j])
        diss[j, i] <- apply(pair, 1, function(x) strsplit(x, split=",")) %>% metric()
    }
}

这些循环可以工作，但当 mydata 有 1000 多行和 100 多列时会非常慢。

我在这里使用的指标是 Jaccard 索引，但它是一个嵌套版本。由于数据中的每个元素都不是单个值。因此，我没有将每两个级别视为匹配（0）或不同（1），而是在比较级别时也使用 Jaccard。

更新：

关于我的数据的一些上下文，而不是我编造的玩具数据。

每一行代表一个查询，即“SELECT ... FROM ... WHERE ... ...”。
每一列都包含查询中的部分信息，即第一列包含“SELECT”和“FROM”之间的所有内容，第二列包含“FROM”和“WHERE”之间的内容，等等。
有 100 列和 400 行，但我不明白为什么会有这么多列。

一个单元格中的元素数量可以是任意的，一些单元格包含很长的值列表，而许多实际上是NAs。例如。

                                                 SELECT
  1:                                                 NA
  2:p1.PLAYERID,f1.PLAYERNAME,p2.PLAYERID,f2.PLAYERNAME
  3:                       PLAYER f1,PLAYER f2,PLAYS p1
  4:                                                 NA
  5:                                                 NA
  6:                  c1.table_name t1,c2.table_name t2
  7:                                                 NA
 ...
400:               asd,vrht,yuetr,wxeq,yiknuy,sce,ercher

【问题讨论】：

在某种程度上，速度慢可能是由于metric()的编码方式。如果您解释其背后的基本原理/指标的作用（在问题的主体中，而不是在 cmets 中），它可能会让其他人更容易重新实现。
@Frank 谢谢。又忘记了。
创建 mydata 的第一行代码不会创建显示的输出。
@JacobH 通过这样做，我可以在a,A 和a,B 之间分配一些相似性。
请在第一次调用sample()之前用set.seed()定义一个固定的随机数生成种子值。这将使您的玩具数据可重现。然后，每个人都将使用相同的数据集，并可以比较结果。

标签： r performance loops

【解决方案1】：

您可以通过减少工作轻松获得一些速度。如果你只对成对比较感兴趣，你只需要做N个选择2个比较，而不是N^2。您可以使用下面的F2() 来实现它。

set.seed(3424)
(mydata <- data.table(sample(letters[1:5], 50, replace = T),
                      sample(LETTERS[1:5], 50, replace = T),
                      sample(1:3, 50, replace = T)))

mydf<-data.frame(mydata)

f1<- function(){
diss <- matrix(nrow = nrow(mydata), ncol = nrow(mydata))

for(i in 1:(nrow(mydata)-1)){
  print(i)                     ## to check progress ##
  for(j in (i+1):nrow(mydata)){
    pair <- rbind(mydata[i], mydata[j])
    diss[j, i] <- apply(pair, 1, function(x) strsplit(x, split=",")) %>% metric()
    }
  }
 return(diss)
}


f2<-function(){
met<-NULL
A<-NULL
B<-NULL
choices<-choose(nrow(mydf),2)
combs<-combn(nrow(mydf),2)
  for(i in 1:choices) {
    print(i)
    pair<-rbind(mydf[combs[1,i],], mydf[combs[2,i],])
    met[i]<- apply(pair, 1, function(x) strsplit(x, split=",")) %>% metric()
    A[i]<-mydf[combs[1,i],1]
    B[i]<-mydf[combs[2,i],2]
 }
results<-data.frame(A,B, met)
return(results)
}

library(microbenchmark)
microbenchmark(f1(), f2(), times = 10)
Unit: milliseconds
expr  min     lq   mean median     uq  max neval
f1() 1381 1391.2 1416.8 1417.6 1434.9 1456    10
f2()  907  923.6  942.3  946.9  948.9 1008    10

它有点快，但并不令人兴奋。我的猜测是，您定义的 metric 函数需要做更多的工作。我试图查看它并确定一种对其进行矢量化的方法，但我找不到方法。如果可以做到这一点，这个问题将是微不足道的。例如，我有一个类似的程序，可以测量约 400 个长度为约 5000 的向量之间的成对余弦相似度。它必须进行 400 次选择 2 = 79800 次比较，整个程序运行大约需要 6 秒。

【讨论】：

我也在做一些成对的余弦相似性——这需要很长时间。你是如何组织你的程序的？你采取了什么方法？
以矢量化形式进行。定义一个余弦相似度函数，该函数将计算向量化形式的 cos 相似度，它们会按照您的方式处理所有可能的组合。

【解决方案2】：

它与原版相似，但我做了一些更改。它运行得更快，但我没有费心计时。此代码的 1000 似乎与原始代码的 100 差不多。

主要变化：

通过传入变量来删除 rbind 以映射计算并集
变量而不是每次都添加（联合
在循环外一次性拆分字符串
在计算并集和添加交集之前检查长度交集（lenint > 0）

希望对您的案子有所帮助。

rownum <- 1000
(mydata <- data.table(paste(sample(letters[1:5], rownum, replace=T), 
                            sample(LETTERS[1:5], rownum, replace=T), 
                            sep = ","), 
                      paste(sample(LETTERS[1:5], rownum, replace=T), 
                            sample(LETTERS[1:5], rownum, replace=T), 
                            sep = ","), 
                      paste(sample(letters[1:5], rownum, replace=T), 
                            sample(letters[1:5], rownum, replace=T), 
                            sep = ",")))

allsplit <- lapply(mydata,strsplit,split = ',')
allsplitdf <- cbind(allsplit[['V1']],allsplit[['V2']],allsplit[['V3']])
allsplitlist <- split(allsplitdf,1:nrow(allsplitdf))

metric2 <- function(p1,p2){
  for(i in seq_along(p1)){
    intersection <- 0
    A <- p1[[i]]
    B <- p2[[i]]
    if(!any(is.na(A),is.na(B))){
      lenint <- length(intersect(A,B))
      if(lenint > 0){
        intersection <- intersection + lenint/length(union(A,B))
      }
    }
  }
  1 - intersection/length(p1)
}
diss <- matrix(nrow = nrow(mydata), ncol = nrow(mydata))
for(i in 1:(nrow(mydata)-1)){
  print(i)                     ## to check progress ##
  for(j in (i+1):nrow(mydata)){
    diss[j, i] <- mapply(metric2,p1 = allsplitlist[i],p2 = allsplitlist[j])
  }
}

【讨论】：

【解决方案3】：

在构建算法时，务必牢记速度/空间权衡。我所说的速度/空间权衡的意思是，通过将数据存储在不同的模式中，您通常可以消除 for 循环。但是，存储在这个新模式中的数据通常会占用更多空间。

您的示例速度慢的原因是，除其他外，您正在遍历数据的所有行和列。使用 1000x100 data.frame，即 1e5 次计算。消除行上的循环的一种方法是稍微不同地存储数据。例如，我使用expand.grid 命令将所有成对比较组合在同一个data.frame、dTMP 中。然后我去掉逗号并允许该对中的每个成员占据它自己的列（即，最初包含在一个变量中的“a，A”现在是“a”和“A”，并表示两个单独变量中的条目）。一般来说，将数据重新整形为不同的格式很快，或者至少比循环遍历每一行更快。然而，这种重塑显然会生成一个占用更多 RAM 的数据集。在您的情况下，data.frame 将是 1e6x4。这是非常大的，但不会大到阻塞所有 RAM。

做所有这些努力的回报是，现在获得intersect 和union 变量是微不足道且极其快速的。当然，您仍然需要遍历每一列，但是，我们通过简单地排列数据来消除一个循环。可以通过使用 3D 数组来删除列循环上的循环，但是，这样的数组不适合内存。

f3 <- function(){
  intersection <- 0
  for(v in names(mydata)){

    dTMP <- expand.grid(mydata[[v]], mydata[[v]], stringsAsFactors = FALSE)[,c(2,1)]

    #There is likely a more elegant way to do this.
    dTMP <-
      dTMP$Var2 %>%
      str_split(.,  ",") %>%
      unlist(.) %>%
      matrix(., ncol = 2, nrow = nrow(dTMP), byrow = TRUE) %>% 
      cbind(., dTMP$Var1%>%
              str_split(.,  ",") %>%
              unlist(.) %>%
              matrix(., ncol = 2, nrow = nrow(dTMP), byrow = TRUE)) %>%
      as.data.frame(., stringsAsFactors = FALSE) 


    names(dTMP) <- c("v1", "v2", "v3", "v4")

    intersect <- rowSums(dTMP[,c("v1", "v2")]  == dTMP[,c("v3", "v4")])
    intersect <- ifelse(rowSums(dTMP[,c("v1", "v2")]  == dTMP[,c("v4", "v3")]) !=0, rowSums(dTMP[,c("v1", "v2")]  == dTMP[,c("v4", "v3")]), intersect)
    intersect <- ifelse(dTMP[, "v1"] == dTMP[, "v2"], 1, intersect)

    MYunion <- sapply(as.data.frame(t(dTMP)), function(x) n_distinct(x))

    intersection <- intersection + intersect/MYunion

  }

  union <- ncol(mydata)

  return(matrix(1 - intersection/union, nrow = nrow(mydata), ncol = nrow(mydata), byrow = TRUE)) #This is the diss matrix, I think.  Double check that I got the rows and columns correct

}

更新

我仍然无法复制您的结果，但是，我相信新更新的代码非常接近。当set.seed(3424) 时，相异矩阵中只有一个单元格 (2,1) 与我们的结果不同。然而，当前迭代的问题是我需要实现sapply 来获得MYunion。如果您能想到一种更快的方法来做到这一点，您将获得很大的速度提升。阅读此 SO 帖子以获取建议：Efficient Means of Identifying Number of Distinct Elements in a Row

【讨论】：

我认为diss 矩阵不太正确。它为我返回所有 1。
错字，现在试试。对角线是正确的，因为它全为零，正如人们对相异矩阵所期望的那样。非对角线可能需要翻转，但我认为它们是正确的。
虽然越来越近了 ;)
我现在看到，获取dissim 矩阵的方法不正确。这是因为来自第 1、2 和 3 列的信息组合起来构成了dissim 的条目。