Question

假设您有一个3维4x4x2阵列：

foo <- structure(c(1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1), .Dim = c(4L, 4L, 2L), .Dimnames = list(c("p1", "p2", "p3", "p4"), c("f1", "f2", "f3", "f4"), c("t1", "t2")))
foo

, , t1

   f1 f2 f3 f4
p1  1  1  0  0
p2  0  1  0  0
p3  0  0  0  0
p4  0  0  0  0

, , t2

   f1 f2 f3 f4
p1  0  0  0  0
p2  0  1  0  0
p3  0  1  1  1
p4  0  0  0  1

此外，你有一个矩阵，它是第一维（p）的选择器：

bar <- structure(c(1, 1, 2, 2), .Dim = c(4L, 1L), .Dimnames = list(c("p1", "p2", "p3", "p4"), NULL))       [,1]
bar
p1    1
p2    1
p3    2
p4    2

如何创建以下两个数组？

数组1有行p1和p2（由bar选择）和列f1和f2（因为p1和p2与t3或t2中的f3和f4无关）：

阵列2具有行p3和p4（再次由条选择）和列f2，f3和f4（因为p3和p4与t1或t2中的f1无关）。此外，第三个维度减少到t2：

, , t2

   f2 f3 f4
p3  1  1  1
p4  0  0  1

我正在考虑使用subset（），apply（）和which（），但这并没有让我在任何地方。

这是一个玩具的例子。最终代码应该应用于类似于2模式网络（模式p和f）的矩阵随时间（t）。

热烈欢迎任何帮助。

Answer 1

像这样？

lapply(unique(bar),function(x){
  flip<-Reduce('+',lapply(dimnames(foo)[[3]],function(z){
    t(foo[names(bar[bar==x]),,z])
  }
         ))
  n<-dimnames(flip[rowSums(flip)!=0,])
  foo[n[[2]],n[[1]],]
}
       )

[[1]]
, , t1

   f1 f2
p1  1  1
p2  0  1

, , t2

   f1 f2
p1  0  0
p2  0  1


[[2]]
, , t1

   f2 f3 f4
p3  0  0  0
p4  0  0  0

, , t2

   f2 f3 f4
p3  1  1  1
p4  0  0  1

Answer 2

这是另一种选择：

lapply(unique(bar), function(i) {
  foo.row <- foo[rownames(foo) %in% rownames(bar)[bar == i],,]
  foo.row[, apply(foo.row, 2, any), apply(foo.row, 3, any), drop=F]
} )

产地：

[[1]]
, , t1

   f1 f2
p1  1  1
p2  0  1

, , t2

   f1 f2
p1  0  0
p2  0  1


[[2]]
, , t2

   f2 f3 f4
p3  1  1  1
p4  0  0  1

您可以忽略警告。它们只是any强制逻辑值。如果他们打扰你，你可以随时做function(x) any(as.logical(x))。

R：根据选择器减少数组

2 个答案: