Поиск шаблона в бинарной матрице с помощью R

Question

У меня есть симметричная двоичная матрица nxn, и я хочу найти самый большой прямоугольник (площадь) с 0 в верхнем левом и нижнем правом углах и 1 в верхнем правом и нижнем левом углах. Если я просто делаю это с помощью циклов, проверяя все прямоугольники от самого большого до самого маленького, это занимает «дни» для n=100. У кого-нибудь есть идея сделать это эффективно?

Большое спасибо !

Answer 1

спасибо за ваши ответы. Я использую матрицы смежности случайных графов Эрдоша-Реньи. Но для проверки можно взять любую случайную симметричную бинарную матрицу. До сих пор я использую 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)
            }
        }
    }
}

Answer 2

Вот подход, который вы можете попробовать прямо сейчас. Он не требует симметрии и для эффективности рассматривает все ненулевые элементы как единицы.

Он перебирает единицы, предполагая, что единиц меньше, чем нулей. (В обратном случае вы хотели бы перебирать нули с меньшим количеством нулей, чем единиц.)

Этот подход, вероятно, не оптимален, поскольку он зацикливается на всех единицах, даже если самый большой ящик идентифицируется заранее. В этом случае вы можете придумать умное условие остановки, чтобы замкнуть контур. Но это все еще быстро для n = 100, на моей машине требуется менее половины секунды, даже если единицы и нули встречаются примерно в равной пропорции (наихудший случай):

      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