在保留边属性的同时聚合 igraph 中双向边的权重

如何解决在保留边属性的同时聚合 igraph 中双向边的权重

在有向加权图中，当我有双向边时（即 A->B 和 B->A 存在），我想减去两个权重，使得生成的边缘方向在较大权重的方向上。我下面的示例仅针对具有“权重”属性的边完成了此操作，但是当我有其他边属性（多个边）时，我希望在聚合时保留这些属性。我的示例的问题是，当我通过 as_adjacency_matrix 将我的图形转换为邻接矩阵时，该函数会合并权重，而我会丢失属性数据。如何在保留边缘属性数据的同时组合双向边缘权重？

具有“组”属性的示例：

library(dplyr)
library(igraph)
library(visNetwork)

df<-data.frame(from = c('A','A','B','C','G','G'),to = c('B','E','F','C'),weight = c(50,30,20,15,45,34,60,40,100,25,35,72,50),group = c('1','2','1','2'))

g<-igraph::graph_from_data_frame(df)

# visual - original graph
edges<-igraph::as_data_frame(g,what = 'edges')
nodes<-data.frame(id = append(edges$from,edges$to) %>% unique())
visNetwork(nodes=nodes,edges = edges)%>%
  visEdges(arrows ="to")

# aggregate bidirectional edges 
g_old<-g
mx_old<-as_adjacency_matrix(g_old,attr = "weight") %>% as.matrix()
mx_new<-mx_old

u = mx_old[row(mx_old) == (col(mx_old) - 1)] # upper off-diagonal
l = mx_old[row(mx_old) == (col(mx_old) + 1)] # lower off-diagonal

mx_new[row(mx_new) == (col(mx_new) - 1)]<-ifelse((u - l) > 0,(u - l),ifelse((u - l) < 0,u))
mx_new[row(mx_new) == (col(mx_new) + 1)]<-ifelse((l - u) > 0,(l - u),ifelse((l - u) < 0,l))

# new graph with bidrectional edges removes
g_new = graph_from_adjacency_matrix(mx_new,weighted = TRUE)

# visual - new graph
edges<-igraph::as_data_frame(g_new,edges = edges)%>%
  visEdges(arrows ="to")

解决方法

这是一个用 dplyr 实现的函数。我相信有更优雅的方法，但这提供了一个解决方案。

library(dplyr)
remove_bidirect_edges<-function(df,weight_attr) {
  
  wt<-weight_attr
  join_cols<-names(df)
  join_cols<-join_cols[join_cols != wt]
  
  df1<-df %>% rename("wt_attr"=wt)
  df2<-df1 %>% rename('to'='from','from'='to')
  
  df3<-left_join(df1,df2,by = join_cols) %>%
    mutate(diff = wt_attr.x - wt_attr.y) %>%
    filter(!is.na(diff)) %>%
    mutate('NewWeight' = diff)%>%
    select(-wt_attr.x,-wt_attr.y,-diff)
  
  df_return<-left_join(df1,df3,by = join_cols)%>%
    mutate(wt_attr = ifelse(!is.na(NewWeight),NewWeight,wt_attr)) %>%
    filter(wt_attr>=0)%>%
    select(-NewWeight)
  
  names(df_return)[names(df_return) == "wt_attr"] <- wt
  
  return(df_return)
}