Подмножество не-NA

У меня есть матрица, в которой каждая строка имеет хотя бы одну ячейку NA, и каждый столбец имеет по меньшей мере одну ячейку NA. Мне нужно найти самое большое подмножество этой матрицы, которое не содержит NA.

Например, для этой матрицы A

A <- 
  structure(c(NA, NA, NA, NA, 2L, NA,
              1L, 1L, 1L, 0L, NA, NA,
              1L, 8L, NA, 1L, 1L, NA, 
              NA, 1L, 1L, 6L, 1L, 3L, 
              NA, 1L, 5L, 1L, 1L, NA),
            .Dim = c(6L, 5L),
            .Dimnames = 
              list(paste0("R", 1:6),
                   paste0("C", 1:5)))

A
    C1  C2  C3  C4  C5
R1  NA  1   1   NA  NA
R2  NA  1   8   1   1
R3  NA  1   NA  1   5
R4  NA  0   1   6   1
R5  2   NA  1   1   1
R6  NA  NA  NA  3   NA

Существует два решения (8 ячеек): A[c(2, 4), 2:5] и A[2:5, 4:5], хотя для моих целей достаточно найти только одно действительное решение. Размеры моей фактической матрицы составляют 77x132.

Будучи noob, я не вижу очевидного способа сделать это. Может ли кто-нибудь помочь мне с некоторыми идеями?

Ответ 1

1) optim В этом подходе мы решим задачу до задачи непрерывной оптимизации, которую мы решаем с помощью optim.

Объектная функция f, и вход в нее - это вектор 0-1, первые записи которого nrow(A) соответствуют строкам, а оставшиеся записи соответствуют столбцам. f использует матрицу Ainf, которая получена из A, заменяя NA с большим отрицательным числом и не-NA с 1. В терминах Ainf отрицательное число элементов в прямоугольнике строки и столбцы, соответствующие x, -x[seq(6)] %*% Ainf %*$ x[-seq(6)], которые мы минимизируем как функцию от x с учетом каждой компоненты x, лежащей между 0 и 1.

Хотя это релаксация исходной задачи для непрерывной оптимизации, кажется, что мы получим целочисленное решение по желанию.

На самом деле большая часть кода ниже - это просто, чтобы получить начальное значение. Для этого мы сначала применяем сериацию. Это переставляет строки и столбцы, дающие более блочную структуру, а затем в перестановленной матрице мы находим самую большую квадратную подматрицу.

В случае конкретного A в вопросе наибольшая прямоугольная подматрица оказывается квадратной, а начальные значения уже достаточно хороши, что они дают оптимальный результат, но мы будем выполнять оптимизацию так, чтобы она работала вообще. Если хотите, вы можете поиграть с разными стартовыми значениями. Например, измените k с 1 на некоторое большее число в largestSquare, и в этом случае largestSquare вернет столбцы k, дающие начальные значения k, которые могут использоваться в k пробегах optim, принимая лучше всего.

Если начальные значения являются достаточно хорошими, то это должно обеспечить оптимальный результат.

library(seriation) # only used for starting values

A.na <- is.na(A) + 0

Ainf <- ifelse(A.na, -prod(dim(A)), 1) # used by f
nr <- nrow(A) # used by f
f <- function(x) - c(x[seq(nr)] %*% Ainf %*% x[-seq(nr)])

# starting values

# Input is a square matrix of zeros and ones.
# Output is a matrix with k columns such that first column defines the
# largest square submatrix of ones, second defines next largest and so on.
# Based on algorithm given here:
# http://www.geeksforgeeks.org/maximum-size-sub-matrix-with-all-1s-in-a-binary-matrix/
largestSquare <- function(M, k = 1) {
  nr <- nrow(M); nc <- ncol(M)
  S <- 0*M; S[1, ] <- M[1, ]; S[, 1] <- M[, 1]
  for(i in 2:nr) 
    for(j in 2:nc)
      if (M[i, j] == 1) S[i, j] = min(S[i, j-1], S[i-1, j], S[i-1, j-1]) + 1
  o <- head(order(-S), k)
  d <- data.frame(row = row(M)[o], col = col(M)[o], mx = S[o])
  apply(d, 1, function(x) { 
    dn <- dimnames(M[x[1] - 1:x[3] + 1, x[2] - 1:x[3] + 1])
    out <- c(rownames(M) %in% dn[[1]], colnames(M) %in% dn[[2]]) + 0
    setNames(out, unlist(dimnames(M)))
  })
}
s <- seriate(A.na)
p <- permute(A.na, s)
# calcualte largest square submatrix in p of zeros rearranging to be in A  order
st <- largestSquare(1-p)[unlist(dimnames(A)), 1]

