8
$\begingroup$

I want to find the position of the elements which are equal in a matrix. For example in the case of the following matrix:

$m =\left( \begin{array}{cc} a & x \\ x & a \\ \end{array} \right)$

m = {{a, x}, {x, a}};

I want to get these two sets:

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

How can I do that? Is there a built in function?

Improve this question
$\endgroup$
1
  • 1
    $\begingroup$ You should provide a bigger matrix. $\endgroup$ – Öskå Jun 11 '14 at 14:38
6
$\begingroup$

Here is a method that has far better computational complexity than Position:

f1[m_] := Cases[Last @ Reap @ MapIndexed[Sow[#2, #] &, m, {2}], {_, __}]

Test:

SeedRandom[0]
m = RandomInteger[5, {4, 4}];
m // MatrixForm

$\left( \begin{array}{cccc} 5 & 1 & 0 & 4 \\ 0 & 4 & 1 & 2 \\ 1 & 0 & 3 & 3 \\ 4 & 2 & 0 & 4 \end{array} \right)$

f1[m]

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

Alternative code; it is slightly faster than f1 in version 7, but might faster (or slower) in newer versions:

f2[m_] := Module[{x}, Cases[ArrayRules[m, x] ~GatherBy~ Last, {_, __}][[All, All, 1]] ];

To my consternation I tried the same method that rasher recently posted but I managed to lose the potential performance of that method. My mistake was to use Extract[m, #] & instead of m[[#[[1]], #[[2]]]] &. I expected Extract to be at least as fast; I still don't know why it is not. Nevertheless my revised f3:

f3[m_] := GatherBy[Tuples @ Range @ Dimensions @ m, m[[#[[1]], #[[2]]]] &] ~Cases~ {_, __}

Timings

Comparative timings with Öskå's pos. Timing function:

SetAttributes[timeAvg, HoldFirst]
timeAvg[func_] := Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

On small arrays my functions are only a few times faster. (f3 is already much faster.)

m = RandomInteger[40, {15, 20}];
Scan[Print @ timeAvg @ #[m] &, {pos, f1, f2, f3}]

0.0005984
0.00020992
0.0002096
0.000089856

But as the array size and especially number of unique elements increases pos rapidly slows down:

m = RandomInteger[500, {40, 70}];
Scan[Print @ timeAvg @ #[m] &, {pos, f1, f2, f3}]

0.04744
0.0020464
0.0019968
0.000848

m = RandomInteger[3000, {120, 160}];
Scan[Print @ timeAvg @ #[m] &, {pos, f1, f2, f3}]

2.792
0.02372
0.02308
0.005872

m = RandomInteger[10000, {300, 400}];
Scan[Print @ timeAvg @ #[m] &, {pos, f1, f2, f3}]   (* warning: very slow! *)

122.991
0.2404
0.2404
0.04244

Improve this answer
$\endgroup$
1
  • $\begingroup$ @rasher Thank you. $\endgroup$ – Mr.Wizard Jun 12 '14 at 7:07
4
$\begingroup$

How about that? I believe that you should provide a bigger example though.

m = {{a, x}, {x, a}}
pos[m_] := 
  Position[m, #] & /@ First /@ Select[Tally@Flatten@m, Last@# >= 2 &]
pos@m

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

SeedRandom@0;
mat = RandomChoice[Range@25, {5, 5}]

$\left( \begin{array}{ccccc} 21 & 5 & 3 & 3 & 23 \\ 8 & 17 & 3 & 3 & 4 \\ 20 & 2 & 25 & 11 & 22 \\ 13 & 18 & 12 & 23 & 13 \\ 19 & 22 & 2 & 3 & 2 \\ \end{array} \right)$

pos@mat//Column

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

If one wants to illustrate their position in a colorful way:

SeedRandom@0;
mat /. (Rule[#, Style[#, RGBColor@RandomReal[{}, 3]]] & /@ (First /@ 
  Select[Tally@Flatten@mat, Last@# >= 2 &])) // MatrixForm

Mathematica graphics

Improve this answer
$\endgroup$
4
  • $\begingroup$ Thank you. The first edition of your answer was fine. Why did you change that? What is the difference? Position[m, #] & /@ First /@ Tally@Flatten@m $\endgroup$ – MOON Jun 11 '14 at 14:52
  • $\begingroup$ It's different if you have one single variable: {{a,x},{b,a}} where only a is repeated. With the first version you would have the position of x and b while they are not repeated, with this one you only have the position of the elements repeated at least twice. $\endgroup$ – Öskå Jun 11 '14 at 14:55
  • $\begingroup$ Öskå, be aware that repeated use of Position can be very slow. Please see my answer for an alternative and timing examples. $\endgroup$ – Mr.Wizard Jun 11 '14 at 18:44
  • $\begingroup$ @Mr.Wizard Well well well.., 122 seconds is quite long indeed.. :) I should really get into Reap/Sow. $\endgroup$ – Öskå Jun 11 '14 at 18:53
4
$\begingroup$

About 10X faster than fastest so far posted using timeAvg from above...

fr= With[{a = Flatten[Array[List, Dimensions@#], 1], l = #},GatherBy[a, l[[#[[1]], #[[2]]]] &]] &

Quick test of the fastest using timeAvg with data generated as m = RandomInteger[size, {size, size}], with the usual loungebook caveats... I did not include Position based solution, as Mr. Wizard noted it explodes time-wise with larger problems.

enter image description here

Addressing RunnyKine's comment re: singlets (I chose to include them, since OP does not specify treatment of these precisely), and switching Kguler's to his fixed version:

frX=Cases[With[{a = Flatten[Array[List, Dimensions@#], 1], l = #}, 
                GatherBy[a, l[[#[[1]], #[[2]]]] &]], {_, __}] &

enter image description here

No material difference in timings (fr and frX lie on top of each other here, average difference in time treating singlets per comment is <5%)...

Improve this answer
$\endgroup$
6
  • $\begingroup$ @RunnyKine: since the OP does not specify precisely what "same" is, a bit irrelevant, clearly a singlet is the same as itself.. Nonetheless, simply adding Cases to filter that still results in only ~10% overhead, so still vastly faster. I'll update plot to reflect this. $\endgroup$ – ciao Jun 12 '14 at 1:57
  • $\begingroup$ Very strange. I actually tried what I thought was very similar to this and it wasn't faster. However I can confirm that this is. I wish I had that old code to compare because I'd really like to know what I did wrong to kill the potential of this method! +1 of course. $\endgroup$ – Mr.Wizard Jun 12 '14 at 4:11
  • $\begingroup$ Please see my updated answer. Can you explain why Extract was slow here? $\endgroup$ – Mr.Wizard Jun 12 '14 at 4:22
  • $\begingroup$ By the way, for future timing graphs I highly recommend using LogPlot -- it makes it much easier to see the order of complexity. $\endgroup$ – Mr.Wizard Jun 12 '14 at 4:29
  • 1
    $\begingroup$ After some consideration I guess m[[ #[[1]], #[[2]] ]] & can be compiled since the depth of extraction is explicit, whereas Extract[m, #] & cannot be. I really hate having to use the long form however. $\endgroup$ – Mr.Wizard Jun 12 '14 at 7:02
1
$\begingroup$

Here is a method using the new-in-version-10 PositionIndex function.

f4[m_] :=
  m // Flatten // PositionIndex // Values // Cases[{_, __}] //
    (1 + IntegerDigits[# - 1, Length @ First @ m, 2] &)

Test:

SeedRandom[0]
m = RandomInteger[5, {4, 4}];

f4[m]

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

This is not as fast as my earlier f3 but I think it is an interesting variation, hopefully worthy of posting.

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.