# Delete repeating elements across sublists

I have a list like this

test = {{1, 3, 5}, {7, 2, 8, 5}, {7, 1, 3}};


The list is guaranteed to have duplicates only across sublists and not within. I would like to remove elements from the sublists which appear more than once across all sublists. One of the lists needs to retain the element, preferably a random one. Empty lists should be preserved. The expected results would be:

RandomRemoveUniques[test]
{{1, 3 }, { 2, 8, 5}, {7}};

RandomRemoveUniques[test]
{{1}, { 7,2, 8, 5}, {3}};

RandomRemoveUniques[test]
{{1,3}, {7, 2, 8, 5}, {}};


I am looking for an efficient solution (as possible) as these list will be fairly large and the function will be called several times.

I can get as far as counting the number of duplicates

count = Counts@Flatten@test
<|1 -> 2, 3 -> 2, 5 -> 2, 7 -> 2, 2 -> 1, 8 -> 1|>


and then I can use DeleteCases[] but I don't know how to satisfy the other two requirements.

• I can't test at the moment, but try this: ReplacePart[test, Flatten[Values[If[Length[#] == 1, Nothing, Complement[#, {RandomChoice[#]}]] & /@ Merge[Flatten[MapIndexed[Rule, test, {2}]], Identity]], 1] -> Nothing] Mar 11, 2018 at 16:25
• Beautiful, looks like it works perfectly fine! Mar 11, 2018 at 16:31

You may use a pattern approach with ReplaceRepeated using RandomChoice and Nothing to randomly delete the duplicates between the sublists.

randomRemoveUniques[list_] :=
list //.
{s___, {s1___, x_, e1___}, m___, {s2___, x_, e2___}, e___} :>
With[{pos = RandomChoice[{True, False}]},
{s, {s1, If[pos, x, Nothing], e1},
m, {s2, If[! pos, x, Nothing], e2}, e}
]


With test as in OP of five example runs.

SeedRandom
Table[randomRemoveUniques[test], 5] // Column

{{},{2,8,5},{7,1,3}}
{{1,5},{7,2,8},{3}}
{{1,5},{2,8},{7,3}}
{{},{7,2,8,5},{1,3}}
{{3,5},{2,8},{7,1}}


Hope this helps.

• Nice pattern matching. Mar 11, 2018 at 21:48

Update

My original answer worked by flattening the list, finding all positions of each number, deleted one of those positions, then set the remaining positions to Inactive[Nothing], repartitioned the list to it's original form, and then activated the list. The speed bottleneck was deleting a representative from each class since it used RandomInteger as many times as there were sublists.

My update instead uses one RandomReal call to determine which position to remove from each set of positions, and is about twice as fast:

rru2[list_]:=Module[{flat = Flatten@list, pi, lens, p, keep, remove},
pi = PositionIndex @ flat;
p = Values @ pi;
lens = Length /@ p;
keep = Accumulate[lens] - Floor[RandomReal[1, Length[lens]] lens];
remove = Flatten[p][[Complement[Range @ Length @ flat, keep]]];
flat[[remove]] = Inactive[Nothing];
Activate @ TakeList[flat, Length /@ list]
]


Comparison using @JEM_Mosig's test data:

test3 = DeleteDuplicates /@ Split[RandomInteger[{1,8000},10000], RandomChoice[{0.8,0.2}->{True,False}]&];

rru2[test3]; //RepeatedTiming
rru[test3]; //RepeatedTiming


{0.015, Null}

{0.029, Null}

Here is one idea:

rru[list_]:=Module[{flat = Flatten@list, pi},
pi = PositionIndex @ flat;
flat[[Flatten @ Values @ Map[deleteRandom] @ pi]] = Inactive[Nothing];
Activate @ TakeList[flat, Length/@list]
]

deleteRandom[a_] := Delete[a, RandomInteger[{1,Length[a]}]]


Here is a run of 100 applications of rru:

Tally @ Table[rru[test], {100}] //Column //TeXForm


