更新

Question

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

数据看起来像

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。

更新

关于我的数据的一些背景，而不是我编写的玩具数据。

每行代表一个查询，即＆＃34; SELECT ... FROM ... WHERE ... ...＆＃34;
每列包含查询中的部分信息，即第1列包含＆＃34; SELECT＆＃34;之间的所有内容。和＆＃34; FROM＆＃34;，第二栏包含＆＃34; FROM＆＃34;之间的内容。和＆＃34; WHERE＆＃34;等。
有100列和400行，我不知道为什么有这么多列。

一个单元格中的元素数量可能非常随意，一些单元格包含很长的值列表，而许多单元格实际上是NA个。例如。

                                                 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

Answer 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函数上完成更多工作。我试着看一下它并确定一种矢量化的方法，但我找不到办法。如果可以做到这个问题将是微不足道的。例如，我有一个类似的程序来测量长度约为5000的~400个向量之间的成对余弦相似性。它必须进行400选择2 = 79800比较，整个程序需要大约6秒才能运行。

Answer 2

在构建算法时，记住速度/空间权衡是很重要的。我所说的速度/空间权衡是指通过将数据存储在不同的模式中，通常可以消除循环。但是，存储在此新架构中的数据通常会占用更多空间。

您的示例缓慢的原因是，除其他外，您循环遍历所有行和您的数据列。使用1000x100 data.frame即1e5计算。消除行上的循环的一种方法是以稍微不同的方式存储数据。例如，我使用expand.grid命令将所有成对比较组合在同一data.frame，dTMP中。然后我删除逗号并允许该对中的每个成员占用它自己的列（即＆＃34; a，A＆＃34;它最初包含在一个变量中，现在是＆＃34; a＆＃34 ;和＆＃34; A＆＃34;并表示两个单独变量中的条目）。通常，将数据重新整形为不同的格式是快速的，或者比循环每行更快。然而，这种重新形成清楚地产生了占用更多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

Answer 3

它与原版相似，但我做了一些修改。它运行得更快，但我没有打扰它的时机。使用此代码的1000似乎与原始的100一样。

主要变化：

通过将变量传入mapply计算union
变量而不是每次都添加（union＆lt; - union + 1）
在循环外一次分割字符串
在计算联合和添加交集（lenint＆gt; 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])
  }
}

加速R中的循环，计算成对差异

3 个答案:

更新