Блог

В ориентированном взвешенном графе, когда у меня есть двунаправленные ребра (т.Е. Существуют A-> B и B-> A), я хотел бы вычесть два веса таким образом, чтобы результирующее направление ребра было в направлении большего веса. В моем примере ниже это выполняется для ребер только с атрибутом ‘weight’, но когда у меня есть другие атрибуты ребер (несколько ребер), я хочу сохранить атрибуты при агрегировании. Проблема с моим примером заключается в том, что когда я преобразую свой график в матрицу смежности с помощью as_adjacency_matrix , функция объединяет веса, и я теряю данные атрибута. Как я могу объединить двунаправленные веса ребер при сохранении данных атрибутов ребер?

Пример с атрибутом «group»:

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

df<-data.frame(from = c('A','A','B','B','C','C','G','A','A','B','B','C','C','G'),
               to = c('B','C','A','E','F','G','C','B','C','A','E','F','G','C'),
               weight = c(50,30,20,15,45,34,60,40,100,20,25,35,72,50),
               group = c('1','2','2','1','1','1','2','2','1','2','1','1','2','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, 0, u))
mx_new[row(mx_new) == (col(mx_new)   1)]<-ifelse((l - u) > 0, (l - u), ifelse((l - u) < 0, 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, what = 'edges')
nodes<-data.frame(id = append(edges$from, edges$to) %>% unique())
visNetwork(nodes=nodes, 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)
}