# Grouping the list

Let's assume that I have randomly generated list

 llist = {{0, 1}, {2, 1}, {4, 4}, {0, 3}, {3, 4}, {2, 2}, {2, 3}, {2, 0}};


We can represent this data using the following plot,

I want to group the elements, but I can only group them by same x elements or y elements.

For example, if I group them with the same x elements, I got five groups,

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


If I group them with the same y elements, I got four groups

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


However, if I group them with x and y simultaneously, I can reduce the group by three.

I am looking for an efficient way to group them. I attach my naive coding method.

(*Where I want to save group*)
group1 = {};
(*Count them*)
countx = Table[{i, Count[llist[[All, 1]], i]}, {i, 0, 4}];
county = Table[{i, Count[llist[[All, 2]], i]}, {i, 0, 4}];
(*Find the bigger grouping*)
mcx = Select[countx, #[[2]] == Max[countx[[All, 2]]] &][[1]];
mcy = Select[county, #[[2]] == Max[county[[All, 2]]] &][[1]];
(*if x grouping is more,than group them by x and remove their group \
from the list,if y grouping is more or equal,group them by y and remove from \
the list, and call that list as llist1*)
If[mcx[[2]] >
mcy[[2]], {group1 =
Append[group1,
llist[[Flatten[Position[llist[[All, 1]], mcx[[1]]]]]]],
llist1 =
Delete[llist, Position[llist[[All, 1]], mcx[[1]]]]}, {group1 =
Append[group1,
llist[[Flatten[Position[llist[[All, 2]], mcy[[1]]]]]]],
llist1 = Delete[llist, Position[llist[[All, 2]], mcy[[1]]]]}];


group1 will have the first largest elements, {{{2, 1}, {2, 2}, {2, 3}, {2, 0}}}, and the new list llist1 will now have {{0, 1}, {4, 4}, {0, 3}, {3, 4}}.

If I try again,

(*Repeat*)
countx1 = Table[{i, Count[llist1[[All, 1]], i]}, {i, 0, 4}];
county1 = Table[{i, Count[llist1[[All, 2]], i]}, {i, 0, 4}];
mcx1 = Select[countx1, #[[2]] == Max[countx1[[All, 2]]] &][[1]];
mcy1 = Select[county1, #[[2]] == Max[county1[[All, 2]]] &][[1]];
If[mcx1[[2]] >
mcy1[[2]], {group1 =
Append[group1,
llist1[[Flatten[Position[llist1[[All, 1]], mcx1[[1]]]]]]],
llist2 =
Delete[llist1, Position[llist1[[All, 1]], mcx1[[1]]]]}, {group1 =
Append[group1, llist1[[Flatten[Position[llist1[[All, 2]], mcy1[[1]]]]]]],
llist2 = Delete[llist1, Position[llist1[[All, 2]], mcy1[[1]]]]}];


I can find my second biggest group, {{4, 4}, {3, 4}}, and my last list will be {{0, 1}, {0, 3}}

(*Repeat*)
countx2 = Table[{i, Count[llist2[[All, 1]], i]}, {i, 0, 4}];
county2 = Table[{i, Count[llist2[[All, 2]], i]}, {i, 0, 4}];
mcx2 = Select[countx2, #[[2]] == Max[countx2[[All, 2]]] &][[1]];
mcy2 = Select[county2, #[[2]] == Max[county2[[All, 2]]] &][[1]];
If[mcx2[[2]] >
mcy2[[2]], {group1 =
Append[group1,
llist2[[Flatten[Position[llist2[[All, 1]], mcx2[[1]]]]]]],
llist3 =
Delete[llist2, Position[llist2[[All, 1]], mcx2[[1]]]]}, {group1 =
Append[group1,
llist2[[Flatten[Position[llist2[[All, 2]], mcy2[[1]]]]]]],
llist3 = Delete[llist2, Position[llist2[[All, 2]], mcy2[[1]]]]}];


My last repeat will group the last elements, so you will get

group1
(*{{{2, 1}, {2, 2}, {2, 3}, {2, 0}}, {{4, 4}, {3, 4}}, {{4, 4}, {3, 4}}, {{0, 1}, {0, 3}}}*)


and llist3 will be empty, so we can stop the algorithm.

• I don't understand how you decide the groupings in your last example. If you have an example of code that reproduces the grouping you want, please share it. Commented Nov 23, 2020 at 19:34
• @MarcoB I modified the question with example Commented Nov 23, 2020 at 19:57
• Thank you. I wonder if you could also explain the logic behind the code. What feature are you using for grouping? Commented Nov 23, 2020 at 20:02
• @MarcoB I add the comments too! Commented Nov 23, 2020 at 20:02
• First@MaximalBy[Length][GatherBy[llist, #] & /@ {First, Last}]?
– kglr
Commented Nov 23, 2020 at 20:20

We can use GatherBy (or GroupBy) to group by the first or second column:

GatherBy[llist, First] // Column


GatherBy[llist, Last] // Column


To get the last grouping in OP, define two functions take and drop and use them with NestWhileList:

ClearAll[take, drop]
take[lst_] := First @ MaximalBy[Length][Join @@ (GatherBy[lst, #] & /@ {First, Last})];
drop[lst_] := DeleteCases[Alternatives @@ take @ lst] @ lst

take /@ Most@NestWhileList[drop, llist, # =!= {} &] // Column


Alternatively, use Reap/Sow with take:

ClearAll[take2]
take2 = Reap[NestWhileList[
DeleteCases[Alternatives @@ Sow[take @ #]] @ # &, #, # =!= {} &]][[2, 1]] &;

take2 @ llist // Column


### Pictures

ClearAll[matrixPlot]

matrixPlot = Module[{groups = #},
MatrixPlot[Reverse @ SparseArray @ Flatten @
MapIndexed[Thread[1 + Reverse /@ # -> #2[[1]]] &, groups],
DataRange -> {{0, 4}, {0, 4}},
Mesh -> All,
ColorRules -> Map[# -> ColorData[97]@# &, Range[Length @ groups]],
ImageSize -> 1 -> 70,
PlotLegends -> SwatchLegend[ColorData[97] /@ Range[Length@groups],
InputForm /@ groups,
LegendFunction -> (Column[{Style["  groups:", 16], #}] &)]]] &;

Column[matrixPlot /@ {GatherBy[llist, First], GatherBy[llist, Last], take2 @ llist}]


• This is alot better solution! Thank you so much! Commented Nov 23, 2020 at 23:21