合并边属性以生成顶点属性

编程问答 2022-06-12

问题描述

我有一个具有边缘属性的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"),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

解决方法

也许以下功能解决了将边属性分配给顶点属性的问题。

下面的代码使用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,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"),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)
igraphrr