Conditional search along the columns of a matrix

Question

I want to implement the following algorithm in Mathematica.

1. Get element along main diagonal of a matrix.

2. If the element along the main diagonal is positive, then return the positions of the elements in the corresponding column that are negative.

   If the element along the main diagonal is negative, then return the positions of the elements in the corresponding column that are positive. The positions returned are the positions in the table.

   If neither of the two conditions above are true, do nothing.

Here is example of what I want

Given the matrix

{{1, 1, 1}, {2, -2, 2}, {-3, 3, 3}}

the algorithm should produce

{{3, 1}, {1, 2}, {3, 2}}

In the above, the first element of each pair is the row of an off-diagonal element, the second element of the pair is its column)

I'm currently trying to do this with a For-loop, but I can't get it to work. Besides, because Mathematica is so good with lists, I'm sure that a functional solution is possible.

Answer 1

You can do something like:

m = {{1, 1, 1}, {2, -2, 2}, {-3, 3, 3}};
d = Sign@Diagonal@m
Position[(m\[Transpose] d)\[Transpose], _?Negative]

{{1, 2}, {3, 1}, {3, 2}}

Which looks way better in MMA:

Answer 2

I can't beat the elegance of Kuba's clean method so I'll focus on performance.

• Although it has little effect on performance it is worth noting that Sign is extraneous.
• Position is a general function that is quite slow compared to purely numeric methods.

I use SparseArray Properties to quickly find all non-background elements in a numeric array:

fn = SparseArray[
       UnitStep[(#\[Transpose] Diagonal[#])\[Transpose]],
       Automatic, 1
     ]["NonzeroPositions"] &;

This is well over an order of magnitude faster than Position on packed data:

m = RandomInteger[{-9, 9}, {2000, 2000}];

First @ Timing[r1 = Position[(m\[Transpose] (Sign@Diagonal@m))\[Transpose], _?Negative]]

First @ Timing[r2 = fn[m]]

r1 === r2

1.591

0.063

True

Answer 3

Nothing close as nice as Kuba solution.

Clear[x, n, p, mat];
mat = {{1, 1, 1}, {2, -2, 2}, {-3, 3, 3}}

r = MapIndexed[Function[{x, n},
    Which[x < 0,
     p = Position[mat[[All, First@n]], x_ /; x > 0]; p = DeleteCases[p, n]; 
      (Append[#, First@n] & /@ p),

     x > 0, p = Position[mat[[All, First@n]], x_ /; x < 0]; p = DeleteCases[p, n]; 
      (Append[#, First@n] & /@ p)]]
   , Diagonal[mat]];

Flatten[r, 1]

(* {{3, 1}, {1, 2}, {3, 2}} *)

for

mat = {{-1, -1, 1}, {2, -2, 2}, {-3, 3, 3}};

(*{{2, 1}, {3, 2}}*)

for

 mat = {{-1, -1, 1, 0}, {2, -2, 2, 5}, {-3, 3, 3, 4}, {2, 2, 2, 2}};

 {{2, 1}, {4, 1}, {3, 2}, {4, 2}}