r - 过滤逻辑和对称矩阵

Question

我有一个逻辑对称矩阵，我想根据对角线上的值创建块。
这是我的矩阵:

MAT <- data.frame(matrix(data = c(rep(TRUE, 9), rep(FALSE, 3), rep(TRUE, 3), FALSE, rep(TRUE, 3), rep(FALSE, 2), TRUE, 
                FALSE, rep(TRUE, 2), FALSE, TRUE, FALSE, rep(TRUE, 3), FALSE, rep(TRUE, 4)), 6))

 [,1]  [,2]  [,3]  [,4]  [,5]  [,6]
[1,] TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
[2,] TRUE  TRUE  TRUE FALSE FALSE FALSE
[3,] TRUE  TRUE  TRUE FALSE  TRUE  TRUE
[4,] TRUE FALSE FALSE  TRUE FALSE  TRUE
[5,] TRUE FALSE  TRUE FALSE  TRUE  TRUE
[6,] TRUE FALSE  TRUE  TRUE  TRUE  TRUE

这是所需的矩阵:

我们可以看到一个块是基于 TRUE 值的。所有列和行必须通过 TRUE 相互关联才能成为块。一旦我们有一个 FALSE 就没有阻塞。我们可以有一个只由一列组成的块，如第四列。
我的目标是在属于一个块的每一列中放置相同的数字，如图所示。

Answer 1

问题指出 MAT 是一个矩阵，但实际上，它在那里被定义为一个 data.frame。这很重要，因为 all(MAT)其中问题中定义的 MAT 在 R 4.0 中给出了错误，但在 R 4.1 中没有，因此请确保您使用的是 R 4.1 和下面的代码。交替使用 MAT <- as.matrix(MAT) 将 MAT 转换为矩阵在这种情况下，下面的代码适用于 4.1 和 4.0 及更早版本。
1) 循环 如果 MAT[i:j, i:j] 中的所有单元格都为 TRUE，则 is.complete(i, j) 为 TRUE。如果 p 到 i 是完整的，而 p 到 i+1 是不完整的，则 p 到 i 是一个块，因此将 i 记录在 d 中，然后在最后找到每个块的长度并使用 rep 创建所需的向量并将其放入列名，因为不能将逻辑值和整数值混合在一起。

is.complete <- function(i, j) all(MAT[i:j, i:j])

i <- p <- 1
d <- c()
for(i in 1:nrow(MAT)) {
  ok <- is.complete(p, i) && (i == nrow(MAT) || !is.complete(p, i+1) )
  if (ok) { p <- i+1; d <- c(d, i) }
}
colnames(MAT) <- rep(seq_along(d), diff(c(0, d)))
MAT

给予:

     1     1     1     2     3     3
1 TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
2 TRUE  TRUE  TRUE FALSE FALSE FALSE
3 TRUE  TRUE  TRUE FALSE  TRUE  TRUE
4 TRUE FALSE FALSE  TRUE FALSE  TRUE
5 TRUE FALSE  TRUE FALSE  TRUE  TRUE
6 TRUE FALSE  TRUE  TRUE  TRUE  TRUE

2)减少另一种可能性是减少。我们累积块的当前开始，p。在每一步，我们考虑下一个索引 i，如果从 p 到 i 的块完全为真，那么我们继续 p 以供考虑；否则我们在 i 处开始一个新块。最后，Reduce 返回块的每一行(或列)重复的块开始的向量。然后我们可以转换为 factor 并取整数级别来获得 1、2、... 这种方法很紧凑并且不使用显式循环。

f <- function(p, i) if (all(MAT[p:i, p:i])) p else i
colnames(MAT) <- as.integer(factor(Reduce(f, 1:nrow(MAT), acc = TRUE)))
MAT

给予:

     1     1     1     2     3     3
1 TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
2 TRUE  TRUE  TRUE FALSE FALSE FALSE
3 TRUE  TRUE  TRUE FALSE  TRUE  TRUE
4 TRUE FALSE FALSE  TRUE FALSE  TRUE
5 TRUE FALSE  TRUE FALSE  TRUE  TRUE
6 TRUE FALSE  TRUE  TRUE  TRUE  TRUE

3)最大化块中的单元格迄今为止的解决方案本质上是贪婪的。他们取最大的块，当找不到更大的块时，开始一个新的块；但是，如果希望最大化块中的单元格数量，那么这可能不会给出最大值。
如果我们将 MAT 视为邻接矩阵，我们可以将其转换为图，在这种情况下，块对应于完整的子图，也称为集团。我们生成所有的团并形成一个 nrow(MAT) 行矩阵 K，每列一个团，这样每一列都是一个 0/​​1 向量，指示 MAT 中的哪些行在该团中。如果有
该矩阵中的 p 列然后我们形成一个目标 p 向量 v 使得
v[i] 等于 sum(K[, i])^2，它是对应于团 i 的块中的单元格数。由此我们形成整数线性程序，通过选择满足以下条件的 0/1 向量来最大化块中的单元格数量:

