The Birthday Problem -- Exact Probabilities

In a room with n people, find the probability that at least two have the same birthday.  Make a table to see which N produces a probabilty bigger than 1/2.  As described in class, the answer is easily found using the complementary event.

PNoCommonBirthday[n_]:= Product[(365-(i-1))/365,{i,1,n}]
PAtLeastOneCommonBirthday[n_] := 1- PNoCommonBirthday[n]

Here is a table of the results and a plot.  For n >=23, the probability exceeds 1/2 !

Table[{n,N[PAtLeastOneCommonBirthday[n]]},{n,1,60}]
ListPlot[%,Joined->True,AspectRatio->0.5]

The Birthday Problem -- Simulation

Lets compare with a simulation.  First generate the random birthdays.

ChooseBirthdays[npeople_] := Table[Random[Integer,{1,365}],{i,1,npeople}]

Here is a simulation with n = 30 people.  We can then Tally the results.  The second row the transpose gives the number of times the birthdays occured.  If there is a 2 or higher in the second row, some birthday was repeated.

ChooseBirthdays[30]
Transpose[Tally[%]]
Max[%[[2]]]

Now construct a Random Variable whose value is 1 if there is a common birthday and 0 if they are all distinct.  Using the ideas above we just need to see if the Max[ ] of the entries in the second row is at least 2.

RepeatedBirthday[npeople_] := Module[{bdays,max},
bdays =  ChooseBirthdays[npeople];
max  = Max[ Transpose[Tally[bdays]][[2]]];
If[max≥2,1,0]
]

Now we can simulate looking at a room of n people many times to see how often repeated birthdays occur.  Here we look at 100 simulations of n = 30 people.

Table[ RepeatedBirthday[30],{i,1,100}]

In the long run we expect the frequency of 1' s to be 0.706 ...  Here is a one-line program to calculate the frequency.

RepeatedBirthdayFrequency[npeople_, ntrials_] := N[Plus@@Table[ RepeatedBirthday[npeople],{i,1,ntrials}]/ntrials]

Here is the result of 10000 experiments.

RepeatedBirthdayFrequency[30,10000]

Triple Birthdays -- Simulation

We don’t know how to calculate the probability of triple birthdays for n people, but we can simulate it.  Just modify the above to look for the number max above to be at least 3.

TripleBirthday[npeople_] := Module[{bdays,max},
bdays =  ChooseBirthdays[npeople];
max  = Max[ Transpose[Tally[bdays]][[2]]];
If[max≥3,1,0]   (* just changed 2 to 3 here *)
]

TripleBirthdayFrequency[npeople_, ntrials_] := N[Plus@@Table[TripleBirthday[npeople],{i,1,ntrials}]/ntrials]

TripleBirthdayFrequency[30,10000]

We can even make a table of simulated frequencies for various number of people.  This takes a bit of time to compute.

Table[ {n,TripleBirthdayFrequency[n,10000]}, {n,1,100}]
ListPlot[%,Joined->True,AspectRatio->0.5]