# Deleting duplicates of a list without touching specified elements

Suppose I have a list, for example: list = {1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4}; and list of duplicates positions in the list positions = {3, 9};, that should not be touched by DeleteDuplicates. Other duplicates should be deleted. (the desired result should be

{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}

Also, the elements defined by positions (for example 5) should not be deleted even if there are many of them in the list. How can this be done in a most efficient way?

• if you have list={1,2,3,3,4,3} and position={3}, what's your expected output? Commented May 15, 2017 at 10:45
• {1,2,3,3,4,3}, shoud remain the same Commented May 15, 2017 at 10:46
• @DavidBaghdasaryan What is the expected output for {1, 3, 5, 5, 12, 5, 5, 11, 7, 7, 9, 10, 2, 2, 4}? is it {1, 3, 5, 5, 12, 5, 11, 7, 7, 9, 10, 2, 4}? Commented May 15, 2017 at 13:09
• It should be {1, 3, 5, 5, 12, 5, 5, 11, 7, 7, 9, 10, 2, 4} Commented May 15, 2017 at 13:15
• Thanks for the response. The question does not say that. It says DeleteDuplicates should not touch the elements at the given positions. Please include that part in the question. Commented May 15, 2017 at 13:27

This should be reasonably fast:

ClearAll[value];
value[exceptions_List] := value[Alternatives @@ DeleteDuplicates@exceptions];
value[exceptions_][x_] /; MatchQ[x, exceptions] := Unique[];
value[exceptions_][x_] := x;


OP's examples:

list = {1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4};
positions = {3, 9};
DeleteDuplicatesBy[list, value[list[[positions]]]]
(*  {1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}  *)

list = {1, 2, 3, 3, 4, 3};
positions = {3};
DeleteDuplicatesBy[list, value[list[[positions]]]]
(*  {1, 2, 3, 3, 4, 3}  *)


Update. Even faster:

ddxc[expr_, exceptions_List] := Module[{value},
(value[#] := Unique[]) & /@ exceptions;
value[x_] := x;
DeleteDuplicatesBy[expr, value]
];

SeedRandom[0];
list = RandomInteger[1000, 10^5];
positions = Range[100];
DeleteDuplicatesBy[list, value[list[[positions]]]] // Length // AbsoluteTiming
ddxc[list, list[[positions]]] // Length // AbsoluteTiming
(*
{0.661751, 10668}
{0.136582, 10668}
*)

• Friendly heads-up: I just posted an answer that is critical of yours, in case you care to rebut. Commented May 17, 2017 at 12:55
• @Mr.Wizard Thanks. Commented May 17, 2017 at 13:15
DeleteDuplicates[list, And[#1 == #2, Not@MemberQ[list[[positions]], #1]] &]


Clarifiation: The performance concern regarding Unique appears to no longer apply in recent versions. The code below still tests faster for me but deprecation of methods using Unique is presently unfounded.

This question is related to How to Gather a list with some elements considered unique and I propose a similar solution to what I offered there.

fn1[a_, p_] :=
Module[{f, x, i = 1},
Scan[(f[#] := x[i++]) &, p];
GatherBy[a, f][[All, 1]]
]

fn1[{1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4}, {5, 7}]

{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}


Compared to Michael's fastest function:

SeedRandom[0];
list = RandomInteger[1*^6, 2*^6];
positions = Range[100];

fn1[list, list[[positions]]]  // Length // AbsoluteTiming
ddxc[list, list[[positions]]] // Length // AbsoluteTiming

{2.90443, 865482}

{7.5404, 865482}

• Is there a danger in using Unique[], or is it simply that your way is faster? Commented May 17, 2017 at 13:17
• @MichaelE2 IIRC using Unique excessively progressively slows the system down as the Symbol table becomes large. See the timings in my linked answer for an example. Commented May 17, 2017 at 13:19
• @MichaelE2 I just ran the referenced example in 10.1.0 and I did not experience the progressive slow-down so I guess that problem has been fixed now? I guess I don't need to warn against it any longer, but for backward compatibility if nothing else it's good to be aware of the problem in older versions. Commented May 17, 2017 at 13:21
• I had considered something like x[i++] in place of Unique[], but Unique[] seemed cleaner. I didn't think of the non-Temporary attribute of the symbols created. I get about the midpoint in timing between ddxc and fn1 if I make that change. Commented May 17, 2017 at 13:28
• @MichaelE2 I updated both this answer and the older one to clarify the situation as I now observe it. Commented May 17, 2017 at 13:32

Here is a working version.

deleteDuplicateRestricted[list_, pos_] :=
Module[{keptElems = list[[pos]], i = foo},
DeleteDuplicatesBy[list,
If[! MemberQ[keptElems, #], Identity[#], i++] &]]

deleteDuplicateRestricted[{1, 2, 3, 3, 4, 3}, {3}]
(*{1, 2, 3, 3, 4, 3}*)

deleteDuplicateRestricted[{1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2,
2, 4}, {3, 9}]
(*{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}*)


There shouldn't be a symbolic place holder like that foo in high quality codes.

• You could replace foo by Unique["foo"]. (Also, you could use # instead of Identity[#].) Commented May 15, 2017 at 17:42
• @MichaelE2 I have tried things like that but it didn't improve the running time. Actually even completely replacing the symbolic placeholder(use 0 as starting index and i-- instead, since there is no negative numbers in the list ) does not help. Perhaps the bottleneck is somewhere else. Commented May 16, 2017 at 2:13
• I just meant it as a response to your remark about foo & quality code. Even "foo" might be better as it cannot be assigned a value. As for speed, I think it's pretty fast, just slightly slower than my first method. That suggests to me that MemberQ is probably the bottleneck. Commented May 16, 2017 at 2:23

The following method indexes the list and then deletes the duplicates

list = {1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4};
positions = {3, 9};
f[x_, pos_] :=
If[MemberQ[pos, Last@First[#]], #[[;; , 1]], Sequence @@ #[[;; , 1]]] & /@
SplitBy[Transpose[{x, Range@Length[x]}], First] // DeleteDuplicates // Flatten;
f[list, positions]
(*{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}*)


The proposed answer works even for the following list:

list = {1, 3, 5, 5, 12, 5, 5, 11, 7, 7, 9, 10, 2, 2, 4};
f[list, positions]
(*{1, 3, 5, 5, 12, 5, 11, 7, 7, 9, 10, 2, 4}*)

• @MichaelE2 Thanks for pointing that out. Please check the edit. Commented May 15, 2017 at 14:10
• Now it deletes one of the 3s (in my example). I get {1, 2, 3, 3, 4, 3} and I think there should be another 3 at the end. Commented May 15, 2017 at 17:31
• @MichaelE2 The question says DeleteDuplicates should not touch the elements at the given positions. So, for an input of {1, 2, 3, 3, 4, 3, 3} and positions of {3}, it should return {1, 2, 3, 3, 4, 3}. This is according to the OP update. Commented May 16, 2017 at 0:25
• I disagree: The final two 3s (= the value of the element at position {3}) should not be "touched" either, as stated in the OP. But comments are not for such debates. Commented May 16, 2017 at 0:29
• Thanks for clarifying that up. I read it differently. Commented May 16, 2017 at 1:00
list = {1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4, 4, 4, 4};

p = {3, 9};


Using SequenceCases and DeleteElements (new in 13.1) - non-competitive timewise for long lists, but short and easy to understand.

c = Complement[SequenceCases[list, {a_, a_} :> a], list[[p]]]


{2, 4, 12}

n = Lookup[c] @ Counts[list] - 1


{1, 3, 1}

DeleteElements[list, n -> c]


{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}

A oneliner

DeleteElements[list, Lookup[#] @ Counts[list] - 1 -> #]& @
Complement[SequenceCases[list, {a_, a_} :> a], list[[p]]]


{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}

There is also this one:

 (a = Delete[list, Transpose[{Flatten[Lookup[PositionIndex[list],
Complement[list, list[[positions]]]][[All, 2 ;;]]]}]];)//Timing

(b = ddxc[list, list[[positions]]];) // Timing

a === b


{0.125, Null}

{0.265625, Null}

True

• Nice! (Note that Timing is unreliable in hyperthreaded environments. I usually use AbsoluteTiming or RepeatedTiming.) Commented May 17, 2017 at 13:35

An alternative using Split:

list = {1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4};

p = {3, 9};

sp = Split[list];
elems = Extract[list, List /@ p];

Catenate[If[! ContainsAny[#, elems], Union@#, #] & /@ sp]

(*{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}*)


Or using Tally:

ta = Tally[list];
rep = {a_, b_} :> Splice@Array[a &, b];

(If[! ContainsAny[#, elems], {#[[1]], 1}, #] & /@ ta) /. rep

(*{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}*)


Using MapIndexed:

The strategy is to convert an entry in list either at one of the positions in p or an actual entry in the list p an interim value, that does not contradict another assigned value. After that run DeleteDuplicates and then restore the augmented entry.

Clear["Global*"];
f[list_List, p_List] :=
Module[{r1},
r1 = MapIndexed[
If[MemberQ[p, First@#2] || MemberQ[list[[p]], #1], {#1,
First@#2}, #] &, list];
DeleteDuplicates[r1] /. {a_, b_} :> a
]


Usage:*

list = {1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4};
p = {3, 9};
f[list, p]


{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4}

Compare with above where the the two added entries at the end are also protected:

list = {1, 3, 5, 5, 12, 12, 6, 11, 7, 7, 9, 10, 2, 2, 4, 5, 7};
p = {3, 9};
f[list, p]


{1, 3, 5, 5, 12, 6, 11, 7, 7, 9, 10, 2, 4, 5, 7}

list = {1, 2, 3, 3, 4, 3, 3};
p = {3};
f[list, p]
`

{1, 2, 3, 3, 4, 3, 3}