19
$\begingroup$

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.

$\endgroup$
  • 1
    $\begingroup$ Is Complement[data, Cases[Subsets[data, {2}], x_List /; (MemberQ[x, Union @@ x]) :> First[x]]] any faster? $\endgroup$ – Patrick Stevens Aug 30 '15 at 17:09
  • 1
    $\begingroup$ I see. @yohbs, what if you use Union[] with an appropriate SameTest setting? $\endgroup$ – J. M. is away Aug 30 '15 at 17:11
  • 1
    $\begingroup$ @yohbs, you're right, seeing that the sorting will put the shorter lists first. Oh well… $\endgroup$ – J. M. is away Aug 30 '15 at 17:44
  • 1
    $\begingroup$ This is a woefully underspecified question (as in, what does data like this mean? Is the data always sorted sublists, is it always integers, are they always positive, are sublists nondecreasing in length, etc.). Be that as it may, you can get orders of magnitude improvement -Hint: use bitmaps. $\endgroup$ – ciao Aug 30 '15 at 19:31
  • 1
    $\begingroup$ Closely related, though different: (8154) $\endgroup$ – Mr.Wizard Aug 31 '15 at 2:05
15
$\begingroup$

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

table

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

fit

The fit is quite satisfactory

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

plot

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

$\endgroup$
  • 1
    $\begingroup$ Well, +1 for refs (lisper since 70's, schemer since it's birth, racket fan... in fact used them under covers at wildly successful startup...) $\endgroup$ – ciao Aug 31 '15 at 4:39
  • $\begingroup$ Any chance you might bench yours with data = Take[ DeleteCases[ Table[Range[x = RandomInteger[{1, 100}], RandomInteger[{x + 1, 2 x}], RandomInteger[{1, Max[1, Round[x/5]]}]], {15000}], {_}], 10000];? I've cobbled up something that does this on the loungebook in a few seconds, so I'd gather under a second on one of my WS, curious how it compares (I'm no longer running 10.x on any machine, and refactoring your code would probably result in unfair comparison). $\endgroup$ – ciao Aug 31 '15 at 6:37
  • $\begingroup$ @ciao. Can't run your benchmark. When I try I get a kernel crash after several minutes of runtime. Determined it is not a memory problem. Don't have time to look at it further at this time (past 3 AM in my time zone). Will look it again tomorrow. Provisional assessment is that one or both of ContainsAll or AnyTrue has very bad performance, not to mention having trouble working on large lists. $\endgroup$ – m_goldberg Aug 31 '15 at 7:34
  • $\begingroup$ Well, thanks for giving it a go (and that's indirectly encouraging that my method has merit - the only answer I tried it against (easy refactor, just writing a 9.x version of SubsetQ) was orders of magnitude slower). Bummer to hear of CA/AT flailing, but sadly not surprised - why I reverted to 9 on all of my machines. $\endgroup$ – ciao Aug 31 '15 at 7:38
  • 1
    $\begingroup$ A new way of cycling for me! $\endgroup$ – Apple Aug 31 '15 at 14:26
10
+150
$\begingroup$

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

enter image description here

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

$\endgroup$
8
+150
$\begingroup$

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:

enter image description here

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:

enter image description here

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

enter image description here

Both codes scale nicely with the number of sets.

$\endgroup$
  • $\begingroup$ Nice graphs. Frankly, the voting (or lack of it) and acceptance (or lack of it) on this makes for a pretty good test of how the whole "rep" system works here. +1... $\endgroup$ – ciao Sep 10 '15 at 1:33
  • $\begingroup$ Yes, that was an unexpected choice to me as well... Thanks for the +1, and thanks for sharing the codes. $\endgroup$ – user31159 Sep 10 '15 at 11:22
  • $\begingroup$ @ciao, I run your new code (cannot comment under your post – not enough rep). I tried for 100k sets with data = Sort[Sort /@ makeSets[{1, 20}, 1, 7, 100000]];. For minSets2 : 1.1124; for your raw input code: 1.22212. They appear equivalent on my machine. For 300k sets, minSets2 : 5.11243 and your new code: 4.34846. Faster indeed (very nice, again)! I do not see the improvement of 10x however. I am certainly missing something. What are the timings you get for these data? $\endgroup$ – user31159 Sep 10 '15 at 11:42
  • $\begingroup$ no, that 10x is for not posted method (just a jumble of code pieces right now, not bothering with it since OP never bothered to respond.) The posted was as noted 15% to 100% faster (depending on data structure/size)... $\endgroup$ – ciao Sep 10 '15 at 16:15
  • $\begingroup$ Thanks for your answer, I misread your post. $\endgroup$ – user31159 Sep 10 '15 at 18:37
7
$\begingroup$

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

$\endgroup$
  • $\begingroup$ Pretty quick... +1 $\endgroup$ – ciao Aug 31 '15 at 5:11
4
$\begingroup$

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.

$\endgroup$

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.