res <- optim(st, f, lower = 0*st, upper = st^0, method = "L-BFGS-B")

даяние:

> res
$par
R1 R2 R3 R4 R5 R6 C1 C2 C3 C4 C5 
 0  1  1  1  0  0  0  1  0  1  1 

$value
[1] -9

$counts
function gradient 
       1        1 

$convergence
[1] 0

$message
[1] "CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL"

2) GenSA Другая возможность - повторить (1), но вместо использования optim используйте GenSA из пакета GenSA. Он не требует начальных значений (хотя вы можете указать начальное значение с помощью аргумента par, и это может улучшить решение в некоторых случаях), поэтому код значительно короче, но поскольку он использует имитированный отжиг, можно ожидать, что он будет значительно длиннее бежать. Используя f (и nr и Ainf, который использует f) из (1). Ниже мы попробуем его без начального значения.

library(GenSA)
resSA <- GenSA(lower = rep(0, sum(dim(A))), upper = rep(1, sum(dim(A))), fn = f)

даяние:

> setNames(resSA$par, unlist(dimnames(A)))
R1 R2 R3 R4 R5 R6 C1 C2 C3 C4 C5 
 0  1  1  1  0  0  0  1  0  1  1 

> resSA$value
[1] -9

Ответ 2

У меня есть решение, но оно не очень хорошо масштабируется:

findBiggestSubmatrixNonContiguous <- function(A) {
    A <- !is.na(A); ## don't care about non-NAs
    howmany <- expand.grid(nr=seq_len(nrow(A)),nc=seq_len(ncol(A)));
    howmany <- howmany[order(apply(howmany,1L,prod),decreasing=T),];
    for (ri in seq_len(nrow(howmany))) {
        nr <- howmany$nr[ri];
        nc <- howmany$nc[ri];
        rcom <- combn(nrow(A),nr);
        ccom <- combn(ncol(A),nc);
        comcom <- expand.grid(ri=seq_len(ncol(rcom)),ci=seq_len(ncol(ccom)));
        for (comi in seq_len(nrow(comcom)))
            if (all(A[rcom[,comcom$ri[comi]],ccom[,comcom$ci[comi]]]))
                return(list(ri=rcom[,comcom$ri[comi]],ci=ccom[,comcom$ci[comi]]));
    }; ## end for
    NULL;
}; ## end findBiggestSubmatrixNonContiguous()

Это основано на идее, что если матрица имеет достаточно малую плотность NA, то, сначала поиская самые большие подматрицы, вы, скорее всего, найдете решение достаточно быстро.

Алгоритм работает, вычисляя декартово произведение всех счетчиков строк и счетчиков столбцов, которые могут быть проиндексированы из исходной матрицы для создания подматрицы. Затем множество пар отсчетов упорядочивается по размеру подматрицы, которая будет производиться каждой парой отсчетов; другими словами, упорядочен по произведению двух отсчетов. Затем он повторяет эти пары. Для каждой пары он вычисляет все комбинации индексов строк и индексов столбцов, которые могут быть приняты для этой пары отсчетов, и пытается каждую комбинацию по очереди, пока не найдет подматрицу, содержащую нулевые NA. Найдя такую подматрицу, он возвращает этот набор индексов строк и столбцов в виде списка.

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

