R: Find optimal sub-matrix - r

Question

I have a large symmetric matrix and want to reduce it to the much smaller matrix matrix_small with rows(matrix_small) = n. The mean of matrix_small should be maximized. Is there are way to achieve this goal in R with a better algorithm than I already have? Better is either faster with the same mean or a higher mean with the same speed.
I feel like there should be a smarter way than to search the min so often. But I'm not aware of a way to set an SQL-like index for a Matrix in R to increase performance.
library(microbenchmark)
set.seed(2016)
sym_matrix <- matrix(runif(1e+06), ncol = 1000)
sym_matrix[lower.tri(sym_matrix)] <- t(sym_matrix)[lower.tri(sym_matrix)]
diag(sym_matrix) <- NA
rownames(sym_matrix) <- 1:1000
colnames(sym_matrix) <- 1:1000
findNrows <- function(sym_matrix, nrows){
# Return a matrix with rows(matrix) = nrows.
# mean(matrix) should be maximized
set.seed(2017)
k <- nrow(sym_matrix)
for (i in nrows:(k-1)) { #eliminate rows with minimum values
min_rows <- arrayInd(which.min(sym_matrix), dim(sym_matrix))
choose_row <- sample(min_rows, 1)
sym_matrix <- sym_matrix[-choose_row, -choose_row]
}
sym_matrix
}
microbenchmark(findNrows(sym_matrix = sym_matrix, nrows = 10), times = 25L)
mean(findNrows(sym_matrix = sym_matrix, nrows = 10), na.rm = TRUE)

Answer 1

The problem is one of finding the optimal nrows rows (and likewise columns) from a symmetric matrix that maximizes the sum of the elements in this selected sub-matrix. Unlike the so-called maximum subarray problem in 2D, which has a solution using Kadane's algorithm, the key issue here is that the chosen rows need not be contiguous. As a result, this problem seems to be a much harder combinatorial optimization. A brute force approach that searches over all combinations of nrows rows (here 10) out of N rows (here 1000) is clearly impractical. However, a very simple approach, which is different than the OP's algorithm, is to simply do a random search in the space of all combinations where we randomly select nrows rows (and likewise columns) from the symmetric matrix at each trial and keep the best set of nrows rows across sequential trials:
findNrows.random <- function(sym_matrix, nrows, ntrials){
set.seed(2017)
s.rows <- sample.int(nrow(sym_matrix),nrows)
s <- sym_matrix[s.rows,s.rows]
for (i in 1:ntrials) {
t.rows <- sample.int(nrow(sym_matrix),nrows)
t <- sym_matrix[t.rows,t.rows]
if (sum(s,na.rm=TRUE) < sum(t,na.rm=TRUE)) {
s.rows <- t.rows
s <- t
}
}
return(s)
}
This algorithm, implemented in R, is fast for even large number of trials, and for just 1000 trials it produces a result (for this particular data set and seed) that is surprisingly on-par to the OP's result but roughly 500 times faster. This speaks more towards the sub-optimality of the OP's algorithm than the optimality of random search because 1000 samples is a very small portion of the overall search space. In adition, by construction, the performance in terms of the mean value of the selected sub-matrix is guaranteed to increase as the number of trials increase. Therefore, for the same compute time, simple random search will outperform the OP's algorithm.
## OP results
microbenchmark(findNrows(sym_matrix = sym_matrix, nrows = 10), times = 2L)
##Unit: seconds
## expr min lq mean median uq max neval
## findNrows(sym_matrix = sym_matrix, nrows = 10) 11.67548 11.69193 11.70937 11.6997 11.71076 11.87105 25
mean(findNrows(sym_matrix = sym_matrix, nrows = 10), na.rm = TRUE)
##[1] 0.6256406
## Random search
microbenchmark(findNrows.random(sym_matrix = sym_matrix, nrows = 10, ntrials=1000), times = 25L)
##Unit: milliseconds
## expr min lq mean median uq max neval
## findNrows.random(sym_matrix = sym_matrix, nrows = 10, ntrials = 1000) 21.81462 23.20069 27.06079 23.89368 26.25163 46.77016 25
mean(findNrows.random(sym_matrix = sym_matrix, nrows = 10, ntrials=1000), na.rm = TRUE)
##[1] 0.6374652
Now, instead of throwing away the previous set of selected nrows rows if the next set has a bigger sum, we can seek to improve the performance of this random search by trying to improve the previous set of selected rows using the new set of selected rows. The heurestic we employ is the rowSum for the resulting sub-matrices. That is, at each trial we seek to replace rows in the current sub-matrix with rows in the newly selected sub-matrix that have larger rowSums (or equivalently larger rowMeans). This seems reasonable given that values are uniformly distributed in the full matrix because a row in a selected sub-matrix with a higher rowMean will on average have higher value elements across the full row. Of course, after replace rows (if any) in the current sub-matrix with rows from the newly selected sub-matrix to form the new sub-matrix, we still check to see if this new sub-matrix is better (i.e., has a bigger sum) than the current sub-matrix before replacing the current best sub-matrix for the next trial. The code is as follows:
findNrows.faster <- function(sym_matrix, nrows, ntrials){
set.seed(2017)
s.rows <- sample.int(nrow(sym_matrix),nrows)
s.means <- rowSums(sym_matrix[s.rows,s.rows],na.rm=TRUE)
for (i in 1:ntrials) {
t.rows <- sample.int(nrow(sym_matrix),nrows)
t.means <- rowSums(sym_matrix[t.rows,t.rows],na.rm=TRUE)
st.rows <- c(s.rows,t.rows)
st.means <- c(s.means,t.means)
## need to make sure we do not have duplicates before we choose the best nrows
dups <- duplicated(st.rows)
st.rows <- st.rows[!dups]
st.means <- st.means[!dups]
new.rows <- st.rows[order(st.means,decreasing=TRUE)[1:nrows]]
new.means <- rowSums(sym_matrix[new.rows,new.rows],na.rm=TRUE)
if (sum(s.means) < sum(new.means)) {
s.rows <- new.rows
s.means <- new.means
}
}
sym_matrix[s.rows,s.rows]
}
This algorithm is slower but the result is significantly better than plain random search. Note that the comparison in performance with findNrows.random is apples to apples since the same number of trials are used and the same seed is used to randomly select the same rows for each trial. However, note that we would expect the optimal algorithm to select a sub-matrix with a mean that is well over 0.9, so this algorithm is far from optimal.
## Improved random search
microbenchmark(findNrows.faster(sym_matrix = sym_matrix, nrows = 10, ntrials=1000), times = 25L)
##Unit: milliseconds
## expr min lq mean median uq max neval
## findNrows.faster(sym_matrix = sym_matrix, nrows = 10, ntrials = 1000) 135.0531 136.3961 137.1123 136.7667 137.0439 143.0155 25
mean(findNrows.faster(sym_matrix = sym_matrix, nrows = 10, ntrials=1000), na.rm = TRUE)
##[1] 0.7797313