19
$\begingroup$

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?

$\endgroup$
0

3 Answers 3

23
$\begingroup$

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

$\endgroup$
1
$\begingroup$
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}*)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.