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:

dd1[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 filled with 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]]&;

Answer 2

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}*)

Answer 3

or

DeleteDuplicatesN[list_, n_] := Module[{counts},
  counts = <||>;
  
  First@Last@Reap[
    Scan[
      (counts[#] = Lookup[counts, #, 0] + 1;
       If[counts[#] <= n, Sow[#]]) &,
      list
    ]
  ]
]

list = {1, 2, 3, 2, 1, 1, 1, 2, 3, 5, 5, 5, 5, 1, 7, 4, 7, 1};
result = DeleteDuplicatesN[list, 3]

Answer 4

Below are one original algo, one basically re-shuffled dd1 from @ciao and one based on dd from @ciao.

Data:

list0 = {1, 2, 3, 2, 1, 1, 1, 2, 3, 5, 5, 5, 5, 1, 7, 4, 7, 1};
list1 =RandomInteger[20000, 20000];
list2 = RandomInteger[10000000, 20000000];
list3 = RandomSample[Table[Table[#, RandomInteger[{1, 10}]] &@RandomInteger[{1, 100},RandomInteger[{1, 100}]], 1000] // Flatten];

Proposed functions:

ddn1[list_,n_]:=list[[Sort@Flatten[Nearest[list->"Index",DeleteDuplicates@list,{All,0.}][[All,;;UpTo@n]]]]];
ddn2[list_,n_]:=list[[Sort@Flatten[Values[PositionIndex[list]][[All,;;UpTo@n]]]]];(* based on dd1 from @ciao *)
ddd=Module[{o=Ordering@#,t},t=Tally[#[[o]]][[All,2]];o[[o]]=Join@@(Range@Range[Max@t])[[t]];Delete[#,Partition[Pick[Range@Length@#,UnitStep[#2-o],0],1]]]&;(* optimized dd from @ciao + Delete picked positions instead of Picking the list *)

For short lists (list0):

For medium lists (list1):

For large lists (list2):

For special case lists proposed by @azerbajdzan (list3):

Bottomline:

For small lists, surprisingly, ddn2 is a bit faster than @ciao's dd1, though they are basically identical.

For medium and large lists, ddd, which is based on dd by @ciao with optimized Range and employs Delete[list, Pick@Range] instead of Pick@list, is times faster than the original dd.

For special lists like proposed by @azerbajdzan, ddn1 seems to be a bit faster than dd2 by @ciao.

Answer 5

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