3
$\begingroup$

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?

$\endgroup$
  • 1
    $\begingroup$ I have 12 lines. That's a 1 and a 2.. $\endgroup$ – Daniel Lichtblau Apr 15 '14 at 15:01
  • $\begingroup$ Yes. In fact, I'm pretty sure with the undocumented Developer``DemiCompile it can be done in half a line. $\endgroup$ – ciao Apr 15 '14 at 17:47
5
$\begingroup$

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.

enter image description here

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:

enter image description here

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.

$\endgroup$
  • $\begingroup$ I don't think this is addressing the problem as originally posed. In particular neither the selected elements, nor the insertion positions, need be contiguous. $\endgroup$ – Daniel Lichtblau Apr 15 '14 at 18:31
  • $\begingroup$ Yes you are right. I will work it out. $\endgroup$ – Philipp Apr 15 '14 at 18:38
  • 1
    $\begingroup$ nit picking i think you need to add 1 to the random range or you'll never insert at the end $\endgroup$ – george2079 Apr 16 '14 at 3:23
2
$\begingroup$

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)]]]]]
$\endgroup$
  • $\begingroup$ This is essentially what I did, except that mine allows for duplicates to exist in the deck at the beginning, whereas DeleteCases will fail there. $\endgroup$ – Mr.Wizard Apr 15 '14 at 21:59
  • 3
    $\begingroup$ If there's duplicates in the deck, someone's gettin' the short end of mah pistol ;-) $\endgroup$ – ciao Apr 15 '14 at 22:05
  • $\begingroup$ LOL -------------- $\endgroup$ – Mr.Wizard Apr 15 '14 at 22:05
  • $\begingroup$ Note: consider using DeleteCases[list, Alternatives @@ picked] -- your code as written with _?(MemberQ[picked, #] &) is very slow. e.g. pluck[Range@50000, 3000] // place takes 0.09 seconds here, while pluckReinsert[Range@50000, 3000] takes 7.1 seconds. This change brings it down to 1.7 seconds, and it's probably faster in later versions. $\endgroup$ – Mr.Wizard Apr 15 '14 at 22:09
  • $\begingroup$ @Mr.Wizard: You seriously crack me up (in a good way) - I don't write everything with performance in mind (unlike some, hint hint), unless OP implies that's important, I often just vomit out ideas. I figure some kind of take/join/induced ordering (like the multi-insert you did) would be fastest for this by far. $\endgroup$ – ciao Apr 15 '14 at 22:13
2
$\begingroup$

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(1), 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
$\endgroup$
  • $\begingroup$ So it looks like the first line randomly samples three elements from the list (i.e. cards from the deck) and then deletes these elements in the list (removes these cards in the deck). The second line then places these elements (cards), sequentially into the list at the list' front / back / or between any elements (cards). Is this a correct interpretation for your code? If so, that's what I was looking for! $\endgroup$ – S22 Apr 15 '14 at 22:24
  • $\begingroup$ This generally allows for and retains duplicate elements in the list (cards in the deck) right? It isn't totally necessary, but its nice that this is general. $\endgroup$ – S22 Apr 15 '14 at 22:26
  • $\begingroup$ @S22 Yes, and yes. If your "deck" is not long this code is probably all you need. If you are dealing with very long lists (hundreds of thousands of elements) it will become slow because every Insert takes time proportional to the length of the list into which it is inserting. (See this related Q&A). rasher seems to have a way around this but I haven't examined it yet. $\endgroup$ – Mr.Wizard Apr 16 '14 at 0:55
  • $\begingroup$ @S22 Actually rasher's second method does not appear to have equivalent probability to this algorithm. $\endgroup$ – Mr.Wizard Apr 16 '14 at 1:13
  • $\begingroup$ I think your algorithm works well for my purposes, and is quite nice. However, if it's ok, I'm going to wait a little bit to accept since I'm actually learning a huge amount from the postings here! $\endgroup$ – S22 Apr 16 '14 at 16:55
1
$\begingroup$

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.

$\endgroup$
1
$\begingroup$

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}]
    ]];
$\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.