0

This question is a variation of this entry, but more complex in the way that the condition doesn't have to be met just once, but rather at every single step of the loop.

CONTEXT: I am trying to sample a vector:

balls = c(R = rep(1,2), G = rep(2,2), B = rep(3,2), W = rep(4,3), Y = 5, b = 6, O = 7)

in such a way that no color ("R", "G", "B", "W", "Y", "B", "O") with duplicate or triplicate number of balls (e.g. "R" or "W") ends up being aligned contiguously (no two balls of the same color side by side). This is meant to verify this post in MathSE.

So here is the pseudocode I would like to implement:

sam[1] = sample(balls, 1)

for (i in 2:length(balls)){
     remaining = balls[- which(balls = sam[i])]
     ifelse(x <- sample(remaining) != sam[i], sam[i + 1] = x, IFELSE ALL OVER AGAIN)
}
Community
  • 1
  • 1
Antoni Parellada
  • 4,253
  • 6
  • 49
  • 114
  • 1
    I'm not sure I completely understand your `ifelse` call there, but it sounds like you might be well served with a `while` loop. `while( condition ){ repeat until condition not met, then break out back to the for loop } – rosscova Jan 17 '17 at 03:46
  • In your `remaining =...` line, is your intention to subset only the balls not the same as `sam[i]`? That seems to make sense, but you'll need `==` there instead of `=`. In that case, your `ifelse` statement (or `while` loop) would be redundant, since *all* of the values being sampled should match the condition. – rosscova Jan 17 '17 at 04:00
  • @rosscova Sorry for my delay in answering. The first comment is on target. The idea behind `remaining` is to eliminate the balls already assigned to `sam` from the pool of choices in the next round. – Antoni Parellada Jan 17 '17 at 04:42

1 Answers1

1

I think this is what you're after, but please correct me if I'm on the wrong track.

balls = c(R = rep(1,2), G = rep(2,2), B = rep(3,2), W = rep(4,3), Y = 5, B = 6, O = 7)
sam <- vector()
sam[1] = sample(balls, 1)

for (i in 2:length(balls)){

    # withdraw last drawn ball only
    balls <- balls[ - which( balls == sam[i-1] )[1] ]

    # see which balls would be valid for the next draw
    remaining = balls[ balls != sam[i-1] ]

    # get the ball
    x <- sample( remaining, 1 )

    # put it in the result
    sam[ i ] <- x

}

This will "withdraw" each retrieved "ball" from the pool before drawing the next one. Note that you'll sometimes run out of appropriate balls to use toward the end, since the only ball you have left may match the last one you withdrew. So expect some NA values on some runs, but not all.

UPDATE: Possibly a better strategy for you is to sample the entire set at once, and see if the sample fits your condition. If not, resample until it does:

sam <- sample( balls )
sam.lag <- c( NA, sam[ 1:length( sam ) - 1 ] )

while( sum( sam == sam.lag, na.rm = TRUE ) > 0L ) {
    sam <- sample( balls )
    sam.lag <- c( NA, sam[ 1:length( sam ) - 1 ] )
}

So the loop will continue until no two "balls" consecutively match. Giving you a suitable vector in the end. I wouldn't recommend this for large datasets, since it's a "pot-luck" kind of solution, and is bound to get slow.

rosscova
  • 5,430
  • 1
  • 22
  • 35
  • @Toni Sorry, typo there, I've adjusted the code, can you try it now? – rosscova Jan 17 '17 at 13:25
  • OK, I see the problem. You don't need the condition or loop at all here. Do you want to be sampling from the same pool of balls each time, or reducing the pool after each iteration. In other words, should the "ball" be placed back in the "bag" before retrieving another one? – rosscova Jan 17 '17 at 13:35
  • You want to avoid consecutive same-color balls. So if you draw a red ball, and the next one happens to also be red, you have to place it back into the bag, and try again, until you draw a ball that is not red. So `2 4 3 4 4 2 1 5 6 3 1 7` with two `4` back to back is forbidden. Yet, `2 4 3 4 2 4 1 5 6 3 1 7` is OK. By the way, notice that I had `B` for `black` and `brown` - I have changed the second one (`brown`) to `b`. – Antoni Parellada Jan 17 '17 at 13:40
  • @Toni I think that's clearer to me now. Please see the answer, and also note the last paragraph. – rosscova Jan 17 '17 at 13:45
  • @Toni I've added a different method that might work better for you. – rosscova Jan 17 '17 at 14:02
  • NOTE TO SELF: `fun = function(){ sam <- sample( balls ) sam.lag <- c( NA, sam[ 1:length( sam ) - 1 ] ) while( sum( sam == sam.lag, na.rm = TRUE ) > 0L ) { sam <- sample( balls ) sam.lag <- c( NA, sam[ 1:length( sam ) - 1 ] ) } sam }` – Antoni Parellada Jan 17 '17 at 14:18