2
$\begingroup$

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,

enter image description here

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,

enter image description here

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

enter image description here

{{{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.

enter image description here

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.

$\endgroup$
6
  • $\begingroup$ 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. $\endgroup$ – MarcoB Nov 23 '20 at 19:34
  • $\begingroup$ @MarcoB I modified the question with example $\endgroup$ – Saesun Kim Nov 23 '20 at 19:57
  • $\begingroup$ Thank you. I wonder if you could also explain the logic behind the code. What feature are you using for grouping? $\endgroup$ – MarcoB Nov 23 '20 at 20:02
  • $\begingroup$ @MarcoB I add the comments too! $\endgroup$ – Saesun Kim Nov 23 '20 at 20:02
  • $\begingroup$ First@MaximalBy[Length][GatherBy[llist, #] & /@ {First, Last}]? $\endgroup$ – kglr Nov 23 '20 at 20:20
4
$\begingroup$

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

GatherBy[llist, First] // Column

enter image description here

GatherBy[llist, Last] // Column

enter image description here

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

enter image description here

Alternatively, use Reap/Sow with take:

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

take2 @ llist // Column

enter image description here

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

enter image description here

$\endgroup$
1
  • $\begingroup$ This is alot better solution! Thank you so much! $\endgroup$ – Saesun Kim Nov 23 '20 at 23:21

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.