# Deleting list elements by comparing to another list

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.

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

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}

• Nice update. I always seem to use Orderless over OrderlessPatternSequence -- habits are hard to change I guess. – Mr.Wizard Aug 11 '18 at 5:32
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
]


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

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}


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

toBits[list:{__}] := Total[
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}}