所有成对行产品的总和作为双向矩阵

Question

我正在研究一些高通量基因数据，并根据贝叶斯统计数据进行一种相关性分析。 我需要做的一件事是找到数据集中每个成对的产品组合，并找到每个结果行的总和。

因此，例如，对于高吞吐量数据集矩阵Dataset

(Dataset <- structure(list(`Condition 1` = c(1L, 3L, 2L, 2L), `Condition 2` = c(2L, 1L, 7L, 2L), `Condition 3` = c(4L, 1L, 2L, 5L)), .Names = c("Condition 1", "Condition 2", "Condition 3"), class = "data.frame", row.names = c("Gene A", "Gene B", "Gene C", "Gene D")))
       Condition 1 Condition 2   Condition 3
Gene A           1           2             4
Gene B           3           1             1
Gene C           2           7             2
Gene D           2           2             5

首先，我想将每对可能的行相乘，得到以下称为Comb矩阵：

              Condition 1 Condition 2 Condition 3
Gene A Gene A           1           4           9
Gene A Gene B           3           2           4
Gene A Gene C           2          14           8
Gene A Gene D           2           4          20
Gene B Gene B           9           1           1
Gene B Gene C           6           7           2
Gene B Gene D           6           2           5
Gene C Gene C           4          49           4
Gene C Gene D           4          14          10
Gene D Gene D           4           4          25

在我想找到每个产品的行总和并以矩阵的形式得到总和（我将称之为CombSums ）：

            Gene A       Gene B      Gene C      Gene D 
Gene A          NA           10          24          26
Gene B          10           NA          15          13
Gene C          24           15          NA          28
Gene D          26           13          28          NA

当我尝试这样做时，我能想到的最好的是

combs <- combn(seq_len(nrow(Dataset)), 2)
Comb <- Dataset[combs[1,], ] * Dataset[combs[2,], ]
rownames(Comb) <- apply(combn(rownames(Comb), 2), 2, paste, collapse = " ")
CombSums <- rowSums(Comb)

哪个会给我作为列表的总和，如下所示：

                    [1,]
Gene A Gene B       10
Gene A Gene C       24 
Gene A Gene D       26 
Gene B Gene C       15
Gene B Gene D       13
Gene C Gene D       28

不幸的是，我希望它作为一个双向矩阵而不是列表，所以这不是很有效，所以如果有人可以建议一种方法将总和作为一个矩阵，那将是一个很大的帮助。

Answer 1

您可以通过使用lapply和outer计算原始数据框中每列的成对产品来实现此lapply ，然后您可以将所有这些成对产品与Reduce和+一起添加。

Reduce("+", lapply(dat, function(x) outer(x, x)))
#      [,1] [,2] [,3] [,4]
# [1,]   21    9   24   26
# [2,]    9   11   15   13
# [3,]   24   15   57   28
# [4,]   26   13   28   33

该主题的一个变体是内存密集度较低（因为它不需要同时存储每个列的矩阵），但更多的输入将是：

ret <- outer(dat[,1], dat[,1])
for (i in 2:ncol(dat)) ret <- ret + outer(dat[,i], dat[,i])
ret
#      [,1] [,2] [,3] [,4]
# [1,]   21    9   24   26
# [2,]    9   11   15   13
# [3,]   24   15   57   28
# [4,]   26   13   28   33

以下是目前针对100 x 100数据框架提出的方法的基准：

# Larger dataset
set.seed(144)
dat <- as.data.frame(matrix(rnorm(10000), nrow=100))

josilber <- function(dat) Reduce("+", lapply(dat, function(x) outer(x, x)))
josilber2 <- function(dat) {
  ret <- outer(dat[,1], dat[,1])
  for (i in 2:ncol(dat)) ret <- ret + outer(dat[,i], dat[,i])
  ret
}
frank <- function(DF) {
  mat   <- as.matrix(DF)
  pairs <- combn(1:nrow(DF),2)
  vals  <- rowSums(mat[pairs[1,],]*mat[pairs[2,],])
  res   <- matrix(,nrow(DF),nrow(DF),dimnames=list(rownames(DF),rownames(DF)))
  res[lower.tri(res)] <- vals
  res
}

library(microbenchmark)
microbenchmark(josilber(dat), josilber2(dat), josilberRcpp(as.matrix(dat)), frank(dat))
# Unit: microseconds
#                          expr       min        lq      mean    median        uq       max neval
#                 josilber(dat)  6867.499 45437.277 45506.731 46372.576 47549.834 85494.063   100
#                josilber2(dat)  6831.692  7982.539 10245.459  9109.023 10883.965 50612.600   100
#  josilberRcpp(as.matrix(dat))   989.592  1112.316  1290.617  1204.388  1483.638  2384.348   100
#                    frank(dat) 13043.912 53369.804 52488.997 53921.402 54855.583 62566.730   100

Answer 2

使用combn ，您可以避免进行冗余计算：

mat   <- as.matrix(DF)

pairs <- combn(1:nrow(DF),2)

vals  <- rowSums(mat[pairs[1,],]*mat[pairs[2,],])
res   <- matrix(,nrow(DF),nrow(DF),dimnames=list(rownames(DF),rownames(DF)))
res[lower.tri(res)] <- vals

#       GeneA GeneB GeneC GeneD
# GeneA    NA    NA    NA    NA
# GeneB     9    NA    NA    NA
# GeneC    24    15    NA    NA
# GeneD    26    13    28    NA

你的Comb矩阵是中间结果mat[pairs[1,],]*mat[pairs[2,],] 。

---

整个计算可以在combn内部交替进行：

vals <- combn(rownames(DF),2,FUN=function(x)sum(apply(DF[x,],2,prod)))

正如@josilber在下面的评论中指出的那样，这是非常缓慢的。

---

数据：

DF <- read.table(header=TRUE,text="Condition1 Condition2   Condition3
GeneA           1           2             4
GeneB           3           1             1
GeneC           2           7             2
GeneD           2           2             5")

Answer 3

如果速度是一个重要因素（例如，如果您正在处理一个巨大的矩阵），您可能会发现Rcpp实现很有帮助。 这仅填充矩阵的上三角部分。

library(Rcpp)
cppFunction(
 "NumericMatrix josilberRcpp(NumericMatrix x) {
   const int nr = x.nrow();
   const int nc = x.ncol();
   NumericMatrix y(nr, nr);
   for (int col=0; col < nc; ++col) {
    for (int i=0; i < nr; ++i) {
      for (int j=i; j < nr; ++j) {
        y(i, j) += x(i, col) * x(j, col);
      }
    }
   }
   return y;
}")
josilberRcpp(as.matrix(Dataset))
#      [,1] [,2] [,3] [,4]
# [1,]   21    9   24   26
# [2,]    0   11   15   13
# [3,]    0    0   57   28
# [4,]    0    0    0   33

我的另一个答案提供了基准测试。 请注意，基准测试不包括使用cppFunction的编译时间，这可能非常重要。 因此，此实现可能仅适用于非常大的输入或需要多次使用此功能时。