6
$\begingroup$

given

lst = {{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}}

I want to remove all the sublists which is any other's subset. For the above example, remove {6, 8}

I wrote this

lst //. {x___List, a_List, c___List, b_List, y___List} /; (SubsetQ[a, b] 
|| SubsetQ[b, a]) :> {x, If[SubsetQ[b, a], b, a], c, y}

But it's kind of slow.


The following method comes from a qq group

Intersection[lst, 
    Flatten[Select[
            GatherBy[
                Flatten[(y \[Function] Subsets[y, {Min[Length /@ #], Length[y]}]) /@ # &[
                        DeleteDuplicates[lst]], 1], Sort], Length[#] == 1 &], 1]]
$\endgroup$

5 Answers 5

4
$\begingroup$
multiSubsetQ = Fold[DeleteCases[##, 1, 1] &, ##] == {} &;

lst = {{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}};

We can use multiSubsetQ with Select as in Roman's answer or with RelationGraph and get sink vertices:

rg = SimpleGraph @ RelationGraph[multiSubsetQ, Select[lst, Count[lst, #] == 1 &]];

Graph[rg, VertexLabels -> "Name"]

enter image description here

GeneralUtilities`GraphSinks @ rg
{{1, 5}, {2, 5}, {6, 8, 9}}
GraphComputation`SinkVertexList @ rg
{{1, 5}, {2, 5}, {6, 8, 9}}

Alternatively, we can use the ResourceFunction MultisetComplement to define multiSubsetQ:

multiSubsetQ2 = ResourceFunction["MultisetComplement"][##] == {} &;
 
$\endgroup$
3
$\begingroup$
lst = {{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}};

Select[lst, Count[lst, x_ /; SubsetQ[x, #]] == 1 &]
(*    {{1, 5}, {2, 5}, {6, 8, 9}}    *)

Update

As @hadesth has pointed out, we need to first define a subset function that takes the multiplicity of elements into account:

mysubsetQ[A_List, B_List] := 
  Length[B] <= Length[A] && Sort[A][[;; Length[B]]] == Sort[B]

(or use @kglr's multiSubsetQ or multiSubsetQ2 function).

Now it works more generally:

lst = {{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}, {1, 1}};

Select[lst, Count[lst, x_ /; mysubsetQ[x, #]] == 1 &]
(*    {{1, 5}, {2, 5}, {6, 8, 9}, {1, 1}}    *)
$\endgroup$
5
  • $\begingroup$ it has some problem, as SubsetQ[{1, 2, 3, 5}, {1, 1}] will return True $\endgroup$
    – hadesth
    Commented Jan 1, 2021 at 17:29
  • $\begingroup$ Ah yes, as the documentation states: "SubsetQ does not account for multiplicity of elements." Thanks @hadesth $\endgroup$
    – Roman
    Commented Jan 1, 2021 at 18:25
  • $\begingroup$ you also need to remove duplicates from the input list. $\endgroup$
    – kglr
    Commented Jan 1, 2021 at 18:39
  • $\begingroup$ @kglr why? If lst = {{1}, {1}, {2}} then according to the description the result should be {{2}}, not {{1}, {2}}. "[...] remove all the sublists which is any other's subset" $\endgroup$
    – Roman
    Commented Jan 1, 2021 at 19:09
  • $\begingroup$ Roman, good point ... of course. $\endgroup$
    – kglr
    Commented Jan 1, 2021 at 19:27
1
$\begingroup$
list = {{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}};

Intersection[list,Flatten[Select[GatherBy[Flatten[(y\[Function]Subsets[y,{Min[Length/@#],Length[y]}])/@#&[DeleteDuplicates[list]],1],Sort],Length[#]==1&],1]]

(* {{1, 5}, {2, 5}, {6, 8, 9}} *)

$\endgroup$
1
$\begingroup$

Assuming your set elements are all positive integers, you could convert the sets to a tally form, and then use Internal`ListMin to prune sets. (I gave a variation of this approach in this answer, but in that question minimal subsets were desired instead of maximal subsets). Here is an example using this idea:

lst = {{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}};

i = Total[
    Replace[lst, s_ :> UnitVector[9, s], {2}],
    {2}
]

{{1, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 1, 0, 0, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 1, 0, 1, 0}, {0, 0, 0, 0, 0, 1, 0, 1, 1}}

Then:

r = -Internal`ListMin[-i]

{{0, 0, 0, 0, 0, 1, 0, 1, 1}, {1, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 1, 0, 0, 1, 0, 0, 0, 0}}

Converting back to sets:

Pick[Range[9], #, 1]& /@ r

{{6, 8, 9}, {1, 5}, {2, 5}}

To package this up as a function (and support multisets), I will introduce two helper functions:

fromSets[sets_] := With[{m = Max[sets]},
    Total[
        Replace[sets, s_ :> UnitVector[m, s], {2}],
        {2}
    ]
]

toSets[lists_] := (Flatten @ MapIndexed[ConstantArray[#2[[1]], #1]&, #]&) /@ lists

For example:

fromSets[{{2,4}, {1,2,2,4}, {1,1,3}}]
toSets[%]

{{0, 1, 0, 1}, {1, 2, 0, 1}, {2, 0, 1, 0}}

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

Then, a function that selects maximal sets would be:

maximal[sets_] := toSets @ -Internal`ListMin[-fromSets @ sets]

Your example:

maximal[{{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}}]

{{6, 8, 9}, {1, 5}, {2, 5}}

@Roman's example with a multiset:

maximal[{{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}, {1, 1}}]

{{6, 8, 9}, {1, 5}, {2, 5}, {1, 1}}

Using Internal`ListMin should be orders of magnitude faster than the other answers for large lists of sets.

$\endgroup$
1
  • 1
    $\begingroup$ (1) It is not hard to extend to arbitrary elements using Union to get the universe set, and perhaps a Dispatch table to associate elements to unit vectors. (2) Internal`ListMin now is in the Wolfram Function Repository as ResourceFunction["ParetoListMinima"]. So one need no longer rely on an Internal context function (some people are put off by such). $\endgroup$ Commented Jan 2, 2021 at 15:52
1
$\begingroup$
lst = {{1, 5}, {2, 5}, {6, 8}, {6, 8, 9}, {1, 1}};

Another way using SequencePosition and Pick:

p = Partition[lst, 2, 1, 1];

test = Length@SequencePosition[#1, #2] == 0 & @@ ReverseSortBy[#, Length] &;

Pick[lst, test /@ p]

(*{{1, 5}, {2, 5}, {6, 8, 9}, {1, 1}}*)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.