Deleting duplicates of a list without touching specified elements

Question

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?

Answer 1

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

Answer 2

DeleteDuplicates[list, And[#1 == #2, Not@MemberQ[list[[positions]], #1]] &]

Answer 3

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}

Answer 4

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.

Answer 5

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

Answer 6

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}

Answer 7

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

Answer 8

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

Answer 9

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}