Can you make it to the end of the deck?

538_card_game.md

From the 538 riddler 8-19-18

Take a standard deck of cards, and pull out the numbered cards from one suit (the cards 2 through 10). Shuffle them, and then lay them face down in a row. Flip over the first card. Now guess whether the next card in the row is bigger or smaller. If you’re right, keep going. If you play this game optimally, what’s the probability that you can get to the end without making any mistakes? Extra credit: What if there were more cards — 2 through 20, or 2 through 100? How do your chances of getting to the end change?

R code is here. Starts with function to determine success in single 10 card trial (0 or 1), which comes out to ~ .17.

Use function to simulate repetitions of 10 card came, can be extended to many cards or repetitions. Probability of success rapidly drops to near zero with ~ 35 cards:

538_card_game.r

# packages for plotting
library(ggplot2)
library(ggthemes)

# function to play game, with default of 10 cards
# select card at random - guess next card based on percentage of remaining cards greater than your card
# if successful with all cards returns 1 else returns 0
guess_cards <- function(total = 10){
  guess = vector()
  cards = 2:total
  card = vector()
  result = vector()
  new_card = vector()
  for(i in 1:(total-2)){
    if(i > 1){
      new_card <- sample(cards,1,replace = F)
      result[i] <- ifelse((new_card > card & guess == "Higher") | (new_card < card & guess == "Lower"), "Correct","Incorrect")
      if(result[i] == 'Incorrect'){break}
      card <- new_card
      cards <- cards[cards!=card]
      guess <- ifelse(sum(card<cards)/length(cards) >= .5,"Higher","Lower")
    } else {
      card <- sample(cards,1,replace = F)
      cards <- cards[cards!=card]
      guess <- ifelse(sum(card<cards)/length(cards) >= .5,"Higher","Lower")
    }
  }
  return(ifelse("Incorrect" %in% result,0,1))
}

# simulate draws to get estimate of probability of success for 10 cards
# can change iterations for i - tends to stabilize ~ 100000
guess_accuracy = vector()
for(i in 1:100000){
  guess_accuracy[i] = guess_cards()
}
sum(guess_accuracy)/length(guess_accuracy)


# simulate draws to get estimate of probability of success for 10:100 cards
# can change max number of cards: probability approaches 0 long before 100
# can change iterations for j depending on accuracy/time trade-off
cards_number = 10:100
cards_result = vector()
for(i in seq_along(cards_number)){
  guess_accuracy = vector()
  for(j in 1:10000){
    guess_accuracy[j] = guess_cards(cards_number[i])
  }
  cards_result[i] = sum(guess_accuracy)/length(guess_accuracy)
}

# plot results, watch probability drop rapidly as more cards are added 
ggplot(data.frame(cards_number, cards_result), aes(cards_number, cards_result)) + 
  geom_line(lwd = 2.5, col = 'dodgerblue') + 
  #geom_point(col = 'red', size = 1.5) + 
  theme_fivethirtyeight() + 
  scale_color_fivethirtyeight() + 
  labs(title ="Probability of Success by Number of Cards")

gistlog.yml

published: true