# Deleting duplicates after n-occurrences

As a generalization of DeleteDuplicates, I want to delete duplicates from a list, but only after n number of duplicates.

Say, n = 3 means that three duplicates are allowed.

I made my own function:

DeleteDuplicatesN[x_, n_] :=
x[[
Sort[
Flatten[#[[1 ;; Min[Length[#], n]]]& /@
(Flatten[Position[x, #]]& /@ DeleteDuplicates[x])]]]]

DeleteDuplicatesN[{1, 2, 3, 2, 1, 1, 1, 2, 3, 5, 5, 5, 5, 1, 7, 4, 7, 1}, 3]

{1, 2, 3, 2, 1, 1, 2, 3, 5, 5, 5, 7, 4, 7}


Is there a better method — faster or more elegant?

For example, using only DeleteDuplicates or DeleteDuplicatesBy?

I think you'll find this faster:

dd[list_, n_] :=
Module[{pi = Flatten[Values[PositionIndex[list][[All, ;; UpTo@n]]]]},
list[[Sort@pi]]];


Using RandomInteger[20000, 20000] as a test list and allowing 3 duplicates, your code took ~37 seconds, this needed ~0.03 seconds.

Comparable in speed, simpler:

dd2[list_, n_] :=
list[[Union @@
GatherBy[Range@Length@list, list[[#]] &][[All, ;; UpTo@n]]]];


For large lists that aren't grossly duplicated elements, this offers a performance edge (e.g., with RandomInteger[10000000,20000000] test list, over 6X speed of above methods):

dd=Module[{o = Ordering@#},
o[[o]] = Join @@ Range[Tally[#[[o]]][[All, 2]]];
Pick[#, UnitStep[#2 - o], 1]]&;

• Nice. If nobody comes with a better code in a day or so I will accept your answer. Aug 19, 2020 at 22:47
• We can use Sort[pi] instead of pi[[Ordering[pi]]]. If I am not mistaken it is the same speed but more transparent code. Aug 19, 2020 at 23:08
• @azerbajdzan - yes, that function was snipped from some code that used the ordering later. I've made the readability change.
– ciao
Aug 19, 2020 at 23:16
• Maybe this is a good one for the Function Repository? Aug 20, 2020 at 8:13
• @azerbajdzan - ? It is written as a pure function - the slot are the arguments. It is called the same way as the other examples.
– ciao
Aug 20, 2020 at 19:15
list = {1, 2, 3, 2, 1, 1, 1, 2, 3, 5, 5, 5, 5, 1, 7, 4, 7, 1};


Using DeleteElements (new in 13.1)

p = Rule @@ Reverse /@ Cases[Tally @ list + Threaded[{0, -3}], {_, _?Positive}]


{3, 1} -> {1, 5}

Delete 3 ones and 1 five

Reverse @ DeleteElements[Reverse @ list, p]


{1, 2, 3, 2, 1, 1, 2, 3, 5, 5, 5, 7, 4, 7}

Since DeleteElements works from left to right we have to Reverse twice

list = {1, 2, 3, 2, 1, 1, 1, 2, 3, 5, 5, 5, 5, 1, 7, 4, 7, 1};


A variant of the first accepted answer:

list[[Union @@ PositionIndex[list][[All, ;; UpTo[3]]]]] // RepeatedTiming

(*{0.0000210309, {1, 2, 3, 2, 1, 1, 2, 3, 5, 5, 5, 7, 4, 7}}*)

list[[Sort@
Flatten[Values[
PositionIndex[list][[All, ;; UpTo[3]]]]]]] // RepeatedTiming

(*{0.0000263463, {1, 2, 3, 2, 1, 1, 2, 3, 5, 5, 5, 7, 4, 7}}*)


Another variant using Tally:

list[[Union @@ Tally[PositionIndex[list]][[All, 1, ;; UpTo[3]]]]]

(*{1, 2, 3, 2, 1, 1, 2, 3, 5, 5, 5, 7, 4, 7}*)