Deleting duplicates after n-occurrences

Question

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?

Answer 1

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]]&;