# 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? – vapor May 15 '17 at 10:45
• {1,2,3,3,4,3}, shoud remain the same – David Baghdasaryan May 15 '17 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}? – Anjan Kumar May 15 '17 at 13:09
• It should be {1, 3, 5, 5, 12, 5, 5, 11, 7, 7, 9, 10, 2, 4} – David Baghdasaryan May 15 '17 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. – Anjan Kumar May 15 '17 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. – Mr.Wizard May 17 '17 at 12:55
• @Mr.Wizard Thanks. – Michael E2 May 17 '17 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? – Michael E2 May 17 '17 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. – Mr.Wizard May 17 '17 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. – Mr.Wizard May 17 '17 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. – Michael E2 May 17 '17 at 13:28
• @MichaelE2 I updated both this answer and the older one to clarify the situation as I now observe it. – Mr.Wizard May 17 '17 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[#].) – Michael E2 May 15 '17 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. – vapor May 16 '17 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. – Michael E2 May 16 '17 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. – Anjan Kumar May 15 '17 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. – Michael E2 May 15 '17 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. – Anjan Kumar May 16 '17 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. – Michael E2 May 16 '17 at 0:29
• Thanks for clarifying that up. I read it differently. – Anjan Kumar May 16 '17 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.) – Michael E2 May 17 '17 at 13:35