结合边属性生成顶点属性

Question

我有一个带有边缘属性的 igraph 网络。

我想生成一个结合边属性的顶点属性。具体来说，我希望每个顶点根据其自身边缘属性的模式（或任何其他操作）分配一个属性。

在我的示例中，边表示人们之间在某个主题上的协作。

library(igraph)
library(RColorBrewer)
g <- graph("Zachary") # the Zachary carate club
V(g)$names <- c(1:gorder(g))
set.seed(1); E(g)$relation <- sample(c("A","B","C"), gsize(g), replace = TRUE)
set.seed(1); E(g)$relation_col <- sample(brewer.pal(3, "Set1"), gsize(g), replace = TRUE)
    
plot(g, vertex.size=10, vertex.label=NA, 
         vertex.color="grey",
         edge.color=E(g)$relation_col)

我无法生成特定于顶点的属性。当我计算模式时，它是针对整个网络完成的，而不是针对特定边缘的

getmode <- function(v) {
      uniqv <- unique(v)
      uniqv[which.max(tabulate(match(v, uniqv)))]
    }
g <- set_vertex_attr(g, "relation", value=getmode(E(g)$relation))

vertex_attr(g)
$names
 [1]  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34

$relation
 [1] "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B" "B"

手册参考：https://igraph.org/r/doc/igraph-attribute-combination.html

Answer 1

也许下面的函数解决了将边属性分配给顶点属性的问题。

下面的代码使用来自this SO post 的函数Modes。如果有多个模式，它会随机选择一个sample。因此，请致电set.seed 以使结果可重现。

library(igraph)
library(RColorBrewer)

Modes <- function(x) {
  ux <- unique(x)
  tab <- tabulate(match(x, ux))
  ux[tab == max(tab)]
}

attr_from_edge_to_vertex <- function(x, e_attr, v_attr){
  f <- function(v, edges_mat){
    i1 <- which(edges_mat[,1] == v)
    i2 <- which(edges_mat[,2] == v)
    i <- union(i1, i2)
    ea <- edge_attr(x, v_attr, index = E(x)[i])
    ea <- Modes(ea)
    if(length(ea) > 1) sample(ea, 1) else ea
  }
  if(missing(e_attr)){
    msg <- paste("Edge attribute", sQuote(e_attr), "doesn't exist.")
    msg <- paste(msg, "Returning the graph unchanged.")
    warning(msg)
  } else {
    es <- ends(x, es = E(x))
    if(missing(v_attr)) v_attr <- e_attr
    for(v in as_ids(V(x))){
      va <- f(v, es)
      vertex_attr(x, v_attr, index = v) <- va
    }
  }
  x
}

g <- graph("Zachary") # the Zachary carate club
V(g)$names <- c(1:gorder(g))
set.seed(1); E(g)$relation <- sample(c("A","B","C"), gsize(g), replace = TRUE)
set.seed(1); E(g)$relation_col <- sample(brewer.pal(3, "Set1"), gsize(g), replace = TRUE)

h <- attr_from_edge_to_vertex(g, "relation_col")
vertex_attr(h, "relation_col")
# [1] "#E41A1C" "#E41A1C" "#377EB8" "#E41A1C" "#377EB8" "#377EB8" "#377EB8" "#4DAF4A" "#377EB8"
#[10] "#E41A1C" "#377EB8" "#4DAF4A" "#4DAF4A" "#E41A1C" "#4DAF4A" "#377EB8" "#4DAF4A" "#4DAF4A"
#[19] "#377EB8" "#E41A1C" "#377EB8" "#E41A1C" "#377EB8" "#377EB8" "#4DAF4A" "#4DAF4A" "#377EB8"
#[28] "#377EB8" "#E41A1C" "#E41A1C" "#E41A1C" "#4DAF4A" "#4DAF4A" "#E41A1C"


plot(g, vertex.size=10, vertex.label=NA,
     vertex.color=vertex_attr(h, "relation_col"),
     edge.color=E(g)$relation_col)