Counting adjacent elements in a matrix?

Question

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.

Answer 1

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}}}

Answer 2

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}

Answer 3

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] &

Answer 4

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}};

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]]

To obtain the count:

Length@posf[mat]

In this case yielding: 12.

Answer 5

Revision notice

Thanks to E. Chan-López commets I added Overlaps -> True

a = {{2, 2, 3}, {3, 2, 3}, {2, 1, 1}};
b = {{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}};
CountAdjacentElements[m_?MatrixQ] :=
 With[{c = SequenceCount[#, {x_, x_}, Overlaps->True] &},
  Total[{c /@ m, c /@ Transpose[m]}, 2]]
CountAdjacentElements /@ {a,b}

{4, 6}

Answer 6

adjPairsCount = 
  Total @
  Map[Split /* Map[Length @ # - 1 &] /* Splice] @ 
  Join[#, Transpose @ #] &;

Examples:

Using input examples a and b from eldo's answer:

a = {{2, 2, 3}, {3, 2, 3}, {2, 1, 1}};
b = {{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}};
c = {{4, 2, 2, 2, 3, 3}, {2, 3, 1, 2, 2, 3}, {3, 0, 4, 2, 0, 4}, 
     {1, 4, 1, 0, 1, 2}, {1, 3, 4, 2, 1, 4}};
adjPairsCount /@ {a, b, c}

{4, 6, 9}

Visualization:

adjPairs = Map[
  ReplaceAll[{{_?NumericQ} -> -1, a : {_?NumericQ, __} :> Splice[a]}] @*
  Split];
markAdjPairs = MapThread[Max, 
  {Transpose @ adjPairs @ Transpose @ # , adjPairs @ #}, 2] &;
labeledMatrixPlot = MatrixPlot[markAdjPairs @ #, 
    PlotLabel -> 
     Style[PromptForm["adjacent Pairs Count", adjPairsCount@#], 16], 
    Mesh -> All, 
    ColorRules -> {_?Negative -> White},
    Epilog ->  MapIndexed[Text[Style[#, 20], #2 - 1/2] &, 
      Transpose @ Reverse @ #, {2}], ##2] &;
Row[labeledMatrixPlot[#, ImageSize -> 300, Frame -> False, 
    MeshStyle -> Directive[LightGray, Thick]] & /@ {a, b,c}, 
 Spacer[20]]

Answer 7

Thanks to @eldo for inspiring the following answer using SequenceCases:

a = {{2, 2, 3}, {3, 2, 3}, {2, 1, 1}};
b = {{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}};
c = {{4, 2, 2, 2, 3, 3}, {2, 3, 1, 2, 2, 3}, {3, 0, 4, 2, 0, 4}, 
     {1, 4, 1, 0, 1, 2}, {1, 3, 4, 2, 1, 4}};
CountAdjacentElements[m_?MatrixQ] := Total[
    Flatten[
            Function[
                Map[
                    Function[
    SequenceCases[#, s : {x_, Repeated[x_]} :> (Length[s] - 1)]
                    ],
                Join[#, Transpose @ #]
            ]
        ][m]
    ]

];
CountAdjacentElements /@ {a, b, c}
({4, 6, 9})