I have two lists as follow. The first is


and the second one is:


I want to delete those combination that exist in p from l, such that I get:


this is because {"d","a","k","o","l","z"} contains {"d","k","z"} and {"j","a","d","o","x"} contains {"j","d","x"}. The way I did this so far is:


The above does the job, yet for a long list of p this would be ineffective as one would have to use 100s of DeleteCases commands. I wonder if there is a clever way of doing this?

EDIT: As @rhermans suggested I am going to give a realistic example, let us make a list of all English words, separated by their letters as follow:

En = Alphabet["English"];
Characters[ToLowerCase[WordList[Language -> "English"]]];
Select[%, SubsetQ[En, ToLowerCase[#1]] &];
EN = Map[Sort, Map[DeleteDuplicates, %]];

We then make a list containing all the subsets of size 3 from the English alphabet, that is

l = Subsets[En, {3}]

Now for l[[1 ;; 1000]] delete the cases in EN that contain l.

  • $\begingroup$ @HenrikSchumacher This is not a suitable command, I tried it. $\endgroup$
    – Wiliam
    Aug 10, 2018 at 13:38
  • $\begingroup$ There are many solutions, can you provide a sample of a realistic big data set to compare performance? $\endgroup$
    – rhermans
    Aug 10, 2018 at 13:55

5 Answers 5

DeleteCases[l, _?(Function[x,Or@@(ContainsAll[x,#]&/@p)])]

{{"a", "b", "c"}, {"a", "x"}, {"g", "f", "k"}}


DeleteCases[l, _?(Or@@(Function[t,ContainsAll[#,t]]/@p)&)]

{{"a", "b", "c"}, {"a", "x"}, {"g", "f", "k"}}

Update: A variant of Mr. Wizard's filter using OrderlessPatternSequence:

filter3[l_, p_] := Module[{f}, f[{Alternatives @@ 
  (OrderlessPatternSequence[##& @@ #,___]& /@ p)}] := 0; f[_] := 1; Pick[l, f /@ l, 1]]  

filter3[l, p] 

{{"a", "b", "c"}, {"a", "x"}, {"g", "f", "k"}}

This is faster than both filter and filter2:

filter3[EN, ss~Take~1000] // Length // AbsoluteTiming 

{9.43515, 19155}


filter[EN, ss~Take~1000] // Length // AbsoluteTiming

{13.1298, 19155}

filter2[EN, ss~Take~1000] // Length // AbsoluteTiming 

{13.1131, 19155}

  • $\begingroup$ Nice update. I always seem to use Orderless over OrderlessPatternSequence -- habits are hard to change I guess. $\endgroup$
    – Mr.Wizard
    Aug 11, 2018 at 5:32
Pick[l, Or @@@ Outer[SubsetQ, l, p, 1], False]


Fold[DeleteCases[#1, _?(ContainsAll[#2])] &, l, p]


Fold[{a, b} \[Function] Select[a, ! SubsetQ[#, b] &], l, p]

or (parallelized and thus should be faster than the others for longer lists)

 ParallelTable[Or @@ Map[SubsetQ[x, #] &, p], {x, l}, 
  Method -> "CoarsestGrained"],

This question is related to: How to select minimal subsets?

If you want a solution that performs well with a long $p$ list you do not want one that rescans naively for each of its elements, as supplied in the other answers. (Sorry, guys.)

Instead try:

filter[l_, p_] :=
    SetAttributes[f, Orderless];
    (f[##, ___] = Sequence[]) & @@@ p;
    f[else__] := {else};
    f @@@ l

filter2[l_, p_] :=
  Module[{f, g},
    SetAttributes[f, Orderless];
    (f[##, ___] = True) & @@@ p;
    g[a_] /; f @@ a = Sequence[];
    g[a_] := a;
    g /@ l

filter[l, p]
filter2[l, p]
{{"a", "b", "c"}, {"a", "x"}, {"f", "g", "k"}}

{{"a", "b", "c"}, {"a", "x"}, {"g", "f", "k"}}    (* original set order *)

These will actually finish on your sample problem, whereas the others will run indefinitely:

En = Alphabet["English"];
Characters[ToLowerCase[DictionaryLookup[{"English", "*"}]]];
Select[%, SubsetQ[En, ToLowerCase[#1]] &];
EN = Map[Sort, Map[DeleteDuplicates, %]];
ss = Subsets[En, {3}];

filter[EN, ss ~Take~ 1000]  // Length // AbsoluteTiming

filter2[EN, ss ~Take~ 1000] // Length // AbsoluteTiming
{9.09321, 19155}

{9.09125, 19155}

String Patterns

The method above was written to be general, but if your sample problem truly is representative you may consider String patterns as an alternative:

pat = StringRiffle[#, {"*", "*", "*"}] & /@ Take[ss, 1000];

joinEN = StringJoin /@ EN;

Pick[joinEN, StringMatchQ[joinEN, pat], False] // Length // AbsoluteTiming
{5.16058, 19155}

Another idea is to use bit vectors. Here I convert the subsets and words into bit vectors:

toBits[list:{__}] := Total[
    list /. Thread[CharacterRange["a","z"] -> 2^Range[0,25]],
    If[StringQ @ list[[1]], {1}, {2}]

bWords = toBits[EN]; //RepeatedTiming
bSets = toBits[ss]; //RepeatedTiming

{0.71, Null}

{0.013, Null}

Now, for the Boolean contains/free predicate, we want to check whether the word is missing a letter (bit) from the set. I will define the following predicate:

bAndQ[a_, b_] := Unitize @ BitAnd[a, b]

We can use the predicate for set membership. For example:

bAndQ[BitNot[Range[20]], 6]

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

Note how 6, 7, 14 and 15 (which all have bits 2^1 and 2^2 set) return 0, the others return 1. For speed reasons, it will be convenient to define the not version of bWords:

nbWords = BitNot[bWords]; //RepeatedTiming

{0.00027, Null}

Putting things together:

r = Total @ Table[bAndQ[nbWords, b], {b, bSets[[;;1000]]}]; //RepeatedTiming

{0.46, Null}

The dimensions of r are:



Each element of r is equal to 1000 if it does not contain any of the sets. So, the number of words that don't contain any of the sets is:

Count[r, 1000]


in agreement with the other answers. If you want to know which words these are, you can use Pick:

Pick[EN, r, 1000] //Short


p = 
  {{"j", "d", "x"}, {"d", "k", "z"}};

list = 
  {{"a", "b", "c"}, {"a", "x"}, {"g", "f", "k"}, {"d", "a", "k", "o", "l", "z"}, {"j", "a", "d", "o", "x"}};

Define a deconstructing function

f[a_][b_] /; Or @@ Map[ContainsAll[b, #] &, a] := Nothing

f[_][b_] := b

and map it

f[p] /@ list

{{"a", "b", "c"}, {"a", "x"}, {"g", "f", "k"}}


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.