计算每对列的相同行值以创建网络图

Question

我有这样的数据：

dat <- data.frame(
  music = c("classical", "jazz", "baroque", "electronic", "ambient"),
  john = c(1,1,0,1,1),
  jeff = c(1,0,0,1,0),
  jane = c(0,1,1,0,0)
)

       music john jeff jane
1  classical    1    1    0
2       jazz    1    0    1
3    baroque    0    0    1
4 electronic    1    1    0
5    ambient    1    0    0

并且想要绘制列上个人之间的重叠 - 他们多久在同一行中都有 1？如果我能得到这个data.frame：

result <- data.frame(person1 = c("john", "john", "jeff"), person2 = c("jeff", "jane", "jane"), overlap = c(2, 1, 0))

  person1 person2 overlap
1    john    jeff       2
2    john    jane       1
3    jeff    jane       0

我可以创建我想要的图表：

library(igraph)
g <- graph.data.frame(result, directed = FALSE)
plot(g, edge.width = result$overlap * 3)

但我正在努力转换数据以计算每对列之间的逐行重叠。我该怎么做？

Answer 1

可能更简单的方法是通过取叉积来创建图的邻接矩阵。然后，您可以将其直接读入 igraph。

library(igraph)

# Take the crossproduct: assumes unique music types in each row
# otherwise aggregate terms
m <- crossprod(as.matrix(dat[-1]))

# You could remove the diagonal terms here
# although it is useful to see the sum for each individual
# You can also remove it in igraph, as below
# diag(m) <- 0

# Create graph
# The weights are stored in E(g)$weight
g <- graph_from_adjacency_matrix(m, mode="undirected", weighted = TRUE)

# Remove edge loops
g <- simplify(g)

Answer 2

也许您想尝试不同的相似度/距离度量，例如 Russel/Roa、Jaccard 等。我的意思是：0 和 0 也可以解释为相似度。无论如何，这是另一种方法：

library(proxy)
m <- (1-as.matrix(dist( t(dat[, -1]), method = "Russel")))*nrow(dat)
m[lower.tri(m, T)] <- NA
(res <- setNames(reshape2::melt(m, na.rm=T), c("p1", "p2", "ol")))
#     p1   p2 ol
# 4 john jeff  2
# 7 john jane  1
# 8 jeff jane  0

Answer 3

以下适用于您的示例：

# build name matrix
nameMat <- t(combn(names(dat[,-1]), 2))
# pre-allocate count vector
overLap <- integer(nrow(nameMat))

# loop through name combos
for(i in 1:nrow(nameMat)) {
  overLap[i] <- sum(rowSums(dat[, nameMat[i,]]) == 2)
}
# construct data.frame
df <- data.frame("person1"=nameMat[,1], "person2"=nameMat[,2], "overLap"=overLap)

如果您不喜欢for 循环，可以使用sapply 来获取重叠计数：

overLap <- sapply(1:(nrow(nameMat)), 
                  function(i) sum(rowSums(dat[, nameMat[i,]]) == 2))

根据@user20650 的建议，您还可以使用combn 计算重叠：

overLap <- combn(dat[-1], 2, FUN=function(i) sum(rowSums(i)==2))

一个long计算重叠的方法如下： overLap

这个较长的版本有一个优点，它可以推广到这些度量在李克特量表上的情况（指示亲和力强度）。在 5 分制的情况下，可以将 c(1,1) 改为 c(3,3) 来检验无差异或 c(5,5)。如果兴趣是对立的观点，例如 c(1,5)，则必须操纵和复制 nameMat：

newNameMat <- rbind(nameMat, cibind(nameMat[,2], nameMat[,1])

并在此矩阵上执行计算。将这些操作封装到一个可以计算李克特量表组合的任何成对比较的函数中并不难。