Deleting list elements by comparing to another list
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}
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.)
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}