The Mathematics of Marriage

Kurt Bryan and SIMIODE

Here is the data from Table 3.11 for the male 1940-44 cohort, percentage data rescaled to fractions:

men4044 = {{0, 21.1/100}, {5, 66.1/100}, {10, 83.1/100}, {15, 88.8/100}, {20, 91.2/100}, {25, 92.7/100}, {30, 94.0/100}}
n = Length[men4044]

A plot of the data

plt1 = ListPlot[men4044]

The function P(t) that might fit this data, according to the model, is

P0 = men4044[[1,2]]
P[t_] = P0/(P0+(1-P0)*Exp[-A*(b^t-1)/Log[b]])

Form a sum of squares to fit the data

SS[A_,b_] = Sum[(P[men4044[[j,1]]]-men4044[[j,2]])^2,{j,1,n}]

Now minimize in A and b. A contour plot of log(SS) may be helpful.

ContourPlot[Log[SS[A,b]],{A,0,1},{b,0,1},Contours->20]

Something near A = 0.6, b = 0.9 looks promising. We can set dSS/dA = 0 and dSS/db = 0 to find this point.

dSSdA = D[SS[A,b],A];
dSSdb = D[SS[A,b],b];
Absol = FindRoot[{dSSdA==0,dSSdb==0},{A,0.6},{b,0.9}]

Plot P(t) with these values, compare to the data

P2 = P[t]/.Absol
plt2=Plot[P2,{t,0,30},PlotStyle->{Red}];
Show[plt1,plt2]

Here is the data for the 1945-49 men

men4549 = {{0, 22.3/100}, {5, 65.5/100}, {10, 80.1/100}, {15, 86.1/100}, {20, 89.3/100}, {25, 91.3/100}, {30, 92.5/100}}

For the 1940-44 women:

women4044 = {{0, 48.1/100}, {5, 78.2/100}, {10, 86.8/100}, {15, 89.7/100}, {20, 91.4/100}, {25, 92.5/100}, {30, 93.2/100}}

For the 1945-49 women:

women4549 = {{0, 43.1/100}, {5, 76.9/100}, {10, 85.0/100}, {15, 88.4/100}, {20, 90.2/100}, {25, 91.5/100}, {30, 92.2/100}}