Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

To start, I have a situation where I have some matrix, for example

$$ A=\left[ \begin{matrix} 4&2&2&3&3\\ 2&3&1&2&3\\ 3&0&4&0&4\\ 1&4&1&1&2\\ 1&3&4&1&4\\ \end{matrix} \right] $$

and I would like to count how many adjacent elements there are. Adjacent elements can be up, down, left or right. For a pair to be valid the numbers have to have the same value. For example $\left(A_{1,2},A_{1,3}\right)$ is a valid pair because the are both $2$ and they are next to each other. I need a way to count the defined adjacent element pairs on a matrix of size $n$.

eg.

$$ \left[ \begin{matrix} 2&2&3\\ 3&2&3\\ 2&1&1 \end{matrix} \right] $$

There would be 4 pairs in this matrix.

I thought about converting the matrix into some sort of graph with "weighted vertices" however I had no clue on doing so. It would have then made it a matter of counting arcs. So how would one produce a function that takes in a matrix and spits out the number of pairs (by my definition) it contains?

I am unsure whether or not I have tagged this correctly.

share|improve this question
    
Question is not clear to me, e.g., would the 2-4 elements of which there are four pairings in your example count as 1 total? –  rasher Jan 16 at 21:03
    
@rasher Apologies about ambiguity I changed it. I also added an example –  Alizter Jan 16 at 21:05
1  
If I understand correctly, this should accomplish the count you want. I treat a row, e.g, of x,x,x as two pairs. Try it and reply... (Count[{Differences /@ #}, 0, Infinity] + Count[{Differences /@ Transpose[#]}, 0, Infinity]) &[yourMatrixHere] –  rasher Jan 16 at 21:28
2  
A one-liner: Count[Flatten@{Differences[a, {1,0}], Differences[a, {0,1}]}, 0], where the matrix is a. –  Szabolcs Jan 16 at 21:46

4 Answers 4

Following @rasher 's idea, you could do

countAdjRows=Count[{Differences @ #}, 0, Infinity]&;

countAdj=countAdjRows@# + countAdjRows@Transpose@# &

Or, maybe speed it a little bit by counting with Unitize as @belsarius's superbly suggests

countAdj= -Total[Unitize@Differences@# - 1 & /@ {#, Transpose@#}, Infinity]&;

Or @Szabolcs magestic one-liner

countAdj= Count[Flatten@{Differences[#, {1,0}], Differences[#, {0,1}]}, 0]&

Some Code Golf:

Count[Differences /@ {#, #\[Transpose]}, 0, 3] &
share|improve this answer
    
You don't need to map Differences, you can use it directly. E.g. Count[Flatten@Differences[a], 0]. –  Szabolcs Jan 16 at 21:45
    
@Szabolcs it just counts in the other direction, which is perfect anyway. Editing –  Rojo Jan 16 at 21:47
1  
-Total[Unitize@Differences@# - 1 & /@ {m, Transpose@m}, 3] –  belisarius Jan 16 at 21:47
    
@belisarius I expected that subtracting one to a whole matrix would be slower but no. I don't deserve any credits for this –  Rojo Jan 16 at 21:49
    
I wonder if there isn't a ListConvolve kernel that can count both horiz and vert matches in one pass –  belisarius Jan 16 at 21:54

This method generates all neighboring position-pairs (according to nontoroidal Neumann neighborhood) and then checks whether any of these position-pairs is a valid pair (i.e. identical) or not.

size= 5;
mat = RandomInteger[{1, 5}, {size, size}];
close = Cases[Tuples[Tuples[Range@size, {2}], {2}],
         {{a_, b_}, {c_, d_}} /; (a==c && b==d-1) || (a==c-1 && b==d)]
pairs = Cases[close, _?(SameQ @@ Extract[mat, #] &)]

Grid[mat, Background -> {None, None, Thread[# -> Hue[.66, .2]]}] & /@ pairs
{{{1, 2}, {1, 3}}, {{1, 4}, {1, 5}}, {{2, 2}, {2, 3}}, {{2, 4},
    {2, 5}}, {{2, 4}, {3, 4}}, {{3, 4}, {4, 4}}, {{5, 4}, {5, 5}}}

Mathematica graphics

share|improve this answer
    
Nice answer there! –  rasher Jan 16 at 22:52

This uses pattern-based rather than numeric methods and therefore will not be highly efficient, but I like the style.

f[a_?MatrixQ] :=
  Module[{h, pad},
    h[{{i_, x_}, {y_, _}}] := Count[{x, y}, i];
    Developer`PartitionMap[h, a, {2, 2}, 1, 1, pad] ~Total~ 2
  ]

Test:

a = {{4, 2, 2, 3, 3}, {2, 3, 1, 2, 3}, {3, 0, 4, 0, 4}, {1, 4, 1, 1, 2}, {1, 3, 4, 1, 4}};
m = {{2, 2, 3}, {3, 2, 3}, {2, 1, 1}};

f /@ {a, m}
{6, 4}
share|improve this answer
    
Nice approach ! –  belisarius Jan 17 at 14:28
    
@belisarius Thanks. :-) –  Mr.Wizard Jan 17 at 14:32
1  
Stylish +1! Why pad the array and not stop before going over the borders? Also, adding the $ in the Module seems like a good idea –  Rojo Jan 17 at 14:56
    
@Rojo Because I'm stupid and/or lazy? :o) Good ideas! –  Mr.Wizard Jan 17 at 15:00
1  
@Rojo Actually I don't think I can avoid the padding in a single Partition operation, unless I'm missing something. There is only one wasted check, for the lower right corner; all other overlaps are valid. –  Mr.Wizard Jan 17 at 15:04

Position of pairs:

posf[u_] := Module[{a, at, p1, p2},
  {a, at} = Position[Differences /@ #, 0] & /@ {u, Transpose@u};
  p1 = {#, # + {0, 1}} & /@ a;
  p2 = {#, # + {1, 0}} & /@ (Reverse /@ at);
  Join[p1, p2]]

Test matrix:

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

enter image description here

posf[mat]

yields:

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

Visualizing using:

Map[Function[x, 
  Grid[mat, Background -> {None, None, # -> LightRed & /@ x}]]
 , posf[mat]]

enter image description here

To obtain the count:

Length@posf[mat]

In this case yielding: 12.

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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