优化解决方案以在大型数据集上找到共同的第三个

Question

这是我的previous question 的后续问题。我遇到了一个问题，要找到一种内存高效的解决方案，以便为我的大型数据集（350 万组和 620 万人）找到共同的三分之一

使用igraph 包的建议解决方案对于正常大小的数据集运行速度很快，不幸的是，由于为更大的数据集创建了一个大矩阵，因此遇到了内存问题。类似的问题出现在我自己的使用串联内连接的解决方案中，其中第三个内连接使数据帧膨胀，因此我的电脑内存不足 (16gb)。

    df.output <-   inner_join(df,df, by='group' ) %>% 
      inner_join(.,df, by=c('person.y'='person')) %>%
      inner_join(.,df, by=c('group.y'='group')) %>% 
      rename(person_in_common='person.y', pers1='person.x',pers2='person') %>% 
      select(pers1,pers2,person_in_common) %>% 
      filter(pers1!=pers2) %>% 
      distinct() %>% 
      filter(person_in_common!=pers1 & person_in_common!=pers2)

    df.output[-3] <- t(apply(df.output[-3], 1, 
                             FUN=function(x) sort(x, decreasing=FALSE)))

    df.output <- unique(df.output)

小数据集示例和预期输出

df <- data.frame(group= c("a","a","b","b","b","c"),
             person = c("Tom","Jerry","Tom","Anna","Sam","Nic"), stringsAsFactors = FALSE)

df
    group person
1     a    Tom
2     a  Jerry
3     b    Tom
4     b   Anna
5     b    Sam
6     c    Nic

预期结果

df.output
  pers1 pers2 person_in_common
1  Anna Jerry              Tom
2 Jerry   Sam              Tom
3   Sam   Tom             Anna
4  Anna   Tom              Sam
6  Anna   Sam              Tom

不幸的是，我无法使用具有更多内存的机器，也没有真正的云计算经验，所以我希望让它在我的本地电脑上运行。我将不胜感激输入如何优化任何解决方案或建议如何以其他方式解决问题。

编辑 1

反映我实际数据大小的数据框。

set.seed(33)

Data <- data.frame(group = sample(1:3700000, 14000000, replace=TRUE),
                   person = sample(1:6800000, 14000000,replace = TRUE))

编辑 2

作为示例数据，就更大的组和每组更多的人而言，我的真实数据要复杂一些。因此，它变得更加记忆密集。我不知道如何模拟这种结构，所以请按照真实数据下载：

Full person-group data

Answer 1

所以，我设法在您的测试数据上运行它（我有 16 GB 的 RAM），但是如果您在小示例上运行它，那么您会发现它不会给出相同的结果。我不明白为什么，但也许你可以帮助我。所以我会尽量解释每一步：

myFun <- function(dt) {
  require(data.table)
  # change the data do data.table:
  setDT(dt)
  # set key/order the data by group and person:
  setkey(dt, group, person)
  # I copy the initial data and change the name of soon to be merged column name to "p2"
  # which represents person2
  dta <- copy(dt)
  setnames(dta, "person", "p2")
  # the first merge using data.table:
  dt1 <- dt[dta, on = "group", allow.cartesian = TRUE, nomatch = 0]
  # now we remove rows where persons are the same:
  dt1 <- dt1[person != p2] # remove equal persons
  # and also we need to remove rows where person1 and person2 are the same,
  # just in different order , example:
  # 2:     a    Tom    Jerry
  # 3:     a  Jerry      Tom
  # is the same, if I get it right then you did this using apply in the end of code,
  # but it would be much better if we could reduce data now
  # also my approach will be much faster (we take pairwise min word to 2 column
  # and max to the last):
  l1 <- pmin(dt1[[2]], dt1[[3]])
  l2 <- pmax(dt1[[2]], dt1[[3]])
  set(dt1, j = 2L, value = l1)
  set(dt1, j = 3L, value = l2)
  # now lets clear memory and take unique rows of dt1:
  rm(l1, l2, dt)
  dt1 <- unique(dt1)
  gc()
  # change name for group column:
  setnames(dta, "group", "g2")
  # second merge:
  dt2 <- dt1[dta, on = "p2", allow.cartesian = TRUE, nomatch = 0]
  rm(dt1)
  gc()
  setnames(dta, "p2", "p3")
  dt3 <- dt2[dta, on = "g2", allow.cartesian = TRUE, nomatch = 0] # third merge
  rm(dt2)
  gc()
  dt3 <- dt3[p3 != p2 & p3 != person] # removing equal persons
  gc()
  dt3 <- dt3[, .(person, p2, p3)]
  gc()
  return(dt3[])
}

