TheDinnerParty

Library

 library(magrittr)
library(ggplot2)

Helper functions

flipCoin<-function(n=NULL){
  toss<- sample(c("H","T"),1,prob =c(0.5,0.5))
  return(toss)
 }
 updateDinner<-function(dinner=NULL,host.id=NULL,pass.id=NULL){
    # the previous host is no longer host.
   dinner[host.id,'host']<-'NO'
   dinner[host.id,'touchedBox']<-'YES'
   
    dinner[pass.id,'host']<-'YES'
   dinner[pass.id,'touchedBox']<-'YES'
   return(dinner)
 }
 
 passBox<-function(dinner=NULL,verbose=FALSE){
   toss<-NULL
    toss<-flipCoin()
 if(toss=='H'){
   ## pass right host.id+1
   host.id<-dinner[which(dinner$host=='YES'),'seat']
      passesToward<-host.id+1
     ## if the host is the last position in the circle, and passes right, then the pass goes toward the first position.
      if(host.id==nrow(dinner)){
     passesToward<-1
      }
   dinner<-updateDinner(dinner,host.id=host.id,pass.id=passesToward)
  ##check for failure
  } ## Heads (right) 
 
 ## generate for left pass.
 if(toss=='T'){
   ## pass right host.id+1
   host.id<-dinner[which(dinner$host=='YES'),'seat']
      passesToward<-host.id-1
     ## if the host is the first position in the circle, and passes left, then the pass goes toward the last position.
      if(host.id==1){
     passesToward<-nrow(dinner)
      }
   dinner<-updateDinner(dinner,host.id=host.id,pass.id=passesToward)
  ##check for failure
  } ## T (left) 
    if(verbose){
    message(paste0(toss," ",host.id," passed to ",passesToward))
    }
 return(dinner)
 }
 
  checkTable<-function(dinner=NULL){
    if( dinner$touchedBox[which(dinner$selected.seat=='YES')]=='YES' & any(dinner$touchedBox[which(dinner$selected.seat=='NO')]=='NO') ){
    # failure
    runs<-'fail'
    }else{
      runs<-'continue'
    }
    return(runs)
 }
 

  runExperiment<-function(n=NULL,k=NULL,verbose=FALSE){
    # n is number of people attending party
    # k is a seat number 1:n.
    #by default seat number 1 is the host chair.
 dinner<-seq(1,n)
 dinner<-data.frame(seat=dinner,host="NO",touchedBox="NO",stringsAsFactors=FALSE)
 dinner[1,'host']<-'YES'
  dinner[1,'touchedBox']<-'YES'
  dinner$selected.seat<-'NO'
  dinner$selected.seat[k]<-'YES'
  success<-c()
  while( any(dinner$touchedBox=='NO')){
   dinner<-passBox(dinner,verbose=verbose)
   run<-checkTable(dinner)
    if(run=='fail'){
      success<-c(success,0)
      break
    }
  }
  if(is.null(success)){
  success<-c(success,1)
  }
  return(success)
  }

Simple/First-case analysis

 message("selecting position 2 with 4 people.")

## selecting position 2 with 4 people.

 x<- runExperiment(n=4,k=2,verbose=TRUE)

## T 1 passed to 4

## T 4 passed to 3

## T 3 passed to 2

 if(x==0){
   message("selecting position 2 failed")
 }else{
   message("selecting position 2 succeeded for 1 simulation")
 }

## selecting position 2 succeeded for 1 simulation

 message("selecting position 3 with 8 people.")

## selecting position 3 with 8 people.

 x<- runExperiment(n=8,k=3,verbose=TRUE)

## T 1 passed to 8

## T 8 passed to 7

## T 7 passed to 6

## T 6 passed to 5

## H 5 passed to 6

## T 6 passed to 5

## T 5 passed to 4

## T 4 passed to 3

   if(x==0){
   message("selecting position 3 failed")
 }else{
   message("selecting position 3 succeeded for 1 simulation")
 }

## selecting position 3 failed

The dinner party.

Sitting with 4 people at the table, we can compute the probabilities of being passed the box last. Here we have 10,000 simulations for each position at the table, and we average the indicator variable for success/failure to estimate the probability. This problem is a gambler’s ruin problem with equal probability, so we expect each position to have equal probability of winning the prize \((1/N-1)\).

Note that the probability of winning the prize with N people (excluding the host) is \(1/N-1\).

  ## simulate some tosses to check the probability
