R语言 图数据表的高效分组聚类

k4aesqcs  于 2023-06-27  发布在  其他
关注(0)|答案(3)|浏览(157)

我有以下结构的图形数据:

library(data.table)

dt = data.table(
  n1 = c(1, 1, 2, 4, 6),
  n2 = c(2, 3, 3, 5, 3)
)

> dt
   n1 n2
1:  1  2
2:  1  3
3:  2  3
4:  4  5
5:  6  3

其中dt描述节点之间的链路。我想以下面的方式来识别这个结构中的集群集合:

output = data.table(
  node = 1:6,
  grp = c(1,1,1,2,2,1)
)

> output
   node grp
1:    1   1
2:    2   1
3:    3   1
4:    4   2
5:    5   2
6:    6   1

当然,我可以使用igraph库来做到这一点:

library(igraph)
g = graph_from_data_frame(dt)
plot(g)

> clusters(g)$membership
1 2 4 6 3 5 
1 1 2 1 1 2

但是,我想尽量减少图书馆的使用。因此,我想使用data.table或base R来确定一个高效的操作,该操作使用dt生成成员关系表output。我怀疑它会涉及到dt上的一系列自连接,但还没有能够在具有多个集群的缩放数据上实现这一点。

1cklez4t

1cklez4t1#

这不是一个微不足道的问题。我的解决方案是创建第二个dtdt1)并删除其行,同时将每对节点分配给某个组。

我的第一选择

可以进一步优化,如果你玩它。

l<-list()
itr <- 1
l[[itr]] <- as.numeric(dt[1, ])
dt1 <- dt[2:nrow(dt)]

while( nrow(dt1) > 0){
  
  i <- apply(dt1, 1, function(x) any(x %in% l[[itr]]))
  if(any(i)){
    l[[itr]] <- c(unname(unlist(dt1[i])), l[[itr]])
    dt1 <- dt1[!i]
  } else {
    itr <- itr + 1
    l[[itr]] <- as.numeric(dt1[1,])
    dt1 <- dt1[-1,]
  }
}

output <- data.table(node = unique( c(dt$n1, dt$n2) ), 
                     group = as.numeric(NA), key = "node")

for(i in seq_along(l)){
   output[node %in% l[[i]], group := i][]
}

导致:

> output
   node group
1:    1     1
2:    2     1
3:    3     1
4:    4     2
5:    5     2
6:    6     1

第二个选项

output <- data.table(node = unique( c(dt$n1, dt$n2) ), 
                     group = as.numeric(NA), key = "node")
grpCount <- 2

for(i in 1:nrow(output)){
  
  if(i == 1){
    output$group[1] <- 1
    next
  }
  
  ind <- c(dt$n1[match(output[i, node], dt$n2)] , 
           dt$n2[match(output[i, node], dt$n1)])
  
  grp <- output[match(ind, node), group]
  
  
  if(any(!is.na(grp))){
    
    output[i, group := unique(grp[!is.na(grp)])][]
    
  } else {
    
    output[i, group := grpCount][]
    grpCount <- grpCount + 1 
  }
  
}

> output
   node group
1:    1     1
2:    2     1
3:    3     1
4:    4     2
5:    5     2
6:    6     1
cqoc49vn

cqoc49vn2#

选项一

如果只需要顶点的分组信息

dtt <- copy(dt)
grp <- list()
repeat {
    u <- dtt[1]
    repeat {
        s <- unique(unlist(u))
        idx <- rowSums(matrix(unlist(dtt) %in% s, ncol = 2)) > 0
        uu <- dtt[idx]
        if (nrow(uu) == nrow(u)) {
            break
        }
        u <- uu
    }
    grp[[length(grp) + 1]] <- s
    dtt <- dtt[!idx]
    if (nrow(dtt) == 0) {
        break
    }
}
out <- setorder(
    setnames(
        as.data.table(
            stack(setNames(grp, seq_along(grp)))
        ),
        c("node", "group")
    ),
    "node"
)[]

