Mathematica Asked by Pillsy on April 5, 2021
The Lotka-McKendrick model is a demographic model that represents the way a population changes over time due to fertility and mortality. For an age-specific population density $ u(a, t) $, and a total birth rate $ Lambda(t) $, the following equations should be satisfied:
$$begin{eqnarray}
frac{partial u}{partial a} + frac{partial u}{partial t} & = & -mu(a) u(a, t)
Lambda(t) & = & u(0, t) = int_{0}^{infty} da,u(a,t) f(a,t)
u(a, 0) & = & u_0(a)
end{eqnarray}$$
Here, $ mu(a) $ is an age-specific force of mortality, $ f(a) $ is an age-specific fertility rate, and $ u_0(a) $ is an initial condition.
If it weren’t for the integral in the boundary condition $ Lambda(T) = u(0, t) $, we’d be home free. In fact, DSolve
would suffice, using the standard technique of integrating along the characteristic lines of the first-order PDE:
lkPDE = {D[u[a, t], a] + D[u[a, t], t] == -[Mu][a]*u[a, t],
u[a, 0] == u0[a]};
DSolve[lkPDE, u[a, t], {a, t}]
(* {{u[a, t] ->
E^(Inactive[Integrate][-[Mu][K[1]], {K[1], 1, a}] - Inactive[Integrate][-[Mu][K[1]],
{K[1], 1, a - t}])*u0[a - t]}} *)
Sticking the integral in there makes everything fall apart.
lkIntegral =
u[0, t] == Integrate[u[x, t]*f[x], {x, 0, Infinity}];
DSolve[Flatten@{lkPDE, lkIntegral}, u[a, t], {a, t}]
(* returns unevaluated *)
You can write an analytic solution down, but as an alternative, I would like to use NDSolve
, especially as numerical methods will generalize to cases where the analytic solutions don’t exist or are too complicated to be useful.
Sadly, NDSolve
also chokes, even with appropriate concessions to reality. Let’s choose very simple parameters:
$$begin{eqnarray}
mu(a) & = & 1/80
f(a) & = & left{ begin{array}
& 1/10 & 20 le a < 45 0 & text{otherwise} end{array} right.
end{eqnarray}$$
Even so, we need a simpler integral condition because Integrate
isn’t quite smart to handle that piecewise function.
simpleLkIntegral =
u[0, t] == Integrate[u[x, t], {x, 20, 45}]/10
NDSolve[{
lkPDE /. [Mu][_] -> 1/80 /. u0[a_] :> 1/80,
simpleLkIntegral
},
u,
{a, 0, 100},
{t, 0, 100}]
(* returns unevaluated, with the an NDSolve::litarg message complaining about the integral *)
In order to appease NDSolve::litarg
, I try rewriting the integral with a
replacing x
as the variable of integration, which yields no joy:
simpleLkIntegral2 =
u[0, t] == Integrate[u[a, t], {a, 20, 45}]/10
NDSolve[{
lkPDE /. [Mu][_] -> 1/80 /. u0[a_] :> 1/80,
simpleLkIntegral2
},
u,
{a, 0, 100},
{t, 0, 100}]
(* returns unevaluated, with a
NDSolve::overdet: There are fewer dependent variables, {u[a,t]}, than equations, so the system is overdetermined.
*)
At this point, I feel like I’ve more or less run out of road, but was wondering if there was some way to force NDSolve
to do what I want.
UPDATE: I did try the model again with a different set of initial conditions, ones which allow for consistency between the boundary and initial conditions from $ t = 0 $ on, as shown below:
simpleLkInit = With[{m = 1/80},
u0[a_] :> Piecewise[{{c - m*a, 0 <= a <= c/m}}, 0]];
simpleLkNormalization = First@Solve[
{simpleLkIntegral2 /. t -> 0 /. u[a_, 0] :> u0[a] /. simpleLkInit,
c > 0}, c]
(* c -> 65/96 *)
Plugging this into NDSolve
gives the same issue with overdetermination (so presumably the consistency of the boundary condition is never even checked):
NDSolve[{lkPDE /. [Mu][_] -> 1/80 /. simpleLkInit /.
simpleLkNormalization, simpleLkIntegral2}, u, {a, 0, 100}, {t, 0,
100}]
(* Unevaluated, with NDSolve::overdet message *)
While the strategy of discretizing the system in age manually, as in
Chris K’s fine answer, is entirely viable, this essentially boils down to using the method of lines, which is the approach NDSolve
itself uses. I would like to see if NDSolve
itself can do the discretization, or at least if I can use it to drive move of the problem.
There is no unique solution for data provided by @Pillsy, since boundary and initial conditions are inconsistent. To show it we just use exact solution in a form:
[Mu][a_] := 1/80; u0[a_] := 1/80;
u[a_, t_] :=
E^(Inactive[Integrate][-[Mu][K[1]], {K[1], 1, a}] -
Inactive[Integrate][-[Mu][K[1]], {K[1], 1, a - t}])*u0[a - t]
u[0, t_] := Integrate[u[x, t], {x, 20, 45}]/25;
Now we can plot u[0,t]
as follows:
Plot[u[0, t], {t, 0, 100}]
So it is smooth function and we can make interpolation in a form
lst = Table[{t, u[0, t] // N}, {t, 0, 100, 1}];
ut = Interpolation[lst];
With ut
we can use NDSolve
directly
sol = NDSolveValue[{D[v[a, t], a] + D[v[a, t], t] == -[Mu][a]*
v[a, t], v[a, 0] == u0[a], v[0, t] == ut[t]},
v, {a, 0, 100}, {t, 0, 100}]
Here we got message NDSolveValue::ibcinc: Warning: boundary and initial conditions are inconsistent.
Nevertheless numerical solution can be plot and it looks like waved function
Plot3D[sol[a, t], {a, 0, 100}, {t, 0, 100}, Mesh -> None,
ColorFunction -> "Rainbow", AxesLabel -> Automatic]
To avoid the inconsistent of boundary and initial conditions we put in the beginning of the code
u[0, t_] := Integrate[u[x, t], {x, 20, 45}]/25;
Then we get smooth numerical solution
Now we can use method of line implemented by Chris K with some appropriate modifications
Clear[u];
imax = 200;
da = 1/2;
f[a_] := If[20 <= a < 45, 1/25, 0];
[Mu][a_] := 1/80;
u0[a_] := 1/80;
eqns = Join[{u[0]'[t] ==
da/2 Sum[(u[i + 1]'[t] f[(i + 1) da] + u[i]'[t] f[i da]), {i, 0,
imax - 1}]},
Table[u[i]'[
t] == -(u[i][t] - u[i - 1][t])/da - [Mu][i da] u[i][t], {i, 1,
imax}]];
ics = Table[u[i][0] == u0[i da], {i, 0, imax}];
unks = Table[u[i], {i, 0, imax}];
tmax = 100;
sol1 = NDSolve[{eqns, ics}, unks, {t, 0, tmax}][[1]];
We make visualization of numerical solution of the system of ODEs and see identical picture as we got for PDE
ListPlot3D[
Flatten[Table[{i da, t, Evaluate[u[i][t] /. sol1]}, {i, 0, imax}, {t,
0, tmax, 1}], 1], AxesLabel -> {"a", "t", "u"},
ColorFunction -> "Rainbow", PlotRange -> All, Mesh -> None]
And more detailed comparison also shows agreement of two solutions
Show[Plot[{sol[10, t]}, {t, 0, 100}],
ListPlot[Table[{t, u[20][t] /. sol1}, {t, 0, 100, 2}],
PlotStyle -> Red]]
One example of growing population with consistent boundary and initial conditions:
[Mu][a_] := 1/80; u0[a_] := Exp[-a/45];
f[a_] := Piecewise[{{1/10/1.2298542626633067, 20 <= x < 45}, {0,
True}}];
ue[a_, t_] :=
E^(Inactive[Integrate][-[Mu][K[1]], {K[1], 1, a}] -
Inactive[Integrate][-[Mu][K[1]], {K[1], 1, a - t}])*u0[a - t]
u1[t_] := NIntegrate[ue[x, t] f[x], {x, 0, 100}] // Quiet;
lst = Table[{t, u1[t]}, {t, 0, 100, 1}];
ut = Interpolation[lst];
sol = NDSolveValue[{D[v[a, t], a] + D[v[a, t], t] == -[Mu][a]*
v[a, t], v[a, 0] == u0[a], v[0, t] == ut[t]},
v, {a, 0, 100}, {t, 0, 100}]
Visualisation
Plot3D[sol[a, t], {a, 0, 100}, {t, 0, 100}, Mesh -> None,
ColorFunction -> "Rainbow", AxesLabel -> Automatic]
And same solution with method of lines:
imax = 500;
da = 100/imax;
f[a_] := If[20 <= a < 45, 1/10/1.2298542626633067, 0];
[Mu][a_] := 1/80;
u0[a_] := Exp[-a/45];
eqns = Join[{u[0]'[t] ==
da/2 Sum[(u[i + 1]'[t] f[(i + 1) da] + u[i]'[t] f[i da]), {i, 0,
imax - 1}]},
Table[u[i]'[
t] == -(u[i][t] - u[i - 1][t])/da - [Mu][i da] u[i][t], {i, 1,
imax}]];
ics = Table[u[i][0] == u0[i da], {i, 0, imax}];
unks = Table[u[i], {i, 0, imax}];
tmax = 100;
sol1 = NDSolve[{eqns, ics}, unks, {t, 0, tmax}][[1]];
Let compare two solution and find out that they have small discrepancies (due to large da
)
Table[Show[
Plot[{sol[i da, t]}, {t, 0, 100}, AxesLabel -> Automatic,
PlotLabel -> Row[{"a = ", i da}]],
ListPlot[Table[{t, u[i][t] /. sol1}, {t, 0, 100, 2}],
PlotStyle -> Red]], {i, 0, imax, 20}]
Last example provided by Pillsy shows divergence of two solutions found out with two methods even if initial data and boundary conditions are consistent. First method:
[Mu][a_] := 1/80; u0[a_] := If[0 <= a <= 325/6, 65/96 - a/80, 0];
f[a_] := Piecewise[{{1/10, 20 <= x < 45}, {0, True}}];
ue[a_, t_] :=
E^(Inactive[Integrate][-[Mu][K[1]], {K[1], 1, a}] -
Inactive[Integrate][-[Mu][K[1]], {K[1], 1, a - t}])*u0[a - t]
u1[t_] := NIntegrate[ue[x, t], {x, 20, 45}]/10 // Quiet;
lst = Table[{t, u1[t]}, {t, 0, 100, 1/4}];
ut = Interpolation[lst];
sol = NDSolveValue[{D[v[a, t], a] + D[v[a, t], t] == -[Mu][a]*
v[a, t], v[a, 0] == u0[a], v[0, t] == ut[t]},
v, {a, 0, 100}, {t, 0, 100}];
Second method:
imax = 500;
da = 100/imax;
f[a_] := If[20 <= a < 45, 1/10, 0];
[Mu][a_] := 1/80;
u0[a_] := If[0 <= a <= 325/6, 65/96 - a/80, 0];
eqns = Join[{u[0]'[t] ==
da/2 Sum[(u[i + 1]'[t] f[(i + 1) da] + u[i]'[t] f[i da]), {i, 0,
imax - 1}]},
Table[u[i]'[
t] == -(u[i][t] - u[i - 1][t])/da - [Mu][i da] u[i][t], {i, 1,
imax}]];
ics = Table[u[i][0] == u0[i da], {i, 0, imax}];
unks = Table[u[i], {i, 0, imax}];
tmax = 100;
sol1 = NDSolve[{eqns, ics}, unks, {t, 0, tmax},
Method -> {"EquationSimplification" -> "Residual"}][[1]];
Now we plot solutions together and see divergence
Table[Show[
Plot[{sol[i da, t]}, {t, 0, 100}, AxesLabel -> Automatic,
PlotLabel -> Row[{"a = ", i da}]],
ListPlot[Table[{t, u[i][t] /. sol1}, {t, 0, 100, 2}],
PlotStyle -> Red, PlotRange -> All]], {i, 0, imax, 20}]
Nevertheless, we can consider all tests above as verification of numerical method of lines for this problem. Now we make next step to develop code with known error of $h^4$, where $h$ is step size. For this we use function GaussianQuadratureWeights[]
to integrate with n-point Gaussian formula for quadrature, and function FiniteDifferenceDerivative
for approximation of derivative $frac {partial u}{partial x}$ with DifferenceOrder
of 4. First we call utilities:
Needs["DifferentialEquations`NDSolveProblems`"]
Needs["DifferentialEquations`NDSolveUtilities`"]
Get["NumericalDifferentialEquationAnalysis`"]
Second step, we define derivative matrix m
and integral vector int
:
np = 400; g = GaussianQuadratureWeights[np, 0, 100];
ugrid = g[[All, 1]]; weights = g[[All, 2]];
fd = NDSolve`FiniteDifferenceDerivative[Derivative[1], ugrid]; m =
fd["DifferentiationMatrix"]; vart =
Table[u[i][t], {i, Length[ugrid]}]; vart1 =
Table[u[i]'[t], {i, Length[ugrid]}]; ux = m.vart; var =
Table[u[i], {i, Length[ugrid]}];
f[a_] := If[20 <= a < 45, 1/10, 0]; int =
Table[f[ugrid[[i]]] weights[[i]], {i, np}];
[Mu][a_] := 1/80;
u0[a_] := If[0 <= a <= 325/6, 65/96 - a/80, 0];
Third step, we define the system of equations:
eqns = Join[{D[u[1][t], t] == int.vart1},
Table[D[u[i][t], t] == -ux[[i]] - [Mu][ugrid[[i]]] u[i][t], {i, 2,
Length[ugrid]}]];
ics = Table[u[i][0] == u0[ugrid[[i]]], {i, Length[ugrid]}];
Finally we solve system as
tmax = 100;
sol1 = NDSolve[{eqns, ics}, var, {t, 0, tmax},
Method -> {"EquationSimplification" -> "Residual"}];
With this code we made research to check how solution diverges with np
increasing:
{np, {u[1][100] /. sol1[[1]], u[np][100] /. sol1[[1]]}}
{100, {4.0455, 0.197089}}
{200, {3.791317314610565`, 0.19572819660924937`}};
{400, {3.6951293716506926`, 0.1949809561721866`}};
{800, {3.70082201902361`, 0.19456320959442788`}};
So numerical solution converges very fast with np
increasing, and for np=800
we have picture
lst1 = Flatten[
Table[{t, ugrid[[i]], u[i][t] /. sol1[[1]]}, {t, 0, 100, 2}, {i, 1,
Length[ugrid], 5}], 1];
ListPlot3D[lst1, Mesh -> None, ColorFunction -> Hue, PlotRange -> All,
AxesLabel -> {"t", "a"}]
We have run several tests with known exact solution and got a good agreement of the exact and numerical solution getting with the last code. Example 1 from Numerical methods for the Lotka–McKendrick’s equation (there are typos in this paper in equations (6.8),(6,9) I have corrected using Mathematica 12.1):
f[a_]:=2; [Mu][a_] := 1/(1 - a);
p0[x_] := If[x <= 1/2, (1 - 2 x)^3 (1 - x), 31 (2 x - 1)^3 (1 - x)];
u0[a_] := p0[a];
With this data we have to compute u[a,t]
on {a,0,1},{t,0,1}
and then compare exact solution $u(0,t)=B(t)$ with numerical solution:
B[t_] := If[t <= 1/2,
217 - 186 t - 372 t^2 - 248 t^3 - 216 E^t Cos[t] + 396 E^t Sin[t],
1/(Sqrt[E] (Cos[1/2]^2 + Sin[1/2]^2)) (-7 Sqrt[E] Cos[1/2]^2 +
6 Sqrt[E] t Cos[1/2]^2 + 12 Sqrt[E] t^2 Cos[1/2]^2 +
8 Sqrt[E] t^3 Cos[1/2]^2 - 216 E^(1/2 + t) Cos[1/2]^2 Cos[t] +
768 E^t Cos[t] Sin[1/2] - 7 Sqrt[E] Sin[1/2]^2 +
6 Sqrt[E] t Sin[1/2]^2 + 12 Sqrt[E] t^2 Sin[1/2]^2 +
8 Sqrt[E] t^3 Sin[1/2]^2 - 216 E^(1/2 + t) Cos[t] Sin[1/2]^2 -
768 E^t Cos[1/2] Sin[t] + 396 E^(1/2 + t) Cos[1/2]^2 Sin[t] +
396 E^(1/2 + t) Sin[1/2]^2 Sin[t])];
In Figure 10 shown numerical solution (left) and exact solution (right, blue line) with numerical solution (red points):
Finally we have to compare absolute error $|B(t)-u(0,t)|$ for code by Chris K and my code to find out accuracy of two code. For Chris code it is obvious that error is of h
and for my code theoretically it should be of $h^3$. But since we solve PDE it is not so perfect. In Figure 11 shown absolute error for Chris code (left) and for my code (right) for imax=np=800. It looks like my code has error of $h^{3/2}$ not $h^3$.
To improve the accuracy of my code we add point a=0
to the grid for differentiation matrix and finally have
Needs["DifferentialEquations`NDSolveProblems`"];
Needs["DifferentialEquations`NDSolveUtilities`"];
Get["NumericalDifferentialEquationAnalysis`"];
np = 40; g = GaussianQuadratureWeights[np, 0, 1];
ugrid = g[[All, 1]]; weights = g[[All, 2]]; grid = Join[{0}, ugrid];
fd = NDSolve`FiniteDifferenceDerivative[Derivative[1], grid]; m =
fd["DifferentiationMatrix"]; vart =
Table[u[i][t], {i, Length[grid]}]; varti =
Table[u[i]'[t], {i, 2, Length[grid]}]; vart1 =
Table[u[i]'[t], {i, Length[grid]}]; ux = m.vart; var =
Table[u[i], {i, Length[grid]}];
[Mu][a_] := 1/(1 - a);
p0[x_] := If[x <= 1/2, (1 - 2 x)^3 (1 - x), 31 (2 x - 1)^3 (1 - x)];
u0[a_] := p0[a];
f[a_] := 2; int = Table[f[ugrid[[i]]] weights[[i]], {i, np}]; eqns =
Join[{D[u[1][t], t] == int.varti},
Flatten[Table[
u[i]'[t] == -ux[[i]] - [Mu][grid[[i]]] u[i][t], {i, 2,
Length[grid]}]]];
ics = Table[u[i][0] == u0[grid[[i]]], {i, Length[grid]}];
tmax = 1;
{bb, mm} = CoefficientArrays[eqns, vart1];
rhs = -Inverse[mm].bb;
sol1 = NDSolve[{Table[vart1[[i]] == rhs[[i]], {i, Length[vart1]}],
ics}, var, {t, 0, tmax}];
With this code we calculate absolute error in Example 1 for np=40
(left picture) and np=80
(right picture). For this code error is of $h^{5/2}$.
Answered by Alex Trounev on April 5, 2021
I'm not an expert on age-structured populations (particularly this continuous-time model) and I know better numerical methods exist, but why not just discretize in age a
and solve the resulting large system of ODEs?
(NB: doublecheck the details of my discretization if you use this for anything serious; I wasn't too careful in how I put the da
's in!)
imax = 100;
da = 1.0;
f[a_] := If[20 <= a < 45, 1/10, 0];
μ[a_] := 1/80;
u0[a_] := If[a <= 10, 1/80, 0];
eqns = Join[
{u[0]'[t] == -μ[0] u[0][t] - u[0][t]/da + Sum[u[i][t] f[i da], {i, 0, imax}]},
Table[u[i]'[t] == -(u[i][t] - u[i - 1][t])/da - μ[i da] u[i][t], {i, 1, imax}]
];
ics = Table[u[i][0] == u0[i da], {i, 0, imax}];
unks = Table[u[i], {i, 0, imax}];
tmax = 160;
sol = NDSolve[{eqns, ics}, unks, {t, 0, tmax}][[1]];
frames = Table[
ListPlot[Table[{i da, u[i][t]}, {i, 0, imax}] /. sol,
PlotRange -> {0, 0.06}, PlotLabel -> t, AxesLabel -> {"a", "u"}]
, {t, 0, tmax}];
ListAnimate[frames]
I started with a step-function of u0[a]
to illustrate a few things:
da
) helps, and if you're only interested in the long-term behavior or smooth age-distributions, I think this isn't too bad. This is where more sophisticated numerical methods may help.Finally, an advantage of this approach is you can look at the eigenvalues and eigenvectors to get more info. Linearizing to make a matrix A
:
A = D[eqns /. ((_ == rhs_) -> rhs) /. (var_[t] -> var), {unks}];
{λ, v} = Eigensystem[A];
λ[[-3 ;; -1]]
(* {-0.0370978 + 0.184096 I, -0.0370978 - 0.184096 I, 0.0163063 + 0. I} *)
The last eigenvalue is the dominant, which gives the asymptotic growth rate to be 0.0163063 per year. The subdominant eigenvalues are complex; I think the imaginary part gives the approximate period of those baby boom echoes:
Abs[2 π/Im[λ[[-2]]]]
(* 34.1299 *)
Finally, the eigenvector associated with the dominant eigenvalue gives the stable age distribution:
ListPlot[Abs[v[[-1]]]]
EDIT:
Better yet, you can just convert this to a discrete-time, discrete-state Leslie matrix model. As long as the time step matches the size of the age classes, there is no spurious numerical diffusion.
Make the Leslie matrix:
L = SparseArray[
Join[
Table[{1, i + 1} -> f[i da] da, {i, 0, imax}],
Table[{i + 2, i + 1} -> 1 - μ[i da] da, {i, 0, imax - 1}]
], {imax + 1, imax + 1}
];
Project forward in time:
n = Table[If[i <= 11, 1/80, 0], {i, imax + 1}];
res = Join[{n}, Table[n = L.n, {t, 1, tmax}]];
frames = Table[
ListPlot[res[[t + 1]], PlotLabel -> t da, PlotRange -> {0, da 0.06}, AxesLabel -> {"a", "u"}]
, {t, 0, tmax/da}];
ListAnimate[frames]
Asymptotic growth rate checks out:
Log[Max[Re[Eigenvalues[A]]]]/da
(* 0.0162194 *)
EDIT 2:
I think you'll end up stuck with manual discretization in age, because the boundary condition is so weird compared to most typical PDEs. The discrete time-step in my matrix approach avoids numerical diffusion, which is important to maintain the shape if there are steps in the initial conditions (this should be a stringent test for any answer that tries to solve this problem).
The only thing I have left to offer is to force NDSolve
to solve the continuous-time system in the same way as the discrete-time version using Method->"ExplicitEuler"
and step size equal to the width of an age class. (note I had to tweak my discretization a little bit).
Here's a nice hi-resolution example:
imax = 1000;
da = 0.1;
f[a_] := If[20 <= a < 45, 1/10, 0];
μ[a_] := 1/80;
u0[a_] := If[a < 5, 0.1, 0];
eqns = Join[
{u[0]'[t] == -μ[0] u[0][t] - u[0][t]/da + Sum[u[i][t] f[i da], {i, 0, imax}]},
Table[u[i]'[t] == -(u[i][t] - u[i - 1][t])/da - μ[(i - 1) da] u[i - 1][t], {i, 1, imax}]
];
ics = Table[u[i][0] == u0[i da], {i, 0, imax}];
unks = Table[u[i], {i, 0, imax}];
tmax = 160;
sol = NDSolve[{eqns, ics}, unks, {t, 0, tmax},
Method -> "ExplicitEuler", StartingStepSize -> da][[1]];
frames = Table[
ListPlot[Table[{i da, u[i][t]}, {i, 0, imax}] /. sol,
PlotRange -> {0, 0.2}, PlotLabel -> t, AxesLabel -> {"a", "u"},
Joined -> True]
, {t, 0, tmax}];
ListAnimate[frames]
Answered by Chris K on April 5, 2021
To give some convincing publication to the round of answerers and the owner of the question: Numerical methods for the Lotka–McKendrick’s equation Galena Pelovska, Mimmo Iannelli∗ Dipartimento di Matematica, Universita degli Studi di Trento, via Sommarive 14, I-38050 Povo(Trento), Italy.
Answered by Steffen Jaeschke on April 5, 2021
Get help from others!
Recent Answers
Recent Questions
© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP