Birthday Problem

Author

Eric W. Weisstein
October 11, 2008

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Statistics/BirthdayProblem.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/BirthdayProblem.html.

©2008 Wolfram Research, Inc. except for portions noted otherwise

Code

P[k_,n_,d_]:=1-Sum[Q[i,n,d],{i,k-1}]
Q[1,n_,d_]:=((d!)/((d-n)!(d^n)))
Q[k_,n_,d_]:=Module[{i,j},
Sum[((n!d!)/((d^(i k))i!(((k!))^i)(n-i k)!(d-i)!))Sum[Q[j,n-k i,d-i]((((d-i))^(n-i k))/(d^(n-i k))),{j,k-1}],{i,Floor[n/k]}]
]

(Subscript[P, 2])

P[2,n,d]

Probability of 2 out of 23 people sharing a birthday = 50%

P[2,23,365]

N[%]

BirthdayCrowdSizeList:={23,88,187,313,460,623,798,985,1181,1385,1596,1813}

BirthdayCrowdSize[i_]:=BirthdayCrowdSizeList[[i]] /; i<=Length[BirthdayCrowdSizeList]

BirthdayPlot[n_,max_]:=Module[{i,m,b},
		b=BirthdayCrowdSizeList;
		Show[
			Table[
				ListPlot[Table[P[i,m,365],{m,max}],
						PlotJoined->True,DisplayFunction->Identity],
				{i,2,n}
		],
		DisplayFunction->$DisplayFunction,
		Epilog->{Dashing[{.02,.02}],Line[{{0,.5},{max,.5}}],
		Table[Line[{{b[[i-1]],0},{b[[i-1]],P[i,b[[i-1]],365]}}],
				{i,2,n}]}]
]

BirthdayPlot[3,200]

P

(Subscript[P, 2])

P[2,n,d]

(Subscript[P, 3])

FullSimplify[P[3,n,d],(n|d)∈Integers&&d>0]

(Subscript[P, 4])

P[4,n,d]

(Subscript[Q, 2])

(Subscript[Q, 2 ])From Recurrence

V5

FullSimplify[Q[2,n,d],
(d|n)∈Integers&&d>0&&n>0
]//TraditionalForm

With[{d=365},Table[(d^(-n)) ((2^(-(n/2))) n! GegenbauerC[n,-d,(1/(Sqrt[2]))]-((d!)/(Gamma[d-n+1]))),{n,10}]]

(only correct for even n)

V7

Q[2,n,d]

TraditionalForm[%]

With[{d=365},Table[(((d^(-n)) d! (-1+Hypergeometric2F1[-(n/2),(1/2)-(n/2),1+d-n,2]))/((d-n)!)),{n,10}]]

(Subscript[Q, 2 ])From Sum

V5

FullSimplify[((n!)/(d^n))Sum[(1/(2^i))Binomial[d,i]Binomial[d-i,n-2i],{i,Floor[n/2]}],
(d|n)∈Integers&&d>0&&n>0
]//TraditionalForm

V7

((n!)/(d^n))Sum[(1/(2^i))Binomial[d,i]Binomial[d-i,n-2i],{i,Floor[n/2]}]

FullSimplify[%,n∈Integers]

(Subscript[Q, 3])

V5

FullSimplify[Q[3,n,d]]

FullSimplify[Sum[Q[j,n-3i,d-i](d-i)^(n-3i)/d^(n-3i),{j,2}],
(d|n|i)∈Integers&&d>0&&n>0&&i>0]//TraditionalForm

V7

Q[3,n,d]

FullSimplify[%,(n|d)∈Integers]

Probabilities

Table[P[2,i,365]//N,{i,20,25}]

Table[P[3,i,365]//N,{i,86,90}]

Table[P[4,i,365]//N,{i,180,190}]

BirthdayCrowdSize[2,.5,365]

a=BirthdayP[2,23,365]

{a,a//N}

Number needed for various probabilities that two or more share a birthday

Plot[P[2,n,365],{n,1,365}]

LogLogPlot[P[2,n,365],{n,1,365}]//Quiet

50%

FindRoot[P[2,n,365]==1/2,{n,3,20},WorkingPrecision->20]

90%

FindRoot[P[2,n,365]==9/10,{n,3,20},WorkingPrecision->20]

95%

FindRoot[P[2,n,365]==95/100,{n,3,20},WorkingPrecision->20]

99%

FindRoot[P[2,n,365]==99/100,{n,3,20},WorkingPrecision->20]