# Deleting duplicates of a list without touching specified elemets

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? May 15, 2017 at 10:45
• {1,2,3,3,4,3}, shoud remain the same 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}? May 15, 2017 at 13:09
• It should be {1, 3, 5, 5, 12, 5, 5, 11, 7, 7, 9, 10, 2, 4} 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. 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. May 17, 2017 at 12:55
• @Mr.Wizard Thanks. May 17, 2017 at 13:15

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? 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. 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. 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. 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. May 17, 2017 at 13:32
DeleteDuplicates[list, And[#1 == #2, Not@MemberQ[list[[positions]], #1]] &]


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[#].) 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. 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. 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. 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. 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. 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. May 16, 2017 at 0:29
• Thanks for clarifying that up. I read it differently. May 16, 2017 at 1:00

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.) May 17, 2017 at 13:35