在R中为igraph网络分析生成带Origin属性的边列表

问题背景 #

已导入Excel文件并拆分Contacts列为多列，去除空格后得到如下结构的数据集：

structure(list(ID = c("ID_003", "ID_004", "ID_009", "ID_009"), 
    Contacts_1 = c("ID_001", "ID_001", "ID_001", "ID_398"), Contacts_2 = c("ID_002", 
    "ID_002", "ID_002", NA), Contacts_3 = c("ID_004", "ID_003", 
    "ID_003", NA), Contacts_4 = c("ID_005", "ID_005", "ID_004", 
    NA), Contacts_5 = c("ID_006", "ID_006", "ID_005", NA), Contacts_6 = c("ID_007", 
    "ID_007", "ID_006", NA), Contacts_7 = c("ID_008", "ID_008", 
    "ID_007", NA), Contacts_8 = c("ID_009", "ID_009", "ID_008", 
    NA), Contacts_9 = c(NA, NA, "ID_011", NA), Contacts_10 = c(NA, 
    NA, "ID_012", NA), Contacts_11 = c(NA, NA, "ID_013", NA), 
    Contacts_12 = c(NA, NA, "ID_016", NA), Contacts_13 = c(NA, 
    NA, "ID_017", NA), Contacts_14 = c(NA, NA, "ID_028", NA), 
    Contacts_15 = c(NA, NA, "ID_040", NA), Contacts_16 = c(NA_character_, 
    NA_character_, NA_character_, NA_character_), Contacts_17 = c(NA_character_, 
    NA_character_, NA_character_, NA_character_), Contacts_18 = c(NA_character_, 
    NA_character_, NA_character_, NA_character_), Contacts_19 = c(NA_character_, 
    NA_character_, NA_character_, NA_character_), Contacts_20 = c(NA_character_, 
    NA_character_, NA_character_, NA_character_), Origin = c("1", 
    "1", "1", "2")), class = "data.frame", row.names = c(NA, 
-4L))

此前尝试生成无属性边列表，但无法将Origin作为第三列保留，期望得到包含V1、V2、Origin三列的边列表，格式如下：

原代码如下：

test<-separate(ID_Kontakt_import_test, 'Contacts 1', paste("Contacts", 1:20, sep="_"), sep=",", extra="drop")
test<-data.frame(lapply(test,trimws),stringsAsFactors = FALSE)
m <- as.matrix(test)
el <- cbind(m[, 1], c(m[, -1])) #create edgelist 

el<-na.omit(el) #drop NA
dups <- duplicated(t(apply(el, 1, sort)))
el2<-el[!dups, ] #drop duplicates

解决方案 #

以下两种方法均可生成带Origin属性的边列表，按需选择即可：

方法1：基于tidyverse的简洁实现 #

利用pivot_longer将宽格式转为长格式，同步保留Origin属性：

# 加载工具包
library(tidyverse)

# 处理数据集生成目标边列表
edgelist <- test %>%
  # 将所有Contacts列转为长格式，自动过滤NA值
  pivot_longer(cols = starts_with("Contacts_"), 
               values_to = "V2",
               values_drop_na = TRUE) %>%
  # 重命名ID列为V1，保留Origin
  rename(V1 = ID) %>%
  select(V1, V2, Origin) %>%
  # 去除无向图中的重复边
  mutate(sorted_edge = pmap_chr(list(V1, V2), ~paste(sort(c(..1, ..2)), collapse = "-"))) %>%
  distinct(sorted_edge, .keep_all = TRUE) %>%
  select(-sorted_edge)

方法2：修改原有矩阵操作逻辑 #

在原代码基础上，同步绑定Origin的对应值：

# 拆分ID、Origin和联系人列
id_origin <- test[, c("ID", "Origin")]
contacts_cols <- test[, grep("^Contacts_", colnames(test))]

# 逐行生成带Origin的边记录
el_with_origin <- do.call(rbind, lapply(1:nrow(test), function(i) {
  valid_contacts <- na.omit(contacts_cols[i, ])
  if (length(valid_contacts) == 0) return(NULL)
  # 绑定当前ID的所有有效联系人与对应Origin
  cbind(V1 = rep(id_origin$ID[i], length(valid_contacts)),
        V2 = valid_contacts,
        Origin = rep(id_origin$Origin[i], length(valid_contacts)))
}))

# 转为数据框并去重
el_with_origin <- as.data.frame(el_with_origin, stringsAsFactors = FALSE)
dups <- duplicated(t(apply(el_with_origin[, c("V1", "V2")], 1, sort)))
final_edgelist <- el_with_origin[!dups, ]

生成的边列表可直接用于igraph网络构建：

library(igraph)
graph <- graph_from_data_frame(final_edgelist, directed = FALSE)

内容的提问来源于stack exchange，提问作者MemeBeauftragter