Sorting rows of matrix by criterion for columns

Question

I would like to reshuffle the rows of a matrix until a criterion is met for all columns. Let us say I have a matrix $G$:

G = {{1, 0, 0, 1, 0, 1}, {1, 0, 0, 1, 1, 1}, {1, 1, 1, 0, 0, 1}, {1, 
    1, 1, 0, 1, 1}, {1, 1, 1, 1, 1, 1}};
G // MatrixForm

I would like to rearrange the rows such that every column forms an unbroken chain of ones. For instance, ${0,1,0,0,0}$ and ${0,0,1,1,1}$ would be unbroken chains, but $1, 1, 0, 0, 1$ is broken. I have highlighted columns form unbroken chains in green and broken chains in red. To test if a column meets this criterion, use ChainQList, and to test if all columns meet this criterion, use ChainQ as defined below:

ChainQList[list_] := Module[{listWithX},
  listWithX = Split[list] /. {Repeated[1]} -> xsymb;
  If[1 == Count[listWithX, xsymb], True, False]
  ]
ChainQ[mat_] := 
 And @@ (ChainQList[mat[[All, #]]] & /@ Range@Last@Dimensions[mat])

As expected, ChainQ@G returns False, and ChainQList /@ Transpose@G returns {True, True, True, False, False, True}, consistent with my color highlighting above.

My question is how I could build a reasonably efficient alogirhtm so that all columns are green, i.e. form chains. At the moment I simply compute all permutations of the rows of $G$ and test with ChainQ every time:

listOfMatrices = 
  G[[#, All]] & /@ Permutations@Range@First@Dimensions@G;
inds = Select[Range@Length@listOfMatrices, 
   ChainQ[listOfMatrices[[#]]] == True &];
MatrixForm /@ listOfMatrices[[inds]]

This requires computing $n!$ permutations (where $n$ is the number of columns of $G$) and is extremely inefficient, as I need to compute for large $G$. How could I build a more efficient algorithm than permuting through everything? If the algorithm delivers any of the two solutions above, I would be happy.

Another example Just to make testing easier, here is another example $G$:

{{1, 0, 0, 1, 0, 1}, {1, 1, 0, 0, 0, 1}, {1, 1, 1, 0, 1, 1}, {1, 1, 1,
   1, 0, 1}}

My brute force algorithm provides these two solutions:

{{{1,0,0,1,0,1},{1,1,1,1,0,1},{1,1,1,0,1,1},{1,1,0,0,0,1}},{{1,1,0,0,0,1},{1,1,1,0,1,1},{1,1,1,1,0,1},{1,0,0,1,0,1}}}

Answer 1

This was a bit like doing sudoku and my approach may be problematic in cases where more than two solutions exist. You can observe that if an ordering l is a solution for a matrix G (such that G[[l]] satisfies the constraint) then Reverse@l is also a solution. i.e. solutions are symmetric w.r.t. column reflections (which reduces your brute force approach to $n!/2$ which isn't much).

Now in order to find how best to devise this ordering, given a matrix G, the following function provides constraints for row adjacency

narrowedTuples[m_] := Module[{ length, indexOnes, out},
      length = Length[m];
      indexOnes = Flatten /@ (Position[#, 1] & /@ Transpose@m //DeleteDuplicates);
      out = Select[
        Flatten[Outer[Intersection, indexOnes, indexOnes, 1], 1] //DeleteDuplicates,
          (Length@# < length) && (# != {}) &];
      SortBy[out, Length]
      ]

this is done by spotting positions for ones on each row and hierarchically ordering them in order of strongest to weakest constraints (which is done by the Intersection bit). For the matrix G that you have provided, this gives

narrowedTuples[G]
{{5}, {2, 5}, {4, 5}, {1, 2, 5}, {2, 4, 5}, {3, 4, 5}}

meaning that row 5 can be anywhere, rows 2, 5 and 4, 5 need to be adjacent, rows 1, 2, 5 need to be adjacent and so on. The rest is easy (perhaps easier!) to work out by hand now that the constraints are there: there are only two ways rows 2, 4, 5 can be encountered, with 5 in their middle, so the ordering will have the form (or its reverse): {___,2,5,4,___} but then if 5, 4 are adjacent, 3 has to be there so the ordering will have the form {___,2,5,4,3,___} and on the other side, 2, 5 need to have a 1 since that is one of the constrained partitions so {1,2,5,4,3} is your ordering; as I said, just like Sudoku. I wrote a function to check whether an ordering satisfies the constraint:

check[Mat_, ordering_] /; Length@ordering == Length@Mat := 
 Module[{oneify},
  oneify[{pre___, a_, a_, post___}] := oneify[{pre, a, post}];
  oneify[l_] := l;
  And @@ ((# <= 1) & /@ Plus @@@ (oneify /@ Transpose@Mat[[ordering]]))
  ]

which gives

check[G,{1,2,5,4,3}]
True

Now in order to automate this I have tried a few things but they won't work if the problem is underdetermined. Essentially one can define a function which starts with a seed for the ordering (the seed corresponding to a row with 1s that can be anywhere) and adds elements on either side of it using constraints of increasing length:

ord[{a_}, list_] := Module[{l, r, cand, test},
  cand = Select[list, (Length@# == 2) &];
  test = Flatten@Select[Complement[#, {a}] & /@ cand, Length@# == 1 &];
  If[Length@test == 2,
   {l, r} = Flatten@Select[Complement[#, {a}] & /@ cand, Length@# == 1 &],
   $Failed
   ];
  {l, a, r}
  ];
ord[tst_, list_] /; Length[ord] > 2 := Module[{l, r, cand},
  cand = Select[list, (Length@tst - 1 <= Length@# <= Length@tst) &];
  {l, r} = {Complement[
     Flatten@Select[Complement[#, Most@tst] & /@ cand, 
       Length@# == 1 &], tst], 
    Complement[
     Flatten@Select[Complement[#, Rest@ord] & /@ cand, 
       Length@# == 1 &], tst]};
  Flatten@{l, tst, r}
  ]

Now you can wrap all these (probably buggy) functions in one that solves for the constraints:

solveMat[m_] := Module[{tuples = ordering[m], seeds},
  seeds = Cases[tuples, {_}];
  First@Select[FixedPoint[ord[#, tuples] &, #] & /@ seeds, Length@# == Length@m &]
  ]

And here is how it works with the matrices you have provided:

m0 = {{1, 0, 0, 1, 0, 1}, {1, 0, 0, 1, 1, 1}, {1, 1, 1, 0, 0, 1}, {1, 
    1, 1, 0, 1, 1}, {1, 1, 1, 1, 1, 1}};
m1 = {{1, 0, 0, 1, 0, 1}, {1, 1, 0, 0, 0, 1}, {1, 1, 1, 0, 1, 1}, {1, 
    1, 1, 1, 0, 1}};

evaluating solveMat[m0] gives {1, 2, 5, 4, 3} (the ordering we came up with above) and solveMat[m1] gives {1, 4, 3, 2} which is corresponds to the ordering you provided m1[[{1,4,3,2}]].

Does it work on larger matrices? I don't know. If there are enough columns for there to be enough constraints to grow the chain to full length it does. My guess is it definitely doesn't work if there are not enough constraints but in that case you can grow whatever sub-chains of rows accordingly and for whichever rows are underdetermined you can use permutations which will be much fewer than brute-forcing. I haven't got time to do this however. If there are enough constraints, the performance is decent: here's a solution (that took a few seconds) to a $100\times 600$ matrix I generated from code given by @anderstood in the comments:

 G0 // ArrayPlot

and here it is "solved":

G0[[solveMat[G0]]] // ArrayPlot