使用 R 在二进制矩阵中查找模式

发布于 2025-01-09 19:38:30 字数 126 浏览 1 评论 0原文

我有一个 nxn 对称二进制矩阵，我想找到左上角和右下角为 0，右上角和左下角为 1 的最大矩形（区域）。如果我只是用循环来做，从最大到最小检查所有矩形，则 n=100 需要“天”。有人知道如何有效地做到这一点吗？

多谢！

原文

分享到QQ

分享到微博

如果你对这篇内容有疑问，欢迎到本站社区发帖提问参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

发布评论

需要登录才能够评论，你可以免费注册一个本站的账号。

情绪操控生活 2025-01-16 19:38:30

感谢您的回答。我使用的矩阵是随机 Erdos-Renyi 图的邻接矩阵。但可以采用任意随机对称二元矩阵来测试它。到目前为止，我使用了 4 个嵌套循环：

switch<-function(Mat)
{
n=nrow(Mat) 
for (i in 1:(n-1)) { 
    for(j in seq(n,i+1,by=-1)) {
        for(k in 1:(n-1)) { 
            if ((k==i)||(k==j) || (Mat[i,k]==1)||(Mat[j,k]==0)) next 
            for(l in seq(n,k+1,by=-1)) { 
                if ((l==i)||(l==j)|| (Mat[i,l]==0)||(Mat[j,l]==1)) next 
                return(i,j,k,l)
            }
        }
    }
}

thanks for your answers. Matrices I use are adjacency matrices of random Erdos-Renyi graphs. But one can take any random symetrical binary matrix to test it. Until now, I use 4 nested loops :

switch<-function(Mat)
{
n=nrow(Mat) 
for (i in 1:(n-1)) { 
    for(j in seq(n,i+1,by=-1)) {
        for(k in 1:(n-1)) { 
            if ((k==i)||(k==j) || (Mat[i,k]==1)||(Mat[j,k]==0)) next 
            for(l in seq(n,k+1,by=-1)) { 
                if ((l==i)||(l==j)|| (Mat[i,l]==0)||(Mat[j,l]==1)) next 
                return(i,j,k,l)
            }
        }
    }
}

回复收藏 0 原文

一枫情书 2025-01-16 19:38:30

您现在可以尝试以下方法。它不需要对称性，并且为了效率而将所有非零元素视为非零元素。

它循环遍历这些，假设 1 的数量少于零。（您可能希望在相反的情况下循环零，并且零比一少。）

这种方法可能不是最佳的，因为即使尽早识别了最大的框，它也会循环所有的零。在这种情况下，您可以设计一个巧妙的停止条件来短路循环。
但对于 n = 100 来说它仍然很快，在我的机器上需要不到半秒，即使 1 和 0 出现的比例大致相等（最坏的情况）：

f <- function(X) {
    if (!is.logical(X)) {
        storage.mode(X) <- "logical"
    }
    J <- which(X, arr.ind = TRUE, useNames = FALSE)
    i <- J[, 1L]
    j <- J[, 2L]
    nmax <- 0L
    res <- NULL
    for (k in seq_along(i)) {
        i0 <- i[k]
        j0 <- j[k]
        ok <- i < i0 & j > j0
        if (any(ok)) {
            i1 <- i[ok]
            j1 <- j[ok]
            ok <- !(X[i0, j1] | X[i1, j0])
            if (any(ok)) {
                i1 <- i1[ok]
                j1 <- j1[ok]
                n <- (i0 - i1 + 1L) * (j1 - j0 + 1L)
                w <- which.max(n)
                if (n[w] > nmax) {
                    nmax <- n[w]
                    res <- c(i0 = i0, j0 = j0, i1 = i1[w], j1 = j1[w])
                }
            }
        }
    }
    res
}

mkX <- function(n) {
    X <- matrix(sample(0:1, n * n, TRUE), n, n)
    X[upper.tri(X)] <- t(X)[upper.tri(X)]
    X
}

set.seed(1L)
X <- mkX(6L)
X
##      [,1] [,2] [,3] [,4] [,5] [,6]
## [1,]    0    1    0    0    1    0
## [2,]    1    0    1    1    0    0
## [3,]    0    1    0    1    1    1
## [4,]    0    1    1    0    0    0
## [5,]    1    0    1    0    0    1
## [6,]    0    0    1    0    1    0

f(X)
## i0 j0 i1 j1 
##  5  1  1  5

Y <- mkX(100L)
microbenchmark::microbenchmark(f(Y))
## Unit: milliseconds
##  expr     min       lq     mean   median       uq      max neval
##  f(Y) 310.139 318.3363 327.8116 321.4109 326.5088 391.9081   100

Here's an approach that you can try for now. It doesn't require symmetry, and it treats all nonzero elements like ones for efficiency.

It loops over the ones, assuming that there are fewer ones than zeros. (You would want to loop over zeros in the reverse case with fewer zeros than ones.)

This approach probably isn't optimal, since it loops over all of the ones even if the largest box is identified early. You can devise a clever stopping condition to short-circuit the loop in that case.
But it is still fast for n = 100, requiring less than half of a second on my machine, even when ones and zeros occur in roughly equal proportion (the worst case):

f <- function(X) {
    if (!is.logical(X)) {
        storage.mode(X) <- "logical"
    }
    J <- which(X, arr.ind = TRUE, useNames = FALSE)
    i <- J[, 1L]
    j <- J[, 2L]
    nmax <- 0L
    res <- NULL
    for (k in seq_along(i)) {
        i0 <- i[k]
        j0 <- j[k]
        ok <- i < i0 & j > j0
        if (any(ok)) {
            i1 <- i[ok]
            j1 <- j[ok]
            ok <- !(X[i0, j1] | X[i1, j0])
            if (any(ok)) {
                i1 <- i1[ok]
                j1 <- j1[ok]
                n <- (i0 - i1 + 1L) * (j1 - j0 + 1L)
                w <- which.max(n)
                if (n[w] > nmax) {
                    nmax <- n[w]
                    res <- c(i0 = i0, j0 = j0, i1 = i1[w], j1 = j1[w])
                }
            }
        }
    }
    res
}

mkX <- function(n) {
    X <- matrix(sample(0:1, n * n, TRUE), n, n)
    X[upper.tri(X)] <- t(X)[upper.tri(X)]
    X
}

set.seed(1L)
X <- mkX(6L)
X
##      [,1] [,2] [,3] [,4] [,5] [,6]
## [1,]    0    1    0    0    1    0
## [2,]    1    0    1    1    0    0
## [3,]    0    1    0    1    1    1
## [4,]    0    1    1    0    0    0
## [5,]    1    0    1    0    0    1
## [6,]    0    0    1    0    1    0

f(X)
## i0 j0 i1 j1 
##  5  1  1  5

Y <- mkX(100L)
microbenchmark::microbenchmark(f(Y))
## Unit: milliseconds
##  expr     min       lq     mean   median       uq      max neval
##  f(Y) 310.139 318.3363 327.8116 321.4109 326.5088 391.9081   100

回复收藏 0 原文

~没有更多了~