#table(sapply(seq(1:100000),function(x) flipCoin()))%>%prop.table
 p1<-sapply(1:10000,function(x) runExperiment(n=4,k=1))%>%mean
 p2<-sapply(1:10000,function(x) runExperiment(n=4,k=2))%>%mean
 p3<-sapply(1:10000,function(x) runExperiment(n=4,k=3))%>%mean
 p4<-sapply(1:10000,function(x) runExperiment(n=4,k=4))%>%mean
 
  results<-data.frame(probabilities=c(1/3,p1,p2,p3,p4),seatNumber=c("expected",1,2,3,4))
  ggplot(results,aes(x=factor(seatNumber),y=probabilities))+geom_bar(stat='identity')+geom_hline(yintercept=1/3,color='red',linetype='dashed')+xlab("Selected seat number")+ggtitle("Party with 4 people, (10,000 sims)")

Sitting with 6 people at the party.

Since the probability of the coin is p=1/2, the textbook showed that for Gambler’s ruin, with equal probability, the probability A wins starting with \(i\) dollars is \(i/N\),

in our case we are starting at the 1 position (the host holding the box) because the host is holding the box, and we have N-1 positions, so the probability for 6 people (excluding host) is \(1/5\).

 p6_2<-sapply(1:10000,function(x) runExperiment(n=6,k=2))%>%mean
 p6_3<-sapply(1:10000,function(x) runExperiment(n=6,k=3))%>%mean
 p6_4<-sapply(1:10000,function(x) runExperiment(n=6,k=4))%>%mean
 p6_5<-sapply(1:10000,function(x) runExperiment(n=6,k=5))%>%mean
 
  results<-data.frame(probabilities=c(1/5,p6_2,p6_3,p6_4,p6_5),seatNumber=c("expected",2,3,4,5))
  ggplot(results,aes(x=factor(seatNumber),y=probabilities))+geom_bar(stat='identity')+geom_hline(yintercept=1/5,color='red',linetype='dashed')+xlab("Selected seat number")+ggtitle("Party with 6 people, (10,000 sims)")

### Attending 8

Setting 8 people in a party, by symmetry we choose seats 2,3,4 and 5. The estimated probability is \(1/7\) and using 10,000 simulations we get close to that.

 p8_2<-sapply(1:10000,function(x) runExperiment(n=8,k=2))%>%mean
 p8_3<-sapply(1:10000,function(x) runExperiment(n=8,k=3))%>%mean
 p8_4<-sapply(1:10000,function(x) runExperiment(n=8,k=4))%>%mean
 p8_5<-sapply(1:10000,function(x) runExperiment(n=8,k=5))%>%mean
 
  results<-data.frame(probabilities=c(1/7,p8_2,p8_3,p8_4,p8_5),seatNumber=c("expected",2,3,4,5))
  ggplot(results,aes(x=factor(seatNumber),y=probabilities))+geom_bar(stat='identity')+geom_hline(yintercept=1/7,color='red',linetype='dashed')+xlab("Selected seat number")+ggtitle("Party with 8 people, 10,000 sims)")

Attending with 100 people

By symmetry we randomly sample 1 even seat numbers and 1 odd in a party with 100 attendance. The probability should be \(1/99\) for all positions. So without loss of generality, we sample 1 even and 1 odd positions and compute their probability.

  ## let's sample 2 even positions and 2 odd positions randomly.
  K<-sample(seq(2,100,2),1,replace=FALSE) 
  K<-c(K,sample(seq(3,99,2),1,replace=FALSE))
  
    p100<-sapply(K,function(k) sapply(1:10000,function(x) runExperiment(n=100,k=k))%>%mean)
  results<-data.frame(probabilities=c(1/99,p100),seatNumber=c("expected",K))
  ggplot(results,aes(x=factor(seatNumber),y=probabilities))+geom_bar(stat='identity')+geom_hline(yintercept=0.01,color='red',linetype='dashed')+xlab("Selected seat number")+ggtitle("Party with 100 people, (10,000 sims)")

Story Proof

So an equivalent (?) way of thinking of this problem is that for a given number of seats in a circle (N), we arrange them in a line.

Now for any chair the package arrives to an adjacent \(person_i\) at the i-1 or it can arrive at i+1 position. If the package is in the i-1 and passes to the ith position the game is over.

However if the package is in the i-1 position and passes around to the ith position (N-1) people then you win. Hence the box must travel to the i+1 position and toward the ith position, then you win.

In either case, this is the gambler’s ruin problem, where the package starts at the 1st position with the end point of N-1. If the position 1 moves to 0, (i-1 passing to i) the game is over. However if the 1 position delivers to N-1 people, then you win. This is equivalent to i-1 passing to the i+1 position. With equal probability the \(p_i=1/N-1\).