# random choice of multiple lists but delete element chosen

I want to make a function which takes lists as an input and outputs one element out of one of the list with uniform probability (if for example we have 2 lists, one with 7 and one with 3 elements, each element should have chance 1/10 to be picked) and removes that element from the list it was chosen from. This should work for 1,2 or 4 lists. I wouldn't mind creating 3 different functions for this. For 2 lists this would work:

randChoice[a_, b_] :=
Module[{ran = RandomInteger[{1, Length[a] + Length[b]}], pos, ret},
If[ran <= Length[a], ret = a[[ran]]; a = Delete[a, ran],
pos = ran - Length[a]; ret = b[[pos]]; b = Delete[b, pos]];
Return[ret];
];
SetAttributes[randChoice, HoldAll]


Example input:

a = {1, 2, 3, 4};
b = {1, 2, 3};
randChoice[a, b]
a
b


Is there a neater way to do this? It should be as fast as possible of course and should work for empty lists as well (though at least one list isn't empty).

ClearAll[deleteRandom]
SetAttributes[deleteRandom, HoldAll]

deleteRandom[a : {__}] := Module[
{pos = RandomChoice@Position[a, _, {2}, Heads -> False]},
a = Delete[a, pos];
pos]


Examples:

{a, b, c} = {{1, 2, 3, 4}, {1, 2, 3}, {x, y, z, w}};

deleteRandom[{a, b, c}]

{1, 1}

{a, b, c}

{{2, 3, 4}, {1, 2, 3}, {x, y, z, w}}

deleteRandom[{a, b, c}]

 {3, 2}

{a, b, c}

{{2, 3, 4}, {1, 2, 3}, {x, z, w}}

{a, b, c, d, e} = {{1, 2, 3, 4}, {}, {1, 2, 3}, {}, {x, y, z, w}};
tot = Total[Length /@ {a, b, c, d, e}];

SeedRandom[1]
Grid[Prepend[{"", a, b, c, d, e}][{#, ## & @@ #2} & @@@
Table[{deleteRandom[{a, b, c, d, e}], {a, b, c, d, e}}, tot]],
Dividers -> {{False, Red}, {False, Red}}]


Update: A variation that returns the deleted element:

ClearAll[deleteRandom2]
SetAttributes[deleteRandom2, HoldAll]

deleteRandom2[a : {__}] := Module[{b = a,
pos = RandomChoice@Position[a, _, {2}, Heads -> False]},
a = Delete[a, pos];
b[[## & @@ pos]]]


Examples:

{a, b, c, d, e} = {{a1, a2, a3, a4}, {}, {c1, c2, c3}, {}, {e1, e2, e3, e4}};
tot = Total[Length /@ {a, b, c, d, e}];

SeedRandom[1]
Grid[Prepend[{"", a, b, c, d, e}][{#, ## & @@ #2} & @@@
Table[{deleteRandom2[{a, b, c, d, e}], {a, b, c, d, e}}, tot]],
Dividers -> {{False, Red}, {False, Red}}]


• I don't really understand the code yet, but it works perfectly and is fast! I want to return the value of the removed element, not the position. I tried deleteRandom[a : {__}] := Module[{pos = RandomChoice@Position[a, _, {2}, Heads -> False], ret}, ret = a[[Sequence @@ pos]]; a = Delete[a, pos]; ret] but this is a bit slower. Is it possible to do this a little faster? Maybe as fast as if one returns the position? Commented Dec 3, 2021 at 17:10
• @PeterMüller, please see the update.
– kglr
Commented Dec 3, 2021 at 17:34
• WOW!!! Thanks a lot!!! This is super fast :) Perfect!!! Thanks!!! I now even believe to understand the code! Really can't thank you enough! Commented Dec 3, 2021 at 17:45

I think this should work

ClearAll @ randChoice;
randChoice[lists__] := Module[
{
choice = RandomChoice[
(*make a table of all the list positions*)
Flatten[
{n, Length @ {lists}}
],
1
]
],
res
},
res = Extract[{lists}, choice];
{lists} = ReplacePart[{lists}, choice -> Nothing];
res
];
SetAttributes[randChoice, HoldAll]


You can pass in any number of lists:

a = {1, 2, 3, 4};
b = {1, 2, 3};
c = {"x", "y", "z"};

randChoice[a, b, c]
{a, b, c}
(* "x" *)
(* {{1, 2, 3, 4}, {1, 2, 3}, {"y", "z"}} *)

randChoice[a, b, c]
{a, b, c}
(* 1 *)
(* {{1, 2, 3, 4}, {2, 3}, {"y", "z"}} *)

randChoice[a, b, c]
{a, b, c}
(* "y" *)
(* {{1, 2, 3, 4}, {2, 3}, {"z"}} *)