# Removing elements from a nested list based on their global count

I have a very large table containing sublists, such as for instance:

{{1, 2, 3}, {4, 5, 6, 7}, {1}, {1, 8}, {9, 10}, {11, 6, 12, 13, 14, 15, 16}}


I want to remove elements from all sublists based on their count. For example, from the list above I would like to remove all elements of count greater than or equal to 2. In this case only 1 and 6 appear more than twice, so those should be removed, and I would like the following output:

{{2, 3}, {4, 5, 7}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}}

• This does not remove the 1's and 6's inside the sublist Aug 7, 2015 at 21:52
• How dense is the list, that is, is the expectation of duplicate/triplicate/etc. high or low? Depending on this, methods posted so far can be handily beaten. And what is "very large"? Millions of sublists, or thousands? Different techniques for each case...
– ciao
Aug 7, 2015 at 23:29
• What would be the bottleneck, @ciao, tallying, the selecting, or the delete cases? Aug 8, 2015 at 2:39
• @march: I'd venture the selecting - but when/if OP more precisely specifies, I'll enter the fray with ideas if appropriate. As it stands, too under-specified to guide fastest solution, IMO.
– ciao
Aug 8, 2015 at 5:11

Version 10 offers Counts which is useful for this question:

$list = {{1, 2, 3}, {4, 5, 6, 7}, {1}, {1, 8}, {9, 10}, {11, 6, 12, 13, 14, 15, 16}}; count = Counts @ Flatten @$list

(* <| 1->3, 2->1, 3->1, 4->1, 5->1, 6->2, 7->1, 8->1, 9->1, 10->1, 11->1,
12->1, 13->1, 14->1, 15->1, 16->1 |> *)

count[6]

(* 2 *)


(A shame that Counts does not accept a level specification.)

With this information, we can use DeleteCases to express the requirement fairly directly:

DeleteCases[$list, x_ /; count[x] >= 2, {2}] (* {{2, 3}, {4, 5, 7}, {}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}} *)  Or we could use Pick to keep the desired values: Pick[$list, Map[count[#] < 2 &, $list, {2}]] (* {{2, 3}, {4, 5, 7}, {}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}} *)  With version 10.2, we can replace all rejected values with Nothing: $list /. x_Integer /; count[x] >= 2 -> Nothing

(* {{2, 3}, {4, 5, 7}, {}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}} *)


... although in earlier versions the cryptic (##&[]) can express the idea of Nothing.

Each of these techniques leaves an empty sublist when all of its original elements are rejected. We can use the operator DeleteCases[{}] to get rid of such empty remnants. For example:

DeleteCases[$list, x_ /; count[x] >= 2, {2}] // DeleteCases[{}] (* {{2, 3}, {4, 5, 7}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}} *)  • The pronunciation of (##&[]) cannot be uttered in polite company. It is a rather harsh colloquial synonym for Nothing. ;) Aug 8, 2015 at 3:35 • Also it's impossible to search for it. – shrx Aug 8, 2015 at 7:09 • @shrx FWIW I use the term "vanishing function" Aug 9, 2015 at 5:42 a = {{1, 2, 3}, {4, 5, 6, 7}, {1}, {1, 8}, {9, 10}, {11, 6, 12, 13, 14, 15, 16}}; b = First /@ Select[Tally[Flatten@a], Last[#] > 1 &]; c = DeleteCases[a /. Thread[b -> Sequence[]], {}]  {{2, 3}, {4, 5, 7}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}} If list = {{1, 2, 3}, {4, 5, 6, 7}, {1}, {1, 8}, {9, 10}, {11, 6, 12, 13, 14, 15, 16}}  then define outs = Alternatives @@ Cases[Tally@Flatten@list, a_ /; Last@a >= 2 :> First@a];  Change the 2 to whatever tally you want. Then DeleteCases[#, outs] & /@ list /. {} -> Sequence[] (* {{2, 3}, {4, 5, 7}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}} *)  Alternatively (based on a comment from MarcoB), DeleteCases[list, outs, {2}] /. {} -> Sequence[]  • As an alternative to Mapping the DeleteCases expression, you could also indicate a level specification for its application, such as DeleteCases[list, outs, 2]. (+1) Aug 7, 2015 at 22:07 • Yes that gets me what I wanted Aug 7, 2015 at 22:07 • @MarcoB. Thanks for the hint (+1); somehow I missed the fact that Cases takes a level-spec. Aug 7, 2015 at 22:22 • Slightly shorter version: list /. Cases[Tally@Flatten@list, a_ /; Last@a >= 2 :> (First@a -> Sequence[])] /. {} -> Sequence[] Aug 7, 2015 at 22:22 • @march no problem, thank you for including it! Aug 7, 2015 at 22:26 My proposal, also leveraging Counts as used by WReach: drop[expr_, thr_Integer] := Pick[expr, Replace[expr, UnitStep[Counts[Join @@ expr] - thr], {2}], 0]  And not quite as efficient but pleasingly terse: drop2[expr_, thr_Integer] := Select[# < thr & /@ Counts[Join @@ expr]] /@ expr  Test: input = {{1, 2, 3}, {4, 5, 6, 7}, {1}, {1, 8}, {9, 10}, {11, 6, 12, 13, 14, 15, 16}}; drop[input, 2]  {{2, 3}, {4, 5, 7}, {}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}}  To drop the empty list you can follow with DeleteCases: input ~drop~ 2 ~DeleteCases~ {}  {{2, 3}, {4, 5, 7}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}}  This appears to be somewhat faster than WReach's formulations. His as functions: WRf1[$list_, n_] :=
With[{count = Counts@Flatten@$list}, DeleteCases[$list, x_ /; count[x] >= n, {2}]
]

WRf2[$list_, n_] := With[{count = Counts@Flatten@$list},
Pick[$list, Map[count[#] < 2 &,$list, {2}]]
]

WRf3[$list_, n_] := With[{count = Counts@Flatten@$list},
\$list /. x_Integer /; count[x] >= 2 :> Sequence[]
]


And a timing comparison:

big = RandomInteger[1*^5, {5000, 100}];

First @ RepeatedTiming @ #[big, 3] & /@ {WRf1, WRf2, WRf3, drop, drop2}

{0.5712, 0.603, 0.593, 0.369, 0.434}

test = {{1, 2, 3}, {4, 5, 6, 7}, {1}, {1, 8}, {9, 10}, {11, 6, 12, 13,
14, 15, 16}}


then

res=test /. Cases[
Tally[Flatten@test], {x_, _?(# >= 2 &)} :> Rule[x, Sequence[]]]


yields:

{{2, 3}, {4, 5, 7}, {}, {8}, {9, 10}, {11, 12, 13, 14, 15, 16}}


and

res/.{}->Sequence[]


will yield desired result