小数据集示例：

df <- data.frame(group = c("a","a","b","b","b","c"),
                 person = c("Tom","Jerry","Tom","Anna","Sam","Nic"),
                 stringsAsFactors = FALSE)
df
myFun(df)
#    person  p2    p3
# 1:   Anna Tom Jerry
# 2:    Sam Tom Jerry
# 3:  Jerry Tom  Anna
# 4:    Sam Tom  Anna
# 5:  Jerry Tom   Sam
# 6:   Anna Tom   Sam
# 7:   Anna Sam   Tom

与您的结果相似但不完全相同

现在有了更大的数据：

set.seed(33)
N <- 10e6
dt <- data.frame(group = sample(3.7e6, N, replace = TRUE),
                 person = sample(6.8e6, N, replace = TRUE))
system.time(results <- myFun(dt)) # 13.22 sek

rm(results)
gc()

还有：

set.seed(33)
N <- 14e6
dt <- data.frame(group = sample(3.7e6, N, replace = TRUE),
                 person = sample(6.8e6, N, replace = TRUE))
system.time(results <- myFun(dt)) # around 40 sek, but RAM does get used to max

更新：

也许你可以试试这个拆分方法，比如nparts 6-10？：

myFunNew3 <- function(dt, nparts = 2) {
  require(data.table)
  setDT(dt)
  setkey(dt, group, person)
  dta <- copy(dt)

  # split into N parts
  splits <- rep(1:nparts, each = ceiling(dt[, .N]/nparts))
  set(dt, j = "splits", value = splits)
  dtl <- split(dt, by = "splits", keep.by = F)
  set(dt, j = "splits", value = NULL)
  rm(splits)
  gc()

  i = 1
  for (i in seq_along(dtl)) {
    X <- copy(dtl[[i]])
    setnames(dta, c("group", "person"))
    X <- X[dta, on = "group", allow.cartesian = TRUE, nomatch = 0]
    X <- X[person != i.person]
    gc()
    X <- X[dta, on = "person", allow.cartesian = TRUE, nomatch = 0]
    gc()
    setnames(dta, "group", "i.group")
    X <- X[dta, on = "i.group", allow.cartesian = TRUE, nomatch = 0] 
    gc()
    setnames(X, "i.person.1", "pers2")
    setnames(X, "i.person", "pers1" )
    setnames(X, "person", "person_in_common" )
    X <- X[, .(pers1, pers2, person_in_common)]
    gc()
    X <- X[pers1 != pers2 & person_in_common != pers1 & person_in_common != pers2]
    gc()
    name1 <- "pers1"
    name2 <- "pers2"
    l1 <- pmin(X[[name1]], X[[name2]])
    l2 <- pmax(X[[name1]], X[[name2]])
    set(X, j = name1, value = l1)
    set(X, j = name2, value = l2)
    rm(l1, l2)
    gc()
    X <- unique(X)
    gc()
    if (i > 1) {
      X1 <- rbindlist(list(X1, X), use.names = T, fill = T)
      X1 <- unique(X1)
      rm(X)
      gc()
    } else {
      X1 <- copy(X)
    }
    dtl[[i]] <- 0L
    gc()
  }
  rm(dta, dtl)
  gc()
  setkey(X1, pers1, pers2, person_in_common)
  X1[]
}