Changing the values in a binary matrix

Question

Consider the 8 by 6 binary matrix, M:

M <- matrix(c(0,0,1,1,0,0,1,1,
          0,1,1,0,0,1,1,0,
          0,0,0,0,1,1,1,1,
          0,1,0,1,1,0,1,0,
          0,0,1,1,1,1,0,0,
          0,1,1,0,1,0,0,1),nrow = 8,ncol = 6)

Here is the M

      [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    0    0    0    0    0    0
[2,]    0    1    0    1    0    1
[3,]    1    1    0    0    1    1
[4,]    1    0    0    1    1    0
[5,]    0    0    1    1    1    1
[6,]    0    1    1    0    1    0
[7,]    1    1    1    1    0    0
[8,]    1    0    1    0    0    1

The following matrix contains the column index of the 1's in matrix M

    [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    3    2    5    2    3    2
[2,]    4    3    6    4    4    3
[3,]    7    6    7    5    5    5
[4,]    8    7    8    7    6    8

Let's denote that

ind <- matrix(c(3,4,7,8,
                2,3,6,7,
                5,6,7,8,
                2,4,5,7,
                3,4,5,6,
                2,3,5,8),nrow = 4, ncol=6)

I'm trying to change a single position of 1 into 0in each column of M.

For an example, one possibility of index of1s in each column would be (4,2,5,4,3,2), i.e. 4th position of Column1, 2nd position of Column2, 5thposition of Column3 and so on. Let N be the resulting matrices. This will produce the following matrix N

N <- matrix(c(0,0,1,0,0,0,1,1,
          0,0,1,0,0,1,1,0,
          0,0,0,0,0,1,1,1,
          0,1,0,0,1,0,1,0,
          0,0,0,1,1,1,0,0,
          0,0,1,0,1,0,0,1),nrow = 8,ncol = 6)

Here is that N

    [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    0    0    0    0    0    0
[2,]    0    0    0    1    0    0
[3,]    1    1    0    0    0    1
[4,]    0    0    0    0    1    0
[5,]    0    0    0    1    1    1
[6,]    0    1    1    0    1    0
[7,]    1    1    1    1    0    0
[8,]    1    0    1    0    0    1

For EACH of the resulting matrices of N, I do the following calculations.

X <- cbind(c(rep(1,nrow(N))),N)
ans <- sum(diag(solve(t(X)%*%X)[-1,-1]))

Then, I want to obtain the matrix N, which produce the smallest value of ans. How do I do this efficiently?

Answer 1

Let me know if this works.

We first build a conversion function that I'll need, and we build also the reverse function as you may need it at some point:

ind_to_M <- function(ind){
  M   <- matrix(rep(0,6*8),ncol=6)
  for(i in 1:ncol(ind)){M[ind[,i],i] <- 1}
  return(M)
}

M_to_ind <- function(M){apply(M==1,2,which)}

Then we will build a matrix of possible ways to ditch a value

all_possible_ways_to_ditch_value <- 1:4
for (i in 2:ncol(M)){
  all_possible_ways_to_ditch_value <- merge(all_possible_ways_to_ditch_value,1:4,by=NULL)
}
# there's probably a more elegant way to do that
head(all_possible_ways_to_ditch_value)
# x y.x y.y y.x y.y y 
# 1 1   1   1   1   1 1 # will be used to ditch the 1st value of ind for every column
# 2 2   1   1   1   1 1
# 3 3   1   1   1   1 1
# 4 4   1   1   1   1 1
# 5 1   2   1   1   1 1
# 6 2   2   1   1   1 1

Then we iterate through those, each time storing ans and N (as data is quite small overall).

ans_list <- list()
N_list   <- list()
for(j in 1:nrow(all_possible_ways_to_ditch_value)){
  #print(j)
  ind_N   <- matrix(rep(0,6*3),ncol=6)                            # initiate ind_N as an empty matrix
  for(i in 1:ncol(M)){
    ind_N[,i] <- ind[-all_possible_ways_to_ditch_value[j,i],i]    # fill with ind except for the value we ditch
  }
  N <- ind_to_M(ind_N)
  X <- cbind(c(rep(1,nrow(N))),N)
  ans_list[[j]] <- try(sum(diag(solve(t(X)%*%X)[-1,-1])),silent=TRUE) # some systems are not well defined, we'll just ignore the errors
  N_list[[j]] <- N
}

We finally retrieve the minimal ans and the relevant N

ans <- ans_list[[which.min(ans_list)]]
# [1] -3.60288e+15
N   <- N_list[[which.min(ans_list)]]
# [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    0    0    0    0    0    0
# [2,]    0    1    0    1    0    1
# [3,]    1    1    0    0    1    1
# [4,]    1    0    0    1    1    0
# [5,]    0    0    1    1    1    1
# [6,]    0    1    1    0    0    0
# [7,]    1    0    1    0    0    0
# [8,]    0    0    0    0    0    0

EDIT:

To get minimal positive ans

ans_list[which(!sapply(ans_list,is.numeric))] <- Inf
ans <- ans_list[[which.min(abs(unlist(ans_list)))]]
# [1] 3.3
N   <- N_list[[which.min(abs(unlist(ans_list)))]]
# [,1] [,2] [,3] [,4] [,5] [,6]
# [1,]    0    0    0    0    0    0
# [2,]    0    1    0    1    0    0
# [3,]    1    1    0    0    0    1
# [4,]    1    0    0    0    1    0
# [5,]    0    0    0    1    1    1
# [6,]    0    1    1    0    1    0
# [7,]    1    0    1    1    0    0
# [8,]    0    0    1    0    0    1

EDIT 2 : to generalize the number of rows of ind to ditch

It seems to give the same result for ans for n_ditch = 1, and results make sense for n_ditch = 2

n_ditch <- 2
ditch_possibilities <- combn(1:4,n_ditch) # these are all the possible sets of indices to ditch for one given columns
all_possible_ways_to_ditch_value <- 1:ncol(ditch_possibilities) # this will be all the possible sets of indices of ditch_possibilities to test
for (i in 2:ncol(M)){
  all_possible_ways_to_ditch_value <- merge(all_possible_ways_to_ditch_value,1:ncol(ditch_possibilities),by=NULL)
}

ans_list <- list()
N_list   <- list()
for(j in 1:nrow(all_possible_ways_to_ditch_value)){
  #print(j)
  ind_N   <- matrix(rep(0,6*(4-n_ditch)),ncol=6)                            # initiate ind_N as an empty matrix
  for(i in 1:ncol(M)){
    ind_N[,i] <- ind[-ditch_possibilities[,all_possible_ways_to_ditch_value[j,i]],i]    # fill with ind except for the value we ditch
  }
  N <- ind_to_M(ind_N)
  X <- cbind(c(rep(1,nrow(N))),N)
  ans_list[[j]] <- try(sum(diag(solve(t(X)%*%X)[-1,-1])),silent=TRUE) # some systems are not well defined, we'll just ignore the errors
  N_list[[j]] <- N
}