你将获得

> out
   node group
1:    1     1
2:    2     1
3:    3     1
4:    4     2
5:    5     2
6:    6     1

选项二

如果您想在列表中对dt的行进行分组,这里有一个选项

dtt <- copy(dt)
dtt[, rid := 1:.N]
grp <- list()
repeat {
    s <- dtt[1, ]
    repeat {
        sp <- dtt[rowSums(matrix(as.matrix(dtt) %in% unique(unlist(s[, .(n1, n2)])), ncol = ncol(dtt))) > 0]
        if (nrow(sp) == nrow(s)) {
            s <- sp
            break
        }
        s <- sp
    }
    grp[[length(grp) + 1]] <- s
    dtt <- dtt[!rid %in% s[, rid]]
    if (nrow(dtt) == 0) {
        break
    }
}

使得

> grp
[[1]]
   n1 n2 rid
1:  1  2   1
2:  1  3   2
3:  2  3   3
4:  6  3   5

[[2]]
   n1 n2 rid
1:  4  5   4

选项三

另一个有趣的实现可能是使用***递归***来实现它

f <- function(n, DT = dt) {
    v <- unname(unlist(DT[n]))
    if (n == 1) {
        return(list("1" = v))
    }
    p <- Recall(n - 1)
    done <- FALSE
    for (k in seq_along(p)) {
        if (any(v %in% p[[k]])) {
            p[[k]] <- union(p[[k]], v)
            done <- TRUE
            break
        }
    }
    if (!done) {
        p[[as.character(length(p) + 1)]] <- v
    }
    p
}

我们将获得

> f(nrow(dt))
$`1`
[1] 1 2 3 6

$`2`
[1] 4 5
a14dhokn

a14dhokn3#

下面是一个性能与igraph相当的解决方案。

library(data.table)
library(collapse) # for fmin
library(igraph) # for comparison

dt <- data.table(
  n1 = c(1, 1, 2, 4, 6),
  n2 = c(2, 3, 3, 5, 3)
)

f <- function(dt) {
  u <- unique(unlist(dt))
  m <- array(match(unlist(dt), u), dim(dt))
  i <- c(m)
  p <- 0L
  dt <- data.table(g1 = 1:length(u), g2 = 1L)
  
  while (any(dt[[1]] != dt[[2]])) {
    dt[[(p <- 1L - p) + 1L]] <- fmin(rep(pmin(dt[[p + 1L]][m[,1]], dt[[p + 1L]][m[,2]]), 2), i, na.rm = FALSE, use.g.names = FALSE)
  }
  
  setorder(dt[, .(node = u, grp = match(g1, unique(g1)))], node)
}

测试功能。

f(dt)[]
#>    node grp
#> 1:    1   1
#> 2:    2   1
#> 3:    3   1
#> 4:    4   2
#> 5:    5   2
#> 6:    6   1

在一个更大的问题上比较igraph的计时。

set.seed(1507948709)

dt <- data.table(
  n1 = sample(1e4, 1e4, 1),
  n2 = sample(1e4, 1e4, 1)
)

microbenchmark::microbenchmark(
  f = f(dt),
  clusters = {
    g <- groups(clusters(graph_from_data_frame(dt)))
    setorder(data.table(node = as.integer(unlist(g)), grp = rep.int(1:length(g), lengths(g))), node)
  },
  components = setorder(
    with(
      components(graph_from_data_frame(dt)),
      data.table(node = as.integer(names(membership)), grp = membership)
    ),
    node
  ),
  check = "equal"
)
#> Unit: milliseconds
#>        expr     min       lq     mean   median       uq     max neval
#>           f 39.7481 44.34225 47.36792 46.22055 49.46780 61.8194   100
#>    clusters 33.3727 35.02645 38.08477 36.43500 39.97225 51.7536   100
#>  components 21.8816 23.30190 27.31324 24.65980 27.55200 96.5117   100

相关问题