Wheel Spin Strategy On The Price Is Right

3rd Player

• After first spin, if you aren’t winning, spin again.
  
• If you are tied after the first spin, spin again if you are less than .5 as your chances of not busting yet being over the previous player is better than .5 (which is the probability of winning on a spin off).
  
• If you are tied after the first spin, do not spin again if you are greater than .5 as your chances of busting are greater than .5 (which is the probability of winning on a spin off).

2nd Player

• After first spin, if you aren’t winning, spin again.
  
• If you are winning after the first spin, spin again if you are less than .5 - as the probability of the next player getting a higher spin than you is pretty high (1-current spin value).
  
• If you are winning after the first spin, don’t spin again if you are greater than .5 - as the probability of the next player getting a higher spin than you is less than .5 (1 - current spin value).

1st Player

This is a different story. While we could work out the math, it is a little more complicated. While I’ve never been afraid of a little math, I’d much rather simulate.

I’ll talk though my logic below and show my code. I do this so the reader can see my thought process and learn something or, more preferably, point out any flaws in logic or propose cleaner or more succinct ways of coding.

Simulate One Game

To support the simulation, I…

• …create a function that will create the result of a single showcase showdown. This function has an option for the first player to spin only once or twice.
  
• … summarize the results of the spins. We’ll determine the probability of player 1 winning whether they spin once or twice at each initial spin value.

I will place comments in code to explain what is happening.

library(tidyverse)

## Define function
wheel_iterations <- function(iteration = 1, num_spins = 1, spins = seq(.05,1,.05)){  

## Begin simulate player spin ##
player_1_first <- sample(spins, 1, replace = TRUE)
player_1_second <- sample(spins, 1, replace = TRUE)

player_2_first <- sample(spins, 1, replace = TRUE)
player_2_second <- sample(spins, 1, replace = TRUE)

player_3_first <- sample(spins, 1, replace = TRUE)
player_3_second <- sample(spins, 1, replace = TRUE)
## End simulate player spin ##

## Find result of player 1 if they spin once vs twice
if(num_spins == 2){
player_1 <- player_1_first + player_1_second
} else {
  player_1 <- player_1_first
}

## force player 1 to lose if they bust
player_1 <- if_else(player_1 > 1, 0, player_1)

## set player 2's logic for spinning again
if(player_2_first == player_1 & player_2_first < .5){ ## what happens if tied but spin below .5
  player_2 <- player_2_first + player_2_second
} else if(player_2_first == player_1 & player_2_first >= .5){ ## what happens if tied but spin above .5
  player_2 <- player_2_first
} else if(player_2_first > player_1) { ## what happens if 2 is higher than 1
  player_2 <- player_2_first
} else if(player_2_first < player_1) { ## what happens if 3 is less than 1
  player_2 <- player_2_first + player_2_second
} else {
  player_2 <- 10000  ## I put this here to catch spin 1 outcomes I missed
}

## Note: I only compare player 3's outcome to player 1 since this simulation is not concerned about the outcome between player 2 and 3 -- only if player 1 gets beat or not.

## set player 3's logic for spinning again
if(player_3_first == player_1 & player_3_first < .5){ ## what happens if tied but spin below .5
  player_3 <- player_3_first + player_3_second
} else if(player_3_first == player_1 & player_3_first >= .5){ ## what happens if tied but spin above .5
  player_3 <- player_3_first
} else if(player_3_first > player_1) { ## what happens if 3 is higher than 1
  player_3 <- player_3_first
} else if(player_3_first < player_1) { ## what happens if 3 is higher than 1
  player_3 <- player_3_first + player_3_second
} else {
  player_3 <- 10000 ## I put this here to catch spin 1 outcomes I missed
}

## accumulate output
output <-
  tibble(iteration, player_1, player_2, player_3, player_1_first, player_1_second, player_2_first, player_2_second, player_3_first, player_3_second, num_spins)

return(output)
}

I’ll display one iteration below.

options(tibble.width = Inf)
set.seed(42)
wheel_iterations(iteration = 1, num_spins = 1)

## # A tibble: 1 x 11
##   iteration player_1 player_2 player_3 player_1_first player_1_second
##       <dbl>    <dbl>    <dbl>    <dbl>          <dbl>           <dbl>
## 1         1     0.85     0.55      1.1           0.85            0.25
##   player_2_first player_2_second player_3_first player_3_second num_spins
##            <dbl>           <dbl>          <dbl>           <dbl>     <dbl>
## 1           0.05             0.5            0.2             0.9         1

You can see from this example, player 1 wins because player 2 and player 3 busted. Along with this we maintain the information about the value of each individual spin.

Simulate 200,000 Games

Next, I’ll simulation 100,000 iterations of player 1 spinning once and 100,000 iterations of player 1 spinning twice and bind the rows together. You can see how long it took my computer with 8 threads to complete this task.

library(furrr)
multiprocess(multiprocess)

tictoc::tic()
games <-
  1:100000 %>%
  furrr::future_map_dfr(~wheel_iterations(iteration = .x, num_spins = 1),.progress = TRUE) %>%
  bind_rows(
    1:100000 %>% furrr::future_map_dfr(~wheel_iterations(iteration = .x, num_spins = 2),.progress = TRUE)
  )
