# Delete the sublist which can be others' subsets

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


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


GeneralUtilitiesGraphSinks @ rg

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

GraphComputationSinkVertexList @ rg

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


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

multiSubsetQ2 = ResourceFunction["MultisetComplement"][##] == {} &;


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

• it has some problem, as SubsetQ[{1, 2, 3, 5}, {1, 1}] will return True Commented Jan 1, 2021 at 17:29
• Ah yes, as the documentation states: "SubsetQ does not account for multiplicity of elements." Thanks @hadesth Commented Jan 1, 2021 at 18:25
• you also need to remove duplicates from the input list.
– kglr
Commented Jan 1, 2021 at 18:39
• @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" Commented Jan 1, 2021 at 19:09
• Roman, good point ... of course.
– kglr
Commented Jan 1, 2021 at 19:27
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}} *)

Assuming your set elements are all positive integers, you could convert the sets to a tally form, and then use InternalListMin 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 = -InternalListMin[-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 @ -InternalListMin[-fromSets @ sets]


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 InternalListMin should be orders of magnitude faster than the other answers for large lists of sets.

• (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) InternalListMin 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). Commented Jan 2, 2021 at 15:52
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}}*)

DeleteSublists[list_] :=
With[{p = Permutations[list, {2}]},
DeleteCases[
list,
Alternatives @@ Pick[p, Apply[SubsetQ] /@ p][[All, 2]]]]

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


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

DeleteSublists[{{1, 2, 3}, {1, 5}, {2, 5}, {6, 8}, {6, 8, 9}, {3, 2}}]


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

Both results agree with OP's ReplaceRepeated`