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.

$\endgroup$
  • 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. is away Mar 11 '18 at 16:25
  • $\begingroup$ Beautiful, looks like it works perfectly fine! $\endgroup$ – Three Diag Mar 11 '18 at 16:31
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.

$\endgroup$
  • 1
    $\begingroup$ Nice pattern matching. $\endgroup$ – alancalvitti Mar 11 '18 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}$

$\endgroup$
  • $\begingroup$ Don't you mean Flatten@list instead of Flatten@test? $\endgroup$ – JEM_Mosig Mar 11 '18 at 23:35
  • $\begingroup$ @JEM_Mosig Thanks, fixed now. $\endgroup$ – Carl Woll Mar 12 '18 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.

$\endgroup$
  • 3
    $\begingroup$ In versions before 11.2 you can use Internal`PartitionRagged instead of TakeList. $\endgroup$ – Carl Woll Mar 12 '18 at 1:05
  • $\begingroup$ @CarlWoll: nice! Now it works! I'll add this to my answer. $\endgroup$ – JEM_Mosig Mar 12 '18 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}}

$\endgroup$
  • $\begingroup$ Thanks for taking the time, I'll benchmark these tomorrow evening. $\endgroup$ – Three Diag Mar 11 '18 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}}
$\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}$$

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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