tictoc::toc()

## 530.36 sec elapsed

To give an example of the output, I show a sample of 5 outcomes of each number of selected spins. To keep the output clean, I’ll only display the player’s final scores and whether it was one vs two spins.

games %>% 
  group_by(num_spins) %>%
  slice_sample(n = 5) %>% 
  select(player_1,player_2,player_3,num_spins)

## # A tibble: 10 x 4
## # Groups:   num_spins [2]
##    player_1 player_2 player_3 num_spins
##       <dbl>    <dbl>    <dbl>     <dbl>
##  1     1        0.65     0.85         1
##  2     0.35     0.95     0.85         1
##  3     0.95     0.55     1.           1
##  4     0.1      1        0.9          1
##  5     0.55     0.85     0.25         1
##  6     0        0.9      0.65         2
##  7     0.95     1        0.85         2
##  8     1        1        0.8          2
##  9     0.35     0.5      1            2
## 10     0        0.3      0.2          2

Results

In this next step, I’ll prepare the data for visualization.

1. For every spin result, we’ll force all ‘busts’ down to 0 so they will automatically lose.
2. We’ll break all ties with a coin flip as we explained before the probability of winning a head to head battle is .5.
   
3. We’ll determine a winner.

plot_data <-
games %>%
  mutate(across(.cols = c(player_1,player_2,player_3),.fns = ~if_else(.>1,0,.))) %>% 
  ## force busts to zero
  mutate(rand_support = rbinom(n = n(),size = 1,prob = .5)) %>% 
  ## create random number to support breaking ties
  mutate(high_number = pmax(player_1,player_2,player_3)) %>%  
  ## find max score
  mutate(winner = as.integer(if_else(player_1 == high_number,1,0))) %>% 
  ## if high score is player 1 give win otherwise loss
  mutate(winner = if_else(winner == 1 & player_1 == player_2 | winner == 1 & player_1 == player_3, rand_support, winner)) %>% 
  ## If player one wins, yet they tied another player, flip a coin for a win
  group_by(player_1_first, num_spins) %>% 
  ## group together all player 1 first spin and 1 vs 2 total spin combinations
  summarise(win_if_percent = mean(winner), .groups = "drop_last")
  ## determine the percentage of wins for each group

Lets take a look.

plot_data %>% 
  pivot_wider(names_from = "num_spins", values_from = "win_if_percent") %>% 
  janitor::clean_names()

## # A tibble: 20 x 3
## # Groups:   player_1_first [20]
##    player_1_first       x1     x2
##             <dbl>    <dbl>  <dbl>
##  1           0.05 0        0.228 
##  2           0.1  0        0.159 
##  3           0.15 0.000400 0.212 
##  4           0.2  0.00159  0.208 
##  5           0.25 0.00351  0.203 
##  6           0.3  0.00671  0.206 
##  7           0.35 0.0158   0.160 
##  8           0.4  0.0229   0.191 
##  9           0.45 0.0350   0.199 
## 10           0.5  0.0644   0.195 
## 11           0.55 0.0852   0.193 
## 12           0.6  0.123    0.194 
## 13           0.65 0.175    0.143 
## 14           0.7  0.235    0.175 
## 15           0.75 0.305    0.156 
## 16           0.8  0.360    0.138 
## 17           0.85 0.478    0.110 
## 18           0.9  0.610    0.0383
## 19           0.95 0.738    0.0443
## 20           1    0.917    0

We can start to get a feel for the break point for when the first player should spin again.

Visualize

Lets look at it visually.

plot_data %>%
  ggplot(aes(x = player_1_first, y = win_if_percent, color = as.factor(num_spins))) +
  geom_line() +
  geom_point() +
  labs(x = "Value of First Spin", y = "Win Percentage of Spin Philosophy",
       title = "Probability of winning if you spin once (red) or twice (blue)",
       subtitle = "Given first spin value",
       color = "Number of Spins") +
  theme(legend.position = "bottom") +
  ylim(0,1) +
  scale_x_continuous(labels = scales::dollar_format(), breaks = seq(0,1,.1))

As you can see from the plot, the simulation shows that the first spin value at which you should hold vs spin again is .7. This is a rather surprising and unsettling realization. There is a little noise in the data and it appears it is about a wash at .65.

Taking a second look at this, we can reach the same conclusion via a heat map showing how the probability of winning on the big wheel balances out at about the .65 mark.

plot_data %>%
  ggplot(aes(x=player_1_first,y=as.factor(num_spins),fill = win_if_percent)) +
  geom_tile(color = "black") +
  labs(x = "Spin Value After 1st Spin", y = "Number of Spins",
       title = "The probility of winning if Player 1 spins once vs twice",
       subtitle = "Given first spin value",
       fill = "Probability of Winning") +
  theme(legend.position = "bottom", line = element_blank(),
        rect = element_blank(), axis.text.y = element_text(size = 20),
        axis.text.x = element_text(angle = 90, vjust = .5)) +
  scale_x_continuous(labels = scales::dollar_format(), breaks = seq(.05,1,.05)) +
  scale_fill_gradientn(limits = c(0,1), colors = c("blue", "red"))