counting the number of winners in a coin flipping game

[swaheera]

• Suppose there is a game where 1000 people flip a fair coin.
• In round 1, everyone who had tails is eliminated.
• In round 2, the remaining people flip coins again, of the remaining people, everyone who had tails is out.
• This keeps going until everyone is out.

Here is my R simulation to represent this:

# pre game set up

num_players <- 1000
results <- data.frame(player = paste0("player", 1:num_players))
status <- rep("playing", num_players)
round <- 1

# simulation
while (any(status == "playing")) {
    
    coin_flips <- ifelse(runif(num_players) > 0.5, "heads", "tails")
   
    current_round <- ifelse(status == "playing", coin_flips, "eliminated")
    
 
    status <- ifelse(status == "playing" & coin_flips == "tails", "eliminated", status)
    
   
    results <- cbind(results, current_round)
    
    colnames(results)[ncol(results)] <- paste0("round_", round)
    
    round <- round + 1
}

The results look like this:

 > head(results)
   player round_1    round_2    round_3    round_4    round_5    round_6    round_7    round_8    round_9   round_10
1 player1   heads      heads      heads      heads      heads      heads      tails eliminated eliminated eliminated
2 player2   tails eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated
3 player3   tails eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated
4 player4   tails eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated
5 player5   tails eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated
6 player6   heads      tails eliminated eliminated eliminated eliminated eliminated eliminated eliminated eliminated

• I am trying to answer the following question: After the result of the simulation, can we see if this game had a unique winner? That is, was there a moment in which all other 999 players were eliminated but one player had still not been eliminated? (i.e. no ties)

• Suppose we repeat this simulation 1000 times. Can we plot the result of each simulation and see how many winners each simulation had? (e.g. game 1 had 3 winners, game 2 had 1 winner, game 3 had 4 winners, etc)

[vedoa]

Hi @swaheera ,

here is my suggestion

set.seed(1)

# pre game set up

num_players <- 1000
results <- data.frame(player = paste0("player", 1:num_players))
status <- rep("playing", num_players)
round <- 1

# how often to rerun
rerun <- 5

runSimulation <- function(){
  
  # simulation
  while (any(status == "playing")) {
    
    coin_flips <- ifelse(runif(num_players) > 0.5, "heads", "tails")
    
    current_round <- ifelse(status == "playing", coin_flips, "eliminated")
    
    
    status <- ifelse(status == "playing" & coin_flips == "tails", "eliminated", status)
    
    
    results <- cbind(results, current_round)
    
    colnames(results)[ncol(results)] <- paste0("round_", round)
    
    round <- round + 1
  }
  
  # wide to long 
  results2 <- reshape(data = results,
                     idvar= "player",
                     varying = list(which(!(names(results) %in% "player"))),
                     timevar = "round",
                     v.names = "result",
                     direction = "long")
  # frequencies
  tab <- as.data.frame.matrix(table(results2$round, results2$result))
  countWinners <- tab[length(tab$heads)-1, "heads"]
  checkUniqueWinner <- which(tab$eliminated == (num_players-1) & tab$heads == 1) 
  answerUniqueWinner <- ifelse(length(checkUniqueWinner) > 0, "yes", "no")
  
  return(list(resultWide = results,
              resultLong = results2,
              tab = tab,
              countWinners = countWinners ,
              checkUniqueWinner = checkUniqueWinner,
              answerUniqueWinner = answerUniqueWinner)
         )
}

final <- lapply(1:rerun, FUN = function(x){ runSimulation()})

# Question 1 
uniqueWinner <- data.frame(simulation = 1:rerun, onlyOne = unlist(lapply(final, function(x){x$answerUniqueWinner})))

# Question 2
winnersPerSimulation <- data.frame(simulation = 1:rerun, n = unlist(lapply(final, function(x){x$countWinners})))

plot(x = winnersPerSimulation$simulation, y = winnersPerSimulation$n)

The seed is just set for reproducibility at the begining.

Everything is done in base R (the wide to long can be done much easier with tidyr - also the plot would look nicer in ggplot2).

[swaheera]

@vedoa : thank you so much for your answer!

[prubin]

Here is another solution using only base R, with a bar plot to answer the second question.

#
# Simulate a coin flipping game.
#

# First, set the random seed, the player count and the number of times to run the experiment.
set.seed(123)
n_players <- 1000
n_replications <- 1000

# Create a data frame to hold the results.
results <- data.frame(Iteration = 1:n_replications, Rounds = NA, Winners = NA, Unique = NA)

# Create a function to play the game once.
# INPUT: none
# OUTPUT: a list of results: number of rounds to extinction, number of winners, indicator
#         that there was a unique winner(T) or not (F)
play <- function() {
  round <- 0           # number of round just completed
  alive <- n_players   # number of players alive
  while (alive > 0) {  # play until nobody is alive
    round <- round + 1 # update the round counter
    # Sample {0, 1} (1 being a head) once for each currently alive player and count the number of heads.
    a <- sample(0:1, size = alive, replace = TRUE, prob = c(0.5, 0.5)) |> sum()
    if (a == 0) {
      # If there are no survivors, we are done.
      # The number of winners is the number alive entering this round.
      return(list(Rounds = round, Winners = alive, Unique = (alive == 1)))
    } else {
      # Update the number of players alive and keep going.
      alive <- a
    }
  }
}

# Play the game the desired number of times.
for (i in 1:n_replications) {
  results[i, 2:4] <- play()
}

# Count the number of times there was a unique winner.
cat("Number of games with a unique winner = ", sum(results$Unique), ".\n")

# Plot the frequency of each number of winners.
barplot(height = table(results$Winners), xlab = "Winners", ylab = "Frequency")