## OP example matrix
A <- data.frame(C1=c(NA,NA,NA,NA,2L,NA),C2=c(1L,1L,1L,0L,NA,NA),C3=c(1L,8L,NA,1L,1L,NA),C4=c(NA,1L,1L,6L,1L,3L),C5=c(NA,1L,5L,1L,1L,NA),row.names=c('R1','R2','R3','R4','R5','R6'));
A;
##    C1 C2 C3 C4 C5
## R1 NA  1  1 NA NA
## R2 NA  1  8  1  1
## R3 NA  1 NA  1  5
## R4 NA  0  1  6  1
## R5  2 NA  1  1  1
## R6 NA NA NA  3 NA
system.time({ res <- findBiggestSubmatrixNonContiguous(A); });
##    user  system elapsed
##   0.094   0.000   0.100
res;
## $ri
## [1] 2 3 4
##
## $ci
## [1] 2 4 5
##
A[res$ri,res$ci];
##    C2 C4 C5
## R2  1  1  1
## R3  1  1  5
## R4  0  6  1

Мы видим, что эта функция работает очень быстро в матрице примера OP и возвращает правильный результат.

randTest <- function(NR,NC,probNA,seed=1L) {
    set.seed(seed);
    A <- replicate(NC,sample(c(NA,0:9),NR,prob=c(probNA,rep((1-probNA)/10,10L)),replace=T));
    print(A);
    print(system.time({ res <- findBiggestSubmatrixNonContiguous(A); }));
    print(res);
    print(A[res$ri,res$ci,drop=F]);
    invisible(res);
}; ## end randTest()

Я написал вышеприведенную функцию, чтобы упростить тестирование. Мы можем назвать это, чтобы проверить случайную матрицу ввода размера NR на NC, с вероятностью выбора NA в любой заданной ячейке probNA.

Вот несколько тривиальных тестов:

randTest(8L,1L,1/3);
##      [,1]
## [1,]   NA
## [2,]    1
## [3,]    4
## [4,]    9
## [5,]   NA
## [6,]    9
## [7,]    0
## [8,]    5
##    user  system elapsed
##   0.016   0.000   0.003
## $ri
## [1] 2 3 4 6 7 8
##
## $ci
## [1] 1
##
##      [,1]
## [1,]    1
## [2,]    4
## [3,]    9
## [4,]    9
## [5,]    0
## [6,]    5

randTest(11L,3L,4/5);
##       [,1] [,2] [,3]
##  [1,]   NA   NA   NA
##  [2,]   NA   NA   NA
##  [3,]   NA   NA   NA
##  [4,]    2   NA   NA
##  [5,]   NA   NA   NA
##  [6,]    5   NA   NA
##  [7,]    8    0    4
##  [8,]   NA   NA   NA
##  [9,]   NA   NA   NA
## [10,]   NA    7   NA
## [11,]   NA   NA   NA
##    user  system elapsed
##   0.297   0.000   0.300
## $ri
## [1] 4 6 7
##
## $ci
## [1] 1
##
##      [,1]
## [1,]    2
## [2,]    5
## [3,]    8

randTest(10L,10L,1/3);
##       [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
##  [1,]   NA   NA    0    3    8    3    9    1    6    NA
##  [2,]    1   NA   NA    4    5    8   NA    8    2    NA
##  [3,]    4    2    5    3    7    6    6    1    1     5
##  [4,]    9    1   NA   NA    4   NA   NA    1   NA     9
##  [5,]   NA    7   NA    8    3   NA    5    3    7     7
##  [6,]    9    3    1    2    7   NA   NA    9   NA     7
##  [7,]    0    2   NA    7   NA   NA    3    8    2     6
##  [8,]    5    0    1   NA    3    3    7    1   NA     6
##  [9,]    5    1    9    2    2    5   NA    7   NA     8
## [10,]   NA    7    1    6    2    6    9    0   NA     5
##    user  system elapsed
##   8.985   0.000   8.979
## $ri
## [1]  3  4  5  6  8  9 10
##
## $ci
## [1]  2  5  8 10
##
##      [,1] [,2] [,3] [,4]
## [1,]    2    7    1    5
## [2,]    1    4    1    9
## [3,]    7    3    3    7
## [4,]    3    7    9    7
## [5,]    0    3    1    6
## [6,]    1    2    7    8
## [7,]    7    2    0    5

Я не знаю простого способа проверить правильность приведенного выше результата, но это выглядит хорошо для меня. Но для получения этого результата потребовалось почти 9 секунд. Запуск функции на умеренно больших матрицах, особенно матрица 77x132, вероятно, является потерянной причиной.

Ожидание, сможет ли кто-нибудь придумать блестящее эффективное решение...