max v'x such that Kx = 1 
x is 0/1 vector

其中 1 是 nrow(K) 个向量。这被称为集合分区问题。

library(igraph)
cli <- cliques(graph_from_adjacency_matrix(as.matrix(MAT), mode = "undirected"))
K <- +sapply(cli, function(x) colnames(MAT) %in% names(x))

library(lpSolve)
obj <- colSums(K)^2
res <- lp("max", obj, K, "=", 1, all.bin = TRUE)
Ksoln <- K[, res$solution == 1]
o <- order(apply(Ksoln, 2, which.max))
colnames(MAT) <- Ksoln[, o] %*% 1:ncol(Ksoln)
MAT

给予:

     1     2     1     3     1     1
1 TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
2 TRUE  TRUE  TRUE FALSE FALSE FALSE
3 TRUE  TRUE  TRUE FALSE  TRUE  TRUE
4 TRUE FALSE FALSE  TRUE FALSE  TRUE
5 TRUE FALSE  TRUE FALSE  TRUE  TRUE
6 TRUE FALSE  TRUE  TRUE  TRUE  TRUE

或按块排序:

o <- order(as.numeric(colnames(MAT)))
MAT2 <- as.matrix(MAT)[o, o]
colnames(MAT2) <- sub("\\.*", "", colnames(MAT2))
MAT2

给出这个重新排序的矩阵:

        1     1     1     1     2     3
[1,] TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
[2,] TRUE  TRUE  TRUE  TRUE  TRUE FALSE
[3,] TRUE  TRUE  TRUE  TRUE FALSE FALSE
[4,] TRUE  TRUE  TRUE  TRUE FALSE  TRUE
[5,] TRUE  TRUE FALSE FALSE  TRUE FALSE
[6,] TRUE FALSE FALSE  TRUE FALSE  TRUE

我们看到这个解决方案有 18 个单元格在块中

res$objval
## [1] 18

而对于贪婪的解决方案，块中只有 3^2 + 1^2 + 2^2 = 14 个单元格。
4) 在评论中，发帖人表示他们对 (3) 的变体感兴趣，其中组被限制为连续的。要做到这一点，只需将 K 矩阵限制为代表连续组的那些列，即添加两行涉及 is.consec 的代码，下面用 ## 标记。我们还使用了发布者在下面的评论中定义的修改后的输入，并用 ## 标记了这些行。该代码在其他方面与 (3) 相同。

MAT <- data.frame(matrix(data = c(rep(TRUE, 9), rep(FALSE, 3), 
  rep(TRUE, 3), FALSE, rep(TRUE, 3), rep(FALSE, 2), TRUE, 
  FALSE, rep(TRUE, 2), FALSE, TRUE, FALSE, rep(TRUE, 3), FALSE, 
  rep(TRUE, 4)), 6))
MAT<-cbind(MAT,c(TRUE,FALSE,rep(TRUE,2),FALSE,TRUE)) ##
MAT<-rbind(MAT,c(TRUE,FALSE,rep(TRUE,2),FALSE,rep(TRUE,2))) ##
MAT<-cbind(MAT,c(rep(FALSE,5),rep(TRUE,2))) ##
MAT<-rbind(MAT,c(rep(FALSE,5),rep(TRUE,3))) ##

library(igraph)
cli <- cliques(graph_from_adjacency_matrix(as.matrix(MAT), mode = "undirected"))
K <- +sapply(cli, function(x) colnames(MAT) %in% names(x))
 
is.consec <- function(x) sum(x == 1) == 1 ||  all(diff(which(x == 1)) == 1) ##
K <- K[, apply(K, 2, is.consec)] ##
 
library(lpSolve)
obj <- colSums(K)^2
res <- lp("max", obj, K, "=", 1, all.bin = TRUE)
Ksoln <- K[, res$solution == 1]
o <- order(apply(Ksoln, 2, which.max))
colnames(MAT) <- Ksoln[, o] %*% 1:ncol(Ksoln)
MAT

给予:

      1     1     1     2     3     4     4     4
1  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE FALSE
2  TRUE  TRUE  TRUE FALSE FALSE FALSE FALSE FALSE
3  TRUE  TRUE  TRUE FALSE  TRUE  TRUE  TRUE FALSE
4  TRUE FALSE FALSE  TRUE FALSE  TRUE  TRUE FALSE
5  TRUE FALSE  TRUE FALSE  TRUE  TRUE FALSE FALSE
6  TRUE FALSE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
7  TRUE FALSE  TRUE  TRUE FALSE  TRUE  TRUE  TRUE
8 FALSE FALSE FALSE FALSE FALSE  TRUE  TRUE  TRUE