Finding the most common n-tuples of a list of lists where order does not matter

Question

I am still learning to use Mathematica and I need some help. How could I get the most common pair, and generally the most common n-tuple of a list (row vector) given a list of lists of m x 5 dimensions? Suppose as a sample I have a list of lists, dimension 9 x 5 of numbers

A = 
53  21  2   49  3
44  31  26  35  46
3   45  44  24  19
19  25  60  12  16
31  44  20  35  46
21  53  2   49  20
5   23  49  18  27
7   22  33  42  58
21  53  2   49  5

More specifically in Mathematica code:

A = {
 {53, 21, 2, 49, 3}, {44, 31, 26, 35, 46}, {3, 45, 44, 24, 19},
 {19,25, 60, 12, 16}, {31, 44, 20, 35,46}, {21, 53, 2, 49, 20},
 {5, 23, 49, 18, 27}, {7, 22, 33, 42, 58}, {21, 53, 2, 49, 5}}

Suppose I want to find the most common 4-tuple of the entire list of lists (A). One scenario could be {53, 21, 2, 49} is the most common 4-tuple of the list of lists. Another scenario could be that {44, 31, 35, 46} is the most common 4-tuple.

More concretely, in the given list A , the most common 4-tuple is {53, 21, 2, 49} since that 4-tuple occurs three times-- one on the first row, one the sixth row, and one on the last row. As you may have noticed, the order does not matter.

The second most common 4-tuple would be {44, 31, 35, 46} since it occurs twice--once on the second row and again on the fifth row.

And then calling on Tally to get a result like {{{53, 21, 2, 49},3}, {{44, 31, 35, 46}, 2},...}

I would like to be able to do this with 2-tuples, 3-tuples, 4-tuples, and 5-tuples. I was able to do 1-tuples trivially by using Flatten[A] on the list of lists then Tally[%]. Any guidance, tips, suggestions is appreciated.

Answer 1

ClearAll[f]
f = With[{a = #, s = #2, n = #3}, Commonest[Flatten[Subsets[Sort@#, {s}] & /@ a, 1], n]] &;

f[A, 4, 1]

{{2, 21, 49, 53}}

f[A, 4, 2]

{{2, 21, 49, 53}, {31, 35, 44, 46}}

f[A, 3, 2]

{{2, 21, 49}, {2, 21, 53}}

f[A, 5, 2]

{{2, 3, 21, 49, 53}, {26, 31, 35, 44, 46}}

Answer 2

I still will post this answer though, fortunately, OP has already got a solution~

The following code will work:

Tally[Flatten[Subsets[Sort[#], {4}] & /@ A, 1]]

Tally[Flatten[#~Subsets~{4}&/@A,1],Sort@#==Sort@#2&]

Truely an interesting thing for @J.M. and I came up woth the same solution ay the same time. :) cheers~

Answer 3

Customized function for your demand.

SeletSubTuple[l_,n_]:=Keys[TakeLargest[Counts[Sort/@Catenate[Subsets[#,{4}]&/@l]],n]]

---

Usage

SeletSubTuple[A, 1]

{{2, 21, 49, 53}}

SeletSubTuple[A, 2]

{{2, 21, 49, 53}, {31, 35, 44, 46}}

If this can serve,It's my honor. :)

Answer 4

This is just play. In the following the list A in OP is a:

Finding the pairwise non-empty intersections and counting:

tal = (Tally[
      Flatten[Outer[Intersection, a, a, 1] /. {} -> Sequence[], 
       1]] /. {__, 1} :> Sequence[])[[All, 1]];

Determining desired result:

u = tal~Join~a;
rg = RelationGraph[SubsetQ[#1, #2] && MemberQ[a, #1] && #1 != #2 &, u,
   VertexShapeFunction -> (Text[
      Framed[Style[#2, Bold], Background -> White], #] &)]
Grid[SortBy[{Length@#, #, VertexDegree[rg, #]} & /@ tal, {First, 
   Last}]]

Ugly but for completion:

fun[lst_, p_] := 
 Module[{ta = (Tally[
        Flatten[Outer[Intersection, lst, lst, 1] /. {} -> Sequence[], 
         1]] /. {__, 1} :> Sequence[])[[All, 1]], sb},
  sb = SortBy[{#, Total@Map[Function[x, Boole@SubsetQ[x, #]], a]} & /@
      ta, {Length[#[[1]]], #[[2]]} &];
  If[p == "All", Grid[sb], 
   GroupBy[sb, Length@#[[1]] & -> (## &), Last][p]]
  ]

Testing:

fun[a,4]
fun[a,"All"]

Answer 5

Post another solution by graph

g = SimpleGraph[
  Graph[If[SubsetQ[#1, #2], DirectedEdge[#1, #2], Nothing] & @@@ 
    Tuples[{A, Sort /@ Catenate[Subsets[#, {4}] & /@ A]}]]]

n = 1; VertexList[g, _?(Or @@ 
     Thread[VertexInDegree[g, #] == 
       TakeLargest[DeleteDuplicates[VertexInDegree[g]], n]] &)]

{{2, 21, 49, 53}}

You can adjust the n to select the 4-tuples arisen frequency of ranking

Answer 6

( This is an extended comment, although the code can be used to produce an answer with dataset in the question. )

Question's request is very closely related to the fundamental task of finding frequent sets in Association Rule Learning (ARL). (ARL is an approach in unsupervised machine learning.)

As far as I can tell, Mathematica does not have a dedicated built-in function for ARL, but there are enough, well performing functions for doing ARL.

The rest of this answer shows the use of the package AprioriAlgorithm.m, which I have used in the last five-six years; it is based on the so called Apriori algorithm. More effective algorithms (and packages) for ARL exist. For example R's "arules" uses the very fast "eclat" written in C.

Here we generate some data using dictionary words:

ClearAll[A]    
A = Characters /@ DictionaryLookup["*"];

Here we find the frequent sets with probability of appearance greater or equal to 5%:

minProb = 0.05;
AbsoluteTiming[
 {ares, itemToIndexRules, indexToItemRules} = AprioriApplication[A, minProb];
]

(* {2.53581, Null} *)

Here are the lengths of the sets of frequent sets found:

Length /@ ares   
(* {22, 131, 243, 118, 8} *)

Here are the frequent sets with 5 elements.

ares[[5]] /. indexToItemRules

(* {{"a", "e", "i", "n", "r"}, {"a", "e", "i", "n", "t"}, 
    {"a", "e", "i", "r", "t"}, {"a", "e", "r", "s", "t"}, 
    {"e", "i", "n", "r", "s"}, {"e", "i", "n", "r", "t"}, 
    {"e", "i", "n", "s", "t"}, {"e", "i", "r", "s", "t"}} *)

Note that using the package AprioriAlgorithm.m can provide results faster that say using Commonest / Subsets because Apriori uses an argument specifying the lower threshold for the frequencies of the sets, and hence candidate sets can be very effectively eliminated.