$\begin{array}{l} \{\{\{1\},\{7,2,8,5\},\{3\}\},8\} \\ \{\{\{1\},\{2,8,5\},\{7,3\}\},7\} \\ \{\{\{1,5\},\{7,2,8\},\{3\}\},11\} \\ \{\{\{1,3,5\},\{2,8\},\{7\}\},8\} \\ \{\{\{5\},\{2,8\},\{7,1,3\}\},3\} \\ \left\{\left( \begin{array}{cc} 1 & 5 \\ 2 & 8 \\ 7 & 3 \\ \end{array} \right),10\right\} \\ \{\{\{5\},\{7,2,8\},\{1,3\}\},5\} \\ \{\{\{1,3,5\},\{7,2,8\},\{\}\},6\} \\ \{\{\{3\},\{2,8,5\},\{7,1\}\},9\} \\ \{\{\{1,3\},\{7,2,8,5\},\{\}\},5\} \\ \{\{\{\},\{2,8,5\},\{7,1,3\}\},6\} \\ \{\{\{3\},\{7,2,8,5\},\{1\}\},5\} \\ \{\{\{3,5\},\{7,2,8\},\{1\}\},5\} \\ \{\{\{1,3\},\{2,8,5\},\{7\}\},6\} \\ \left\{\left( \begin{array}{cc} 3 & 5 \\ 2 & 8 \\ 7 & 1 \\ \end{array} \right),4\right\} \\ \{\{\{\},\{7,2,8,5\},\{1,3\}\},2\} \\ \end{array}$

• Don't you mean Flatten@list instead of Flatten@test? Mar 11, 2018 at 23:35
• @JEM_Mosig Thanks, fixed now. Mar 12, 2018 at 1:06

Here is a recursive algorithm:

ClearAll[randomRemoveDuplicatesJEMM];
randomRemoveDuplicatesJEMM[sets_List, toDelete_:Alternatives[]] :=
Catch[
Module[{n = Length[sets], i, newSets},
(* delete all elements that match toDelete *)
newSets = DeleteCases[sets, toDelete, Infinity];

(* if only one left, then return the only remaining set *)
If[n == 1, Throw[newSets]];

(* randomly pick one of the sets *)
i = RandomInteger[{1, n}];

(* recursively assemble the list *)
Insert[
randomRemoveDuplicatesJEMM[Delete[newSets, i], Alternatives@@newSets[[i]]],
newSets[[i]],
i
]
]
]


To test the algorithms I use three test sets (note the automatic method to generate test2 and test3):

test1 = {{1, 3, 5}, {7, 2, 8, 5}, {7, 1, 3}};

test2 = DeleteDuplicates /@ Split[RandomInteger[{1,800},1000], RandomChoice[{0.8,0.2}->{True,False}]&];

test3 = DeleteDuplicates /@ Split[RandomInteger[{1,8000},10000], RandomChoice[{0.8,0.2}->{True,False}]&];


For the third test my algorithm requires the setting \$RecursionLimit = 10000 which you may implement locally using Block.

I have also implemented the other algorithms that were suggested and checked the timings on Mathemaitca 11.0:

