Deleting list elements by comparing to another list

Question

I have two lists as follow. The first is

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

and the second one is:

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

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

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

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:

DeleteCases[l,_?(ContainsAll[{"j","d","x"}])]
DeleteCases[%,_?(ContainsAll[{"d","k","z"}])]

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.

Answer 1

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

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

or

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:

ClearAll[filter3]
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}

versus

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

{13.1298, 19155}

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

{13.1131, 19155}

Answer 2

Pick[l, Or @@@ Outer[SubsetQ, l, p, 1], False]

or

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

or

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

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

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

Answer 3

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_] :=
  Module[{f},
    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}

Answer 4

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:

Dimensions[r]

{91926}

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]

19155

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

Pick[EN, r, 1000] //Short

{{a},{a,h},<<19151>>,{e,g,o,s,t,y,z},{g,m,r,u,y,z}}

Answer 5

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