Randomly selecting and reinserting a subset of elements in a list

Question

This question is similar to my other question: How do I randomly select 'k' positions in a list and shuffle their respective elements without effecting the other elements?

Imagine first a pack of cards. We randomly draw $k$ cards from the pack, and then sequentially reinsert them 'somewhere' in the deck (between cards or above or below the deck). Now I'd like to do the same thing with list elements using some hypothetical function pluckReinsert:

 k = 3;
 list = {card1, card2, card3, card4, card5, card6, card7, card8, ..., cardN}
 pluckReinsert[list,k]

 output > {card2, card1, card3, card7, card4, card5, card42, card6, card8, ...}

Here, by chance, we randomly chose to "pluck" the set of cards: {card2, card7, card42}. We then, sequentially, placed card2 on top of card 1 (there were $N+1$ total choices given the $N$ cards in the deck), placed card7 between card3 and card4, and finally, placed card42 between card5 and card6. At any of these sequential addition steps, there are were $N+1$ choices for placing the card (i.e. there would be nothing to stop us from an ordering like: {card42, card2, card1, card3, card4, card5, card6, card8, ..., cardN, card7}).

Is there a clever Mathematica trick to do this in one or two lines?

Answer 1

Maybe longer than 1 or 2 lines but it is readable. Of course you could shorten it, but I tend to mess up the code when I try to make it too short. :-)

newStack[list_, k_] := 
      Module[{smallerStack, drawnCards, randomChoice, length},
      length = Length[list];
      randomChoice = RandomSample[Range[length], k];
      drawnCards = list[[randomChoice]] /. colorBefore -> colorAfter;
      smallerStack = Delete[list, Partition[randomChoice, 1]];
      Do[smallerStack = Insert[smallerStack, drawnCards[[i]],    RandomInteger[{1, Length[smallerStack]}]], {i, 1, Length[drawnCards]}];
      smallerStack
];

Works nicely:

NN = 10;
colorBefore = Green;
colorAfter = Orange;
stack = Table[Framed[IntegerString[i, 10, Ceiling[Log[10, NN]] + 1], Background -> colorBefore], {i, 1, NN}];
newStack[stack, 3]

gives e.g.

You can also use real symbols of cards as they are discussed here: Standard deck of 52 playing cards in curated data?

 coolCards = Flatten[ImagePartition[Import["http://www.milefoot.com/math/discrete/counting/images/cards.png"], {73, 98}], 1];

To show the effect on the cards I use the effect to invert the images object in the given list that were shuffled:

newStackImage[list_, k_] := Module[{smallerStack, drawnCards, randomChoice, length, full},
    length = Length[list];
    randomChoice = RandomSample[Range[length], k];
    drawnCards = ColorNegate[#] & /@ list[[randomChoice]];
    smallerStack = Delete[list, Partition[randomChoice, 1]];
    Do[smallerStack = 
     Insert[smallerStack, drawnCards[[i]], RandomInteger[{1, Length[smallerStack]+1}]], {i, 1, Length[drawnCards]}];
    smallerStack
];

When applying this function to the full set of cards

newStackImage[coolCards, 3]

we obtain:

Was it important to have it in 1 or 2 lines? :-) Its easy to compress the code but will be less readable

Of course it works with duplicate entries in the list as well.

Remark: an earlier Version of this answer included an answer how to take three cards that follow each other and put them alltogether back in some place of the remaining deck. You can find this answer in the edit history.

Answer 2

As with Mr.W, not totally clear on the question, but I think this does what you want:

pluckReinsert[list_, num_] := 
 Module[{picked, left}, 
  Fold[Insert[#, #2, RandomInteger[{1, Length@# + 1}]] &, 
   Sequence @@ 
    With[{picked = RandomSample[list, num]}, {left = 
       DeleteCases[list, _?(MemberQ[picked, #] &)], picked}]]]

An alternative (caveat - not gruelingly tested for correctness, just an idea, very fast):

motherPlucker[list_, n_] := 
 With[{o = RandomSample[Ordering[list], n]},
      Join[Extract[list, Transpose[{o}]], Delete[list, Transpose[{o}]]][[Ordering[
      Join[RandomInteger[{1, (Length@list) - n + 1}, n], Range@(Length@list - n)]]]]]

Answer 3

I'm not certain I understand the question so I'll post my code and you can tell me if this does what you expect:

pluck[cards_, n_] := {cards[[#]], Delete[cards, List /@ #]} & @ 
  RandomSample[Range @ Length @ cards, n]

place[{set_, cards_}] :=
  Fold[Insert[#, #2, 1 + RandomInteger @ Length @ #] &, cards, set]

Example:

Array[C, 10] ~pluck~ 3 // place

{C[1], C[2], C[3], C[7], C[9], C[4], C[5], C[10], C[6], C[8]}

---

Optimization

Looking at this problem again, and again inspired by an answer from rasher⁽¹⁾, I think an equivalent place operation can be done as follows:

place2[{set_, cards_}] :=
  Join[ConstantArray[0, Length @ cards], Range @ Length @ set] //
    Join[cards, set][[ Nest[Ordering, RandomSample @ #, 2] ]] &

On small lists this is only moderately faster, but on long lists it is much faster:

dat = pluck[Range[52], 52];

Do[place[dat], {50000}]  // Timing // First
Do[place2[dat], {50000}] // Timing // First

1.716

0.437

dat = pluck[Range[1*^6], 1*^4];

dat // place  // Timing // First
dat // place2 // Timing // First

13.416

0.0874

Answer 4

If you want to sequentially pluck and reinsert one card at a time so that there are always $N$ possible choices for the pluck operation and $N$ choices for the insert operation you can do the following:

list = {card1, card2, card3, card4, card5, card6, card7, card8};
pluckReinsert[list_, k_] := pluckReinsert[pluckReinsert[list, 1], k - 1];
pluckReinsert[list_, 1] := (Insert[Delete[list, #[[1]]], list[[#[[1]]]], #[[2]]])&[RandomInteger[{1, Length[list]}, 2]];

The two random integers I generate with RandomInteger[{1, Length[list]}, 2] are the position of the card to be plucked and the position at which it is to be reinserted respectively.

Answer 5

Not a one liner, but reasonably efficient.

pluckReinsert[ll_, k_] := Module[
  {n = Length[ll], ksamp, replace, partiall, i = 0, j = 0, 
   replacelist, res},
  ksamp = RandomSample[Range[n], k];
  replace = RandomSample[Range[n], k];
  replacelist = ConstantArray[False, n];
  Do[replacelist[[replace[[j]]]] = True, {j, k}];
  partiall = Delete[ll, Transpose[{ksamp}]];
  ksamp = ll[[ksamp]];
  Table[
   If[TrueQ[replacelist[[m]]], i++; ksamp[[i]], j++; partiall[[j]]]
   , {m, n}]
  ]

Example:

list = {card1, card2, card3, card4, card5, card6, card7, card8, cardN};
pluckReinsert[list, 4]

(* {card4, card1, card2, card3, card6, card5, card7, card8, cardN} *)

Big example:

ll = Range[10^6];
Timing[pluckReinsert[ll, 10^2];]

(* {3.664000, Null} *)

Here is a versionn using Compile that is around 30x faster.

pluckReinsertC = Compile[{{ll, _Integer, 1}, {k, _Integer}},
   Module[
    {n = Length[ll], ksamp, replace, partiall, i = 0, j = 0, 
     replacelist, res},
    ksamp = RandomSample[Range[n], k];
    replace = RandomSample[Range[n], k];
    replacelist = ConstantArray[0, n];
    Do[replacelist[[replace[[j]]]] = 1, {j, k}];
    partiall = Delete[ll, Transpose[{ksamp}]];
    ksamp = ll[[ksamp]];
    Table[
     If[replacelist[[m]] == 1, i++; ksamp[[i]], j++; partiall[[j]]]
     , {m, n}]
    ]];