# Counting adjacent elements in a matrix?

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.

• 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?
– ciao
Jan 16, 2014 at 21:03
• @rasher Apologies about ambiguity I changed it. I also added an example Jan 16, 2014 at 21:05
• 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]
– ciao
Jan 16, 2014 at 21:28
• A one-liner: Count[Flatten@{Differences[a, {1,0}], Differences[a, {0,1}]}, 0], where the matrix is a. Jan 16, 2014 at 21:46
• @Szabolcs Would it be possible to use this method to determine, in a matrix defined as mat = RandomChoice[{0, 1, 2}, {5, 5}], the number of 1s that have 0s adjacent to them (i.e. up, down, left, right)?
– jbl
Feb 11, 2021 at 22:56

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


– ciao
Jan 16, 2014 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] :=
h[{{i_, x_}, {y_, _}}] := Count[{x, y}, i];
DeveloperPartitionMap[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}

• Nice approach ! Jan 17, 2014 at 14:28
• @belisarius Thanks. :-) Jan 17, 2014 at 14:32
• 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, 2014 at 14:56
• @Rojo Because I'm stupid and/or lazy? :o) Good ideas! Jan 17, 2014 at 15:00
• @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. Jan 17, 2014 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}};


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.

Following @rasher 's idea, you could do

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



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

• You don't need to map Differences, you can use it directly. E.g. Count[Flatten@Differences[a], 0]. Jan 16, 2014 at 21:45
• @Szabolcs it just counts in the other direction, which is perfect anyway. Editing
– Rojo
Jan 16, 2014 at 21:47
• -Total[Unitize@Differences@# - 1 & /@ {m, Transpose@m}, 3] Jan 16, 2014 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, 2014 at 21:49
• I wonder if there isn't a ListConvolve kernel that can count both horiz and vert matches in one pass Jan 16, 2014 at 21:54
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}};


{4, 6, 9}


Visualization:

adjPairs = Map[
ReplaceAll[{{_?NumericQ} -> -1, a : {_?NumericQ, __} :> Splice[a]}] @*
Split];

{Transpose @ adjPairs @ Transpose @ # , adjPairs @ #}, 2] &;

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


• A very nice and useful illustration, which tells us much more than the dull {4, 6}
– eldo
Nov 16, 2023 at 14:14

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

With[{c = SequenceCount[#, {x_, x_}, Overlaps->True] &},
Total[{c /@ m, c /@ Transpose[m]}, 2]]



{4, 6}

• It seems that SequenceCount is not counting two sequences in the case of matrix c (@kglr) and I don't know what is happening, because if you check with SequencePosition it works: Length@Catenate[SequencePosition[#, {x_, x_ ..}] & /@ Join[#, Transpose@#] &@c] Dec 21, 2023 at 6:45
• I know what you missed, you're not counting the overlaps: Overlaps -> True Dec 21, 2023 at 6:52
• Thank you, I added a revision notice
– eldo
Dec 21, 2023 at 8:30
• Thanks to you too, @eldo. I've followed the use of functions for sequences because you used them in many answers. :-) Dec 21, 2023 at 8:37

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

Flatten[
Function[
Map[
Function[

SequenceCases[#, s : {x_, Repeated[x_]} :> (Length[s] - 1)]
],
Join[#, Transpose @ #]
]
][m]
]
];

`