如何迭代定义映射参数来收缩顶点链？

Question

我有一个简单的图表 g。在保留原图布局的情况下，通过删除度数为2的顶点来平滑图。与 Mathematica 中的相同 task was solved。

library(igraph)
set.seed(1)
# preprocessing
g          <- sample_gnp(40, 1/20)
V(g)$name  <- seq(1:vcount(g))
components <- clusters(g, mode="weak")
biggest_cluster_id <- which.max(components$csize)
vert_ids           <- V(g)[components$membership == biggest_cluster_id]
vert_ids

# input random graph
g    <- induced_subgraph(g, vert_ids)
LO = layout.fruchterman.reingold(g)
plot(g, vertex.color = ifelse(degree(g)==2, "red", "green"), main ="g", layout = LO)

我选择了度数为 2 的顶点链。

subg     <- induced_subgraph(g, degree(g)==2)
subg_ids <- V(subg); subg_ids

我已经阅读了Q&A并且我手动定义了contract()函数的mapping参数。

# join nodes 3 -> 14, 15 -> 40, 13 -> 31, 29 -> 6
mapping = c(2, 3, 4, 5, 6, 7, 8, 10, 13, 3, 15, 16, 17, 18, 19, 20, 21, 22, 23, 25, 26, 27, 6, 30, 13, 32, 33, 34, 35, 36, 38, 39, 15)

g2 <- simplify(contract(g, mapping=mapping, vertex.attr.comb=toString))
# L2 <- LO[-as.numeric(c(14, 40, 31, 6)),] # not working
plot(g2, vertex.color = ifelse(degree(g2)==2, "red", "green"), main ="g2")

问题。迭代定义mapping参数的可能方法是什么？

Answer 1

这只是部分答案，因为它没有提供自动计算收缩的方法。但是，我可以提供一些关于手动映射的见解：

您的顶点有名称，因此这些名称用于参考，而不是从 1 到 n 的内部顶点编号。在映射中我们需要给出收缩后顶点的新ID。

原来的ID是

> V(g)
+ 33/33 vertices, named, from 0af52c3:
  [1] 2  3  4  5  6  7  8  10 13 14 15 16 17 18 19 20 21 22 23 25 26 27 29 30 31 32 33 34 35 36 38 39 40

新 ID 可以给出（存在多种可能性）：

mapping <- c(6, 14, 6, 5, 6, 7, 7, 10, 31, 14, 15, 16, 17, 14, 6, 7, 31, 22, 6, 25, 26, 27, 14, 30, 31, 6, 6, 34, 35, 36, 38, 39, 15)

为了更好地了解：

old ID:   2  3 4 5 6 7 8 10 13 14 15 16 17 18 19 20 21 22 23 25 26 27 29 30 31 32 33 34 35 36 38 39 40
new ID:   6 14 6 5 6 7 7 10 31 14 15 16 17 14  6  7 31 22  6 25 26 27 14 30 31  6  6 34 35 36 38 39 15

这导致：

g2 <- simplify(contract(g, mapping=mapping, vertex.attr.comb=toString))
plot(g2, vertex.color = ifelse(degree(g2)==2, "red", "green"), main ="g2")

要摆脱现在存在的度数为 0 的节点，您可以这样做：

g3 <- delete.vertices(g2, which(degree(g2) == 0))

或者，您可以删除无名节点，甚至可能更干净：

g3 <- delete.vertices(g2, which(names(V(g2)) == ""))

要保持原来的布局你可以这样做：

L3 <- LO[-which(mapping != as.numeric(names(V(g)))),]
plot(g3, layout = L3)

但在这种情况下不太好看...

Answer 2

这里是contract中没有mapping的选项（所以不需要手动配置mapping）

g2 <- graph_from_data_frame(
  rbind(
    get.data.frame(delete.vertices(g, names(subg_ids))),
    do.call(
      rbind,
      lapply(
        decompose(subg),
        function(x) {
          nbs <- names(unlist(neighborhood(g, nodes = names(V(x))[degree(x) < 2])))
          setNames(data.frame(t(subset(nbs, !nbs %in% names(subg_ids)))), c("from", "to"))
        }
      )
    )
  ),
  directed = FALSE
)

你会在运行

之后看到下图

plot(g2, main = "g2", layout = LO[match(names(V(g2)), names(V(g))), ])

如何迭代定义映射参数来收缩顶点链？

How to define the mapping parameter iteratively to contract vertices chains?

r

subgraph

igraph