9
$\begingroup$

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.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ 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] $\endgroup$
    – J. M.'s eventual burnout ♦
    Mar 11, 2018 at 16:25
  • $\begingroup$ Beautiful, looks like it works perfectly fine! $\endgroup$
    – Three Diag
    Mar 11, 2018 at 16:31

6 Answers 6

Reset to default
7
$\begingroup$

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[3221]
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.

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Nice pattern matching. $\endgroup$
    – alancalvitti
    Mar 11, 2018 at 21:48
6
$\begingroup$

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}

Original answer

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

Improve this answer
$\endgroup$
2
  • $\begingroup$ Don't you mean Flatten@list instead of Flatten@test? $\endgroup$
    – JEM_Mosig
    Mar 11, 2018 at 23:35
  • $\begingroup$ @JEM_Mosig Thanks, fixed now. $\endgroup$
    – Carl Woll
    Mar 12, 2018 at 1:06
4
$\begingroup$

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 Internal`PartitionRagged 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.

Improve this answer
$\endgroup$
2
  • 3
    $\begingroup$ In versions before 11.2 you can use Internal`PartitionRagged instead of TakeList. $\endgroup$
    – Carl Woll
    Mar 12, 2018 at 1:05
  • $\begingroup$ @CarlWoll: nice! Now it works! I'll add this to my answer. $\endgroup$
    – JEM_Mosig
    Mar 12, 2018 at 1:13
3
$\begingroup$

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[1]; randomDeleteDups[test1]

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

Tests that which generate empty lists.

 SeedRandom[5]; randomDeleteDups[test1]

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

SeedRandom[12]; randomDeleteDups[test1]

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

SeedRandom[15]; randomDeleteDups[test1]

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

Tests with a bigger list.

SeedRandom[1]; 
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[1]; randomDeleteDups[test2]

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

SeedRandom[3]; randomDeleteDups[test2]

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

Improve this answer
$\endgroup$
1
  • $\begingroup$ Thanks for taking the time, I'll benchmark these tomorrow evening. $\endgroup$
    – Three Diag
    Mar 11, 2018 at 19:57
1
$\begingroup$

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}}
Improve this answer
$\endgroup$
0
$\begingroup$ 
ClearAll[deDupe]
deDupe = Module[{f, rs = RandomSample[Range@Length@#]}, 
    f[y_] := (f[y] = Sequence[]; y); (f /@ # & /@ #[[rs]])[[Ordering[rs]]]] &;

SeedRandom[1]
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}$$

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.