Delete the sublist which can be others' subsets

Question

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

kglr · Answer 1 · 2021-01-01T19:28:04.157

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

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"][##] == {} &;

Roman · Answer 2 · 2021-01-01T18:31:29.180

3

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

edited Jan 01 '21 at 18:31

answered Jan 01 '21 at 17:06

Roman

47,322
2
55
121

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

score 1 · Answer 3 · answered Jan 01 '21 at 17:32

1

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

answered Jan 01 '21 at 17:32

hadesth

275
1
4

score 1 · Answer 4 · answered Jan 02 '21 at 04:23

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.

(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\ListMinnow is in the Wolfram Function Repository asResourceFunction["ParetoListMinima"]. So one need no longer rely on anInternal` context function (some people are put off by such). — Daniel Lichtblau, Jan 02 '21 at 15:52

E. Chan-López · Answer 5 · 2024-01-21T23:42:57.173

1

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

edited Jan 21 '24 at 23:42

answered Jan 21 '24 at 23:36

E. Chan-López

23,117
3
21
44

Delete the sublist which can be others' subsets

5 Answers5

Update