How to delete subsets quickly?

Question

I have some data like this:

data = 
  {{4, 18, 32}, {4, 23, 42}, {5, 17, 29}, {5, 18, 31}, {11, 22, 33}, 
   {11, 23, 35}, {13, 18, 23}, {13, 23, 33}, {13, 31, 49}, {15, 22, 29}, 
   {15, 23, 31}, {15, 32, 49}, {16, 25, 34}, {16, 29, 42}, {17, 25, 33}, 
   {17, 33, 49}, {22, 32, 42}, {25, 31, 37}, {29, 32, 35}, {31, 34, 37}, 
   {32, 37, 42}, {35, 42, 49}, {4, 13, 22, 31}, {5, 15, 25, 35}, {11, 13, 15, 17}, 
   {13, 25, 37, 49}, {15, 16, 17, 18}, {25, 29, 33, 37}, {4, 11, 18, 25, 32}, 
   {29, 31, 33, 35, 37}, {31, 32, 33, 34, 35}, {5, 11, 17, 23, 29, 35}};

Some list is the subset of other list, for example, {5, 17, 29} is the subset of {5, 11, 17, 23, 29, 35}, so I want to delete {5, 17, 29}. My code is:

DeleteDuplicates[SortBy[data, -Length@# &], Length@#1 != Length@#2 && SubsetQ[#1, #2] &]

But it's too slow when the length of data greater than 1000. How to delete subsets quickly?

In my problem, all numbers are always integers and positive. The lists of data actually are arithmetic sequence.

Edit

[m_golberg]: I have deleted my answer because it fails on this more difficult data set:

test = 
  {{26, 4, 4, 7}, {12, 3, 36, 6, 33}, {0, 29, 6, 22, 27}, {34, 24}, {24, 36}, 
   {29, 29, 2, 33, 24}, {35, 20, 41, 2, 39}, {19, 1}, {20, 40}, {3}, {18}, {18, 10}, 
   {4}, {32, 8}, {6, 34, 39, 30, 29}, {41}, {20, 38, 15, 18, 14}, 
   {19, 10, 8, 18, 0}, {24, 5, 36}, {40, 2}, {2, 40}, {38, 0}, {10}, 
   {24, 5, 36, 42}};

I suggest that anyone submitting an answer verify it can handle test, for which the answer should be

{{26, 4, 4, 7}, {12, 3, 36, 6, 33}, {0, 29, 6, 22, 27}, {34, 24}, 
 {24, 5, 36, 42}, {29, 29, 2, 33, 24}, {35, 20, 41, 2, 39}, {19, 1}, 
 {20, 40}, {20, 38, 15, 18, 14}, {19, 10, 8, 18, 0}, {32, 8}, 
 {6, 34, 39,30, 29}, {40, 2}, {38, 0}}

or since this question is regarding the sublists as sets, perhaps it would be best to validate using the canonical (fully-sorted) version.

{{0, 38}, {1, 19}, {2, 40}, {8, 32}, {20, 40}, {24, 34}, {4, 4, 7, 26}, 
 {5, 24, 36, 42}, {0, 6, 22, 27, 29}, {0, 8, 10, 18, 19}, {2, 20, 35, 39, 41}, 
 {2, 24, 29, 29, 33}, {3, 6, 12, 33, 36}, {6, 29, 30, 34, 39}, 
 {14, 15, 18, 20, 38}}

I hope this is useful to anyone working on this surprisingly (to me) difficult problem.

Answer 1

I'm posting a whole new answer because I don't want to inherit any of the votes I received for my previous wrong answer. In formulating my new answer, I was aiming for correctness, simplicity, and reasonable (but not stellar) performance. Simplicity was achieved by taking a recursive approach, the clarity of which gives me confidence in the correctness of this answer.

remover[sets_, tagged_: tag[]] :=
  Module[{car = First @ sets, cdr = Rest @ sets},
    If[cdr === {}, 
      Return[tag[tagged, car]]];
      remover[
        cdr, 
        If[AnyTrue[cdr, ContainsAll[#, car] &], tagged, tag[tagged, car]]]]

removeSubsets[data : {Repeated[{__}, {2, ∞}]}] :=
   List @@ Flatten[remover[Sort[Sort /@ data]]]

The code is written very much in classic Scheme style, and former Lisp/Scheme programmers reading this will be aware of the historical basis for my choice of car and cdr for my local variable names.

Does it work? Well, given

test = 
  {{26, 4, 4, 7}, {12, 3, 36, 6, 33}, {0, 29, 6, 22, 27}, {34, 24}, {24, 36}, 
   {29, 29, 2, 33, 24}, {35, 20, 41, 2, 39}, {19, 1}, {20, 40}, {3}, {18}, {18, 10}, 
   {4}, {32, 8}, {6, 34, 39, 30, 29}, {41}, {20, 38, 15, 18, 14}, 
   {19, 10, 8, 18, 0}, {24, 5, 36}, {40, 2}, {2, 40}, {38, 0}, {10}, 
   {24, 5, 36, 42}};

then

removeSubsets[data]

produces

 {{0, 38}, {1, 19}, {2, 40}, {8, 32}, {20, 40}, {24, 34}, {4, 4, 7, 26}, 
  {5, 24, 36, 42}, {0, 6, 22, 27, 29}, {0, 8, 10, 18, 19}, {2, 20, 35, 39, 41}, 
  {2, 24, 29, 29, 33}, {3, 6, 12, 33, 36}, {6, 29, 30, 34, 39}, 
  {14, 15, 18, 20, 38}}

which is what I think should be the correct result. I did quite a bit of additional test, too, without failure.

Update

I like the above solution for its simple clarity, but I have to admit that it has a problem. The recursion isn't tail-recursive, so it can't handle really large lists of sets. This is fixed in the following tail-recursive code.

remover[car_, {}, tagged_] := tag[tagged, car]
remover[car_, cdr_, tagged_: tag[]] :=
  remover[
    First[cdr],
    Rest[cdr],
    If[AnyTrue[cdr, ContainsAll[#, car] &], tagged, tag[tagged, car]]]

removeSubsets[data : {Repeated[{__}, {2, ∞}]}] :=
  With[{sets = Sort[Sort /@ data]}, 
    List @@ Flatten[remover[First[sets], Rest[sets]]]]

You can still exceed $IterationLimit with this code, but you can raise that limit to very high values without getting into trouble. Raising $RecursionLimit to very high values can lead to stack overflow, which Mathematica does not handle very gracefully -- stack overflow crashes the evaluation kernel.

Perfomance

This update looks into the performance to removeSubsets. To do this I wrote a data generator and a simple benchmark function.

makeSets[maxVal_, minElements_, maxElements_, size_] := 
  Table[RandomInteger[maxVal, RandomInteger[{minElements, maxElements}]], {size}]

benchMark[nSets_Integer /; nSets > 1] :=
  Module[{data, timing, removed},
    SeedRandom[nSets];
    data = makeSets[20, 1, 7, nSets];
    Block[{$IterationLimit = 2 nSets},
      {timing, removed} = AbsoluteTiming[nSets - Length[removeSubsets[data]]];
      {nSets, timing, removed}]]

I then gathered some performance data

performanceData = Table[benchMark[i], {i, 200, 5000, 200}];

and took a first look at it in table form.

Module[{title},
 title =
  Item[Style[#, "SR"], Alignment -> Center] & /@ {"Sets", "Timing", 
    "Subsets\nremoved"};
 Grid[Prepend[performanceData, title],
  Alignment -> ".",
  Spacings -> 1,
  Dividers -> {None, {False, True}}]]

This suggested a power law to me. Something like O(n^(3/2)), so I proceeded to making a fit.

fit = Module[{data},
  data = performanceData[[All, {1, 2}]]; 
  NonlinearModelFit[data, a x^b, {{a, .00002}, {b, 1.5}}, x]]

The fit is quite satisfactory

Show[
  ListPlot[performanceData[[All, {1, 2}]]], 
  Plot[fit[x], {x, 0, 5000}], Frame -> True, AspectRatio -> 1]

and so it turns out the performance is more like O(n^(5/3). which is not as good as my original and in itself unimpressive estimate of O(n^(3/2).

Answer 2

The procedure posted by Xavier can be sped up nicely using some undocumented features, under the same conditions of that code (data comprises sets of positive integers):

minSets3[list_] := Module[{u = DeleteDuplicates@list, ju, rl, lsl, x, y, sp, ranger},

    ranger[l_, lens_] := With[{al = Accumulate@lens}, 
          Inner[l[[# ;; #2]] &, Most@Prepend[al, 0] + 1, al, List]];

    System`SetSystemOptions["SparseArrayOptions" -> {"TreatRepeatedEntries" -> Total}];
    x = Partition[(ju = Join @@ u), 1];
    y = Join @@ ConstantArray @@@ 
       Transpose[{rl = 2^Range[0, Length@u - 1], lsl = Length /@ u}];
    sp = SparseArray[x -> y];
    System`SetSystemOptions["SparseArrayOptions" -> {"TreatRepeatedEntries" -> First}];

    Pick[u, Subtract[BitAnd @@@ ranger[Normal[sp][[ju]], lsl], rl], 0]];

We compare the performance of this code to minSets2 (see Xavier's post) using again the data set generator and benchmark function of m_goldberg. We however modify the makeSets function to avoid having zero's from RandomInteger, otherwise SparseArray returns an error.

(Note that we can instead slightly modify minSets3 by adding 1 to the local value of u and subtracting 1 to the last line of the code. In any case, this does not affect the performance.)

We can see the improvement, and a for larger number of sets it becomes more significant, e.g. for 300'000:

data = Sort /@ makeSets[20, 1, 7, 300000] // Sort;
minSets2[data]; // AbsoluteTiming
minSets3[data]; // AbsoluteTiming

(* {4.47073, Null} *)
(* {3.94752, Null} *)

In addition, testing minSets3 for other types of data sets (in terms of structure/size) was anywhere from 15-100% faster than minSets2, with the usual loungebook performance caveats.

As an aside, it seems the structure of the OP list was missed in existing answers:

The lists of data actually are arithmetic sequence.[sic]

Using that, one can easily build structures that encode covering of sets. A cobbled up set of raw code showed this to be a method that can exhibit excellent performance (e.g., a 100K length list of large sets with some dominating sets completed in a fraction of a second on the loungebook, so about 10X faster than minSets2 for the same data on same machine.)

Answer 3

Follow two codes to remove subsets efficiently (courtesy of ciao).

Codes

minSets

minSets[list_List] := Module[{u = Union@list, f, rl},
   f[_] = 0;
   MapThread[f[#] += #2 &, {Join @@ u, Join @@ MapThread[
        ConstantArray, {rl = 2^Range[0, Length@u - 1], Length /@ u}]}];
   Pick[u, Subtract[BitAnd @@@ Map[f, u, {2}], rl], 0]];

minSets2

minSets2d[list_List] := Block[{u = Union@list, r}, 
   Pick[u, Subtract[BitAnd @@@ Replace[u, With[{
           g = GatherBy[Transpose[{Join @@ u, Join @@ MapThread[
           ConstantArray, {r = 2^Range[0, Length@u - 1], Length /@ u}]}], First]}, 
        Dispatch@Thread[g[[All, 1, 1]] -> Total[g[[All, All, 2]], {2}]]], {2}], r], 0]]

Explanation

I find this technique very nice (and it's also very fast — see the timings below). So here is how the codes work in more details for interested people.

Each element value is mapped to the sublist(s) to which it belongs. Suppose we have a list list = {{2,7},{2,7,9}}. Value 2 is mapped to {1,2} as it belongs to the two sublists, value 7 is mapped to {1,2} and value 9 is mapped to {2}.

The elements of the first sublist, 2 and 7, are thus mapped to {1,2} and {1,2}. The intersection of these tells us that all the elements of the first sublist 1 are subsets of another sublist, 2. So we can drop it.

The codes use this approach with binary maps. The rationale for the above example is as follows.

Since value 2 belongs to the first and second sublists, it can be mapped to the binary number 1 1. (We can read it from left to right: a 1 at position n means that the value belong to the sublist n, a 0 would mean it does not.) Similarly for value 7. Value 9 belongs to the second sublist only, it is mapped to the binary number 1 0.

The elements of the first list are both mapped to 1 1 and the intersection (BitAnd) gives us 1 1. This tells us that they are subsets of another sublist, namely the second one. So we can drop the first sublist.

To end the explanation, the codes use the base-10 representation of the binary numbers. So for instance instead of 1 1 and 1 0, they consider 3 and 2 respectively. (See 2^Range[0, Length@u - 1].)

Timings

Using the data generator and benchmark function of m_goldberg, for a number of sets from 200 to 4'000 with a 200 step:

We can see how efficient it is.

We discriminate the timings between minSets and minSets2 for a larger number of sets. From 200 sets to 50'000 with a 200 step:

We clearly see the performance improvement of minSets2. Same plot in log-log scale:

Both codes scale nicely with the number of sets.

Answer 4

Just a way. Sorts first and removes identical elements, then elements that are strict subsets of other elements...

fun[lst_] := 
 Module[{sort = DeleteDuplicates[Sort[Sort /@ lst]], sa, w},
  sa = SparseArray@
    Outer[Boole[SubsetQ[#1 /. w -> List, #2 /. w -> List]] &, 
     w @@@ sort, w @@@ sort];
  ReplacePart[sort, 
   Thread[(Last /@ DeleteCases[sa["NonzeroPositions"], {a_, a_}]) -> 
     Sequence[]]]]

Using:

test = {{26, 4, 4, 7}, {12, 3, 36, 6, 33}, {0, 29, 6, 22, 27}, {34, 
    24}, {24, 36}, {29, 29, 2, 33, 24}, {35, 20, 41, 2, 39}, {19, 
    1}, {20, 40}, {3}, {18}, {18, 10}, {4}, {32, 8}, {6, 34, 39, 30, 
    29}, {41}, {20, 38, 15, 18, 14}, {19, 10, 8, 18, 0}, {24, 5, 
    36}, {40, 2}, {2, 40}, {38, 0}, {10}, {24, 5, 36, 42}};

fun[test]yields:

{{0, 38}, {1, 19}, {2, 40}, {8, 32}, {20, 40}, {24, 34}, {4, 4, 7,
26}, {5, 24, 36, 42}, {0, 6, 22, 27, 29}, {0, 8, 10, 18, 19}, {2,
20, 35, 39, 41}, {2, 24, 29, 29, 33}, {3, 6, 12, 33, 36}, {6, 29,
30, 34, 39}, {14, 15, 18, 20, 38}}

Answer 5

Using:

$posLenIdx = Association@MapIndexed[First@#2-> Length@#&, test];
$revItenIdx = Merge[Identity]@MapIndexed[Association@Thread[#-> First@#2]&, test];

and:

testSet[set_List, {pos_}]:=Block[{biggerGroups, len = Length@set},
    biggerGroups = Select[Tally@Flatten@Lookup[$revItenIdx, set, {}],
    				(
    				 #[[2(*qtd*)]] >= Length@set
    				 && #[[1(*pos*)]]!=pos
    				 &&(#[[1(*pos*)]]/.$posLenIdx) >len
                )&];
    If[biggerGroups==={}, set, Nothing]
]

We can get the result with:

result2 = MapIndexed[testSet, test];
result2 = DeleteDuplicates[Sort /@ result2]

Length@Intersection[result2, result ] == Length@result2

True

Let me know if the speed improvement is ok.