First@RepeatedTiming[randomRemoveDuplicatesJEMM[#]] & /@
{test1, test2, test3}
(* {0.00010, 0.016, 1.13} *)

First@RepeatedTiming[randomRemoveDuplicatesMGOLDBERG[#]] & /@
{test1, test2}
(* {0.00018, 0.0698} *)

First@RepeatedTiming[randomRemoveDuplicatesEDMUND[#]] & /@
{test1}
(* {0.00018} *)

First@RepeatedTiming[randomRemoveDuplicatesJM[#]] & /@
{test1, test2, test3}
(* {0.00012, 0.00814, 0.094} *)

First@RepeatedTiming[randomRemoveDuplicatesCARLWOLL[#]] & /@
{test1, test2, test3}
(* {0.00013, 0.0055, 0.0581} *)

First@RepeatedTiming[randomRemoveDuplicatesANJANKUMAR[#]] & /@
{test1, test2}
(* {0.0000776, 0.37} *)


When a test case is ommitted, then the algorithm takes more than 5 seconds to complete. I have replaced TakeList by InternalPartitionRagged in Carl Woll's answer, to make it compatible with version 11.0, as he suggested.

In conclusion, in Version 11.0, Carl Woll's answer performes best, shortly followed by the answer given in J.M.'s comment. For short lists, though, Anjan Kumar's answer is faster.

• In versions before 11.2 you can use InternalPartitionRagged instead of TakeList. Mar 12, 2018 at 1:05
• @CarlWoll: nice! Now it works! I'll add this to my answer. Mar 12, 2018 at 1:13

Here is my effort. I found the problem was made more difficult than I first thought by the requirement that it must be able to generate cases where one or more of the final lists may is empty.

randomDeleteDups[a : {{___Integer} ..}] :=
Module[{ints, where, retain, rules},
ints = Union @@ a;
where = Position[a, #] & /@ ints;
retain = SplitBy[Sort[RandomChoice /@ where], First];
rules =
({#[[1, 1]] -> #[[All, 2]]} & /@ retain // Catenate) /.
HoldPattern[i_ -> l_] -> HoldPattern[i -> a[[i]][[l]]];
ReplacePart[ConstantArray[{}, Length @ a], rules // ReleaseHold]]


### Tests

test1 = {{1, 3, 5}, {7, 2, 8, 5}, {7, 1, 3}};

SeedRandom; randomDeleteDups[test1]


{{5}, {2, 8}, {7, 1, 3}}

Tests that which generate empty lists.

 SeedRandom; randomDeleteDups[test1]


{{1, 3, 5}, {7, 2, 8}, {}}

SeedRandom; randomDeleteDups[test1]


{{1, 3}, {7, 2, 8, 5}, {}}

SeedRandom; randomDeleteDups[test1]


{{}, {2, 8, 5}, {7, 1, 3}}

Tests with a bigger list.

SeedRandom;
test2 = Table[RandomInteger[{1, 15}, RandomInteger[{1, 11}]], 5]

{{5, 1}, {1, 1, 9, 7, 1, 14, 5, 2}, {6, 15, 15, 2, 2, 2, 4, 3, 13},
{2, 15, 7, 1, 3, 7, 5, 12, 6, 5, 15}, {1, 2, 4, 14}}

SeedRandom; randomDeleteDups[test2]


{{5}, {9, 7, 14}, {6, 2, 4, 13}, {1, 3, 12, 15}, {}}

SeedRandom; randomDeleteDups[test2]


{{5}, {9, 1}, {6, 15, 4, 3, 13}, {7, 12}, {2, 14}}

• Thanks for taking the time, I'll benchmark these tomorrow evening. Mar 11, 2018 at 19:57

Another approach would be to randomly generate a pair of positions upon which Complement and ReplacePart can be applied to generate random duplicate free lists.

replace[lst_, rule_]:=ReplacePart[lst, #1 -> Complement[lst[[#1]], lst[[#2]]]] & @@ rule;
randomDel[lst_] := Module[{rules, randomRules},
rules = {#, Reverse[#]} & /@ Subsets[Range[Length[lst]], {2}];
randomRules = RandomChoice /@ rules;
Fold[replace, lst, randomRules]
]


Test

test = {{1, 3, 5}, {7, 2, 8, 5}, {7, 1, 3}};
Table[randomDel[test], 5] // Column

{{},{7,2,8,5},{1,3}}
{{1,3},{7,2,8,5},{}}
{{1,3},{7,2,8,5},{}}
{{1,3,5},{2,7,8},{}}
{{},{7,2,8,5},{1,3}}

ClearAll[deDupe]
deDupe = Module[{f, rs = RandomSample[Range@Length@#]},
f[y_] := (f[y] = Sequence[]; y); (f /@ # & /@ #[[rs]])[[Ordering[rs]]]] &;

SeedRandom
Tally[Table[deDupe @ test, {100000}]] // Column // TeXForm


$$\begin{array}{l} \{\{\{1,3\},\{7,2,8,5\},\{\}\},16679\} \\ \{\{\{1,3,5\},\{7,2,8\},\{\}\},16537\} \\ \{\{\{1,3,5\},\{2,8\},\{7\}\},16633\} \\ \{\{\{5\},\{2,8\},\{7,1,3\}\},16591\} \\ \{\{\{\},\{7,2,8,5\},\{1,3\}\},16752\} \\ \{\{\{\},\{2,8,5\},\{7,1,3\}\},16808\} \\ \end{array}$$