1

I have two coupled differential equations as follows:

$$S'(t) = - \frac{a}{1 + B(t)} S(t),$$

$$B'(t) = \frac{c}{1 + S(t)} B(t) (1 - B(t)) - d B^2(t) \Big( \frac{1 - B(t)}{B(t)} \Big)^n,$$

where $a$, $c$, $d$, and $n$ are constants to be determined from the data. And the datasets are:

Sdata = {{0, 9.74},{3, 4.92},{6, 8.29},{9, 5.54},{15, 2.08},{18, 1.38},{21, 1.99},{24, 0.893}};

Bdata = {{0, 0.915094},{3, 0.736097},{6, 0.793694},{9, 0.833664},{15, 1},{18, 0.99578},{21, 0.897964},{24, 0.214499}};

We fit the differential equations to the datasets and obtain:

Clear[fitness]
fitness[a00_?NumberQ, c00_?NumberQ, d00_?NumberQ, n00_?NumberQ, s0_?NumberQ, b0_?NumberQ] := 
Module[{ss, bb, parms, odes, ODES, solode, cinits, ssbb, lambda = 4.75, t}, 
odes = {ss'[t] + a00/(1 + bb[t]) ss[t] == 0, bb'[t] - c00  bb[t] (1 - bb[t])/(1 + ss[t]) + d00 bb[t]^2 ((1 - bb[t])/bb[t])^n00 == 0};
cinits = {ss[0] == s0, bb[0] == b0};
ODES = Join[odes, cinits];
solode = Quiet@NDSolve[ODES, {ss, bb}, {t, tk[[1]], tk[[8]]}][[1]];
Return[
Sum[Norm[{y1[[k]], lambda y2[[k]]} - 
Evaluate[{ss[t], lambda bb[t]} /. solode /. {t -> tk[[k]]}]], {k, 1, 8}]]]

tk = {0, 3, 6, 9, 15, 18, 21, 24}; y1 = {9.74, 4.92, 8.29, 5.54, 2.08, 1.38, 1.99, 0.893}; y2 = {0.915094, 0.736097, 0.793694, 0.833664, 1, 0.99578, 0.897964, 0.214499};

restrs = {0 < a00 < 0.9 && 0 < c00 < 0.9 && 0.1 < d00 < 0.8 && 1.15 < n00 < 1.2 && 8. < s0 < 10 && 0.01 < b0 < 0.99999999}; vars = {a00, c00, d00, n00, s0, b0};

sol = Quiet@ FindMinimum[ Join[{fitness[a00, c00, d00, n00, s0, b0]}, restrs], {{a00, 0.13}, {c00, 0.13}, {d00, 0.24}, {n00, 0.25}, {s0, 9}, {b0, 1}}, StepMonitor :> Print[{a00, c00, d00, n00, s0, b0, fitness[a00, c00, d00, n00, s0, b0]}], MaxIterations -> 10, WorkingPrecision -> 30]

odes = {ss'[t] + a00/(1 + bb[t]) ss[t] == 0, bb'[t] - c00 bb[t] (1 - bb[t])/(1 + ss[t]) + d00 bb[t]^2 ((1 - bb[t])/bb[t])^n00 == 0} /. sol[[2]]; cinits = {ss[0] == s0, bb[0] == b0} /. sol[[2]]; ODES = Join[odes, cinits]; solode = NDSolve[ODES, {ss, bb}, {t, tk[[1]], tk[[8]]}][[1]];

gr0 = Plot[Evaluate[ss[t] /. solode], {t, tk[[1]], tk[[8]]}]; gr10 = ListPlot[Transpose[{tk, y1}], PlotStyle -> Red, PlotLabel -> "S(t)"]; gr2 = ListPlot[Transpose[{tk, y2}], PlotStyle -> Blue]; Show[gr10, gr0]

gr00 = Plot[Evaluate[bb[t] /. solode], {t, tk[[1]], tk[[8]]}]; gr02 = ListPlot[Transpose[{tk, y2}], PlotStyle -> Blue, PlotLabel -> "B(t)"]; Show[gr02, gr00]

enter image description here

I'm much more interested to capture the behavior of $B(t)$ more accurately. The behavior of $B$ data (blue points) is: First it decreases, to have a minimum at $t = 3$, then increases and has a maximum at $t = 15$, and then suddenly it falls. The fitted curve is more or less flat till $t = 15$. It seems to me that coupled two-components first-order differential equations cannot capture the behavior of $B$ data, and one needs either higher derivatives or more components (at least three). However, I don't have any other information about my system to be included in the ODE's. I searched around a little and found the concept of impulsive differential equations with one example here with the associated answer here, which it seems it can be used also in my case. The main idea is to put Dirac deltas and force jumps in the solutions of differential equations, which for my case it means around $t = 3$ and $t = 15$.

To this end, we plug in -DiracDelta[t - 3] + DiracDelta[t - 15] in the right hand side of the differential equation for $B(t)$, two places in the above code, to do fitting again. However, Mathematica runs forever on my PC (4 GB RAM). I'd appreciate it if anyone could see if they can produce results on their PC.

EDIT 1

As Ulrich Neumann suggested in the comments, we approximate Dirac delta as dirac = Function[{t, eps}, Exp[-(t^2/(2 eps))]/Sqrt[2 Pi eps]], and plug in the term: -u3 dirac[t - 3, .1] + u15 dirac[t - 15, .1], with two new parameters $u_3$ and $u_{15}$, in the right-hand side of the differential equation for $B(t)$, thus we have:

Clear[fitness]

Sdata = {{0, 9.74}, {3, 4.92}, {6, 8.29}, {9, 5.54}, {15, 2.08},{18, 1.38}, {21, 1.99}, {24, 0.893}}; Bdata = {{0, 0.915094}, {3, 0.736097}, {6, 0.793694}, {9, 0.833664}, {15, 1}, {18, 0.99578}, {21, 0.897964}, {24, 0.214499}};

dirac = Function[{t, eps}, Exp[-(t^2/(2 eps))]/Sqrt[2 Pi eps]];

fitness[a00_?NumberQ, c00_?NumberQ, d00_?NumberQ, n00_?NumberQ, s0_?NumberQ, b0_?NumberQ, u3_?NumberQ, u15_?NumberQ] := Module[{ss, bb, parms, odes, ODES, solode, cinits, ssbb,lambda = 4.75, t}, odes = {ss'[t] + a00/(1 + bb[t]) ss[t] == 0, bb'[t] - c00 bb[t] (1 - bb[t])/(1 + ss[t]) + d00 bb[t]^2 ((1 - bb[t])/bb[t])^n00 == -u3 dirac[t - 3, .1] + u15 dirac[t - 15, .1]}; cinits = {ss[0] == s0, bb[0] == b0}; ODES = Join[odes, cinits]; solode = Quiet@NDSolve[ODES, {ss, bb}, {t, tk[[1]], tk[[8]]}][[1]]; Return[ Sum[Norm[{y1[[k]], lambda y2[[k]]} - Evaluate[{ss[t], lambda bb[t]} /. solode /. {t -> tk[[k]]}]], {k, 1, 8}]]]

tk = {0, 3, 6, 9, 15, 18, 21, 24}; y1 = {9.74, 4.92, 8.29, 5.54, 2.08, 1.38, 1.99, 0.893}; y2 = {0.915094, 0.736097, 0.793694, 0.833664, 1, 0.99578, 0.897964, 0.214499};

restrs = {0 < a00 < 0.9 && 0 < c00 < 0.9 && 0.1 < d00 < 0.8 && 1.15 < n00 < 1.2 && 8. < s0 < 10 && 0.01 < b0 < 0.99999999 && 0.1 < u3 < 0.15 && 0.2 < u15 < 0.3}; vars = {a00, c00, d00, n00, s0, b0, u3, u15};

sol = Quiet@FindMinimum[Join[{fitness[a00, c00, d00, n00, s0, b0, u3, u15]},restrs], {{a00, 0.13}, {c00, 0.13}, {d00, 0.24}, {n00, 0.25}, {s0, 9}, {b0, 1}, {u3, 0.1}, {u15, 0.1}}, StepMonitor :> Print[{a00, c00, d00, n00, s0, b0, u3, u15, fitness[a00, c00, d00, n00, s0, b0, u3, u15]}], MaxIterations -> 10, WorkingPrecision -> 30]

odes = {ss'[t] + a00/(1 + bb[t]) ss[t] == 0, bb'[t] - c00 bb[t] (1 - bb[t])/(1 + ss[t]) + d00 bb[t]^2 ((1 - bb[t])/bb[t])^n00 == -u3 dirac[t - 3, .1] + u15 dirac[t - 15, .1]} /. sol[[2]]; cinits = {ss[0] == s0, bb[0] == b0} /. sol[[2]]; ODES = Join[odes, cinits]; solode = NDSolve[ODES, {ss, bb}, {t, tk[[1]], tk[[8]]}][[1]];

gr0 = Plot[Evaluate[ss[t] /. solode], {t, tk[[1]], tk[[8]]}]; gr10 = ListPlot[Transpose[{tk, y1}], PlotStyle -> Red, PlotLabel -> "S(t)"]; gr2 = ListPlot[Transpose[{tk, y2}], PlotStyle -> Blue]; Show[gr10, gr0]

gr00 = Plot[Evaluate[bb[t] /. solode], {t, tk[[1]], tk[[8]]}]; gr02 = ListPlot[Transpose[{tk, y2}], PlotStyle -> Blue, PlotLabel -> "B(t)"]; Show[gr02, gr00]

enter image description here

So, it seems Dirac delta is not the best approach for modeling impulsive differential equations.

Any idea for forcing impulses is really appreciated!

EDIT 2

With only one Dirac delta at $t = 3$, the fitting is a little better, but still cannot capture the behavior of the data the end:

Clear[fitness]

Sdata = {{0, 9.74}, {3, 4.92}, {6, 8.29}, {9, 5.54}, {15, 2.08},{18, 1.38}, {21, 1.99}, {24, 0.893}}; Bdata = {{0, 0.915094}, {3, 0.736097}, {6, 0.793694}, {9, 0.833664}, {15, 1}, {18, 0.99578}, {21, 0.897964}, {24, 0.214499}};

dirac = Function[{t, eps}, Exp[-(t^2/(2 eps))]/Sqrt[2 Pi eps]];

fitness[a00_?NumberQ, c00_?NumberQ, d00_?NumberQ, n00_?NumberQ, s0_?NumberQ, b0_?NumberQ, u3_?NumberQ, u15_?NumberQ] := Module[{ss, bb, parms, odes, ODES, solode, cinits, ssbb, lambda = 4.75, t}, odes = {ss'[t] + a00/(1 + bb[t]) ss[t] == 0, bb'[t] - c00 bb[t] (1 - bb[t])/(1 + ss[t]) - d00 bb[t]^2 ((1 - bb[t])/bb[t])^n00 == -u3 dirac[t - 3, .5]}; cinits = {ss[0] == s0, bb[0] == b0}; ODES = Join[odes, cinits]; solode = Quiet@NDSolve[ODES, {ss, bb}, {t, tk[[1]], tk[[8]]}][[1]]; Return[Sum[Norm[{y1[[k]], lambda y2[[k]]} - Evaluate[{ss[t], lambda bb[t]} /. solode /. {t -> tk[[k]]}]], {k, 1, 8}]]]

tk = {0, 3, 6, 9, 15, 18, 21, 24}; y1 = {9.74, 4.92, 8.29, 5.54, 2.08, 1.38, 1.99, 0.893}; y2 = {0.915094, 0.736097, 0.793694, 0.833664, 1, 0.99578, 0.897964, 0.214499};

restrs = {0 < a00 < 0.9 && 0 < c00 < 0.9 && 0.1 < d00 < 0.8 && 1.15 < n00 < 1.2 && 8. < s0 < 10 && 0.01 < b0 < 0.99999999 && 0.1 < u3 < 0.15 && 0.2 < u15 < 0.3}; vars = {a00, c00, d00, n00, s0, b0, u3, u15};

sol = Quiet@FindMinimum[ Join[{fitness[a00, c00, d00, n00, s0, b0, u3, u15]}, restrs], {{a00, 0.13}, {c00, 0.13}, {d00, 0.24}, {n00, 0.25}, {s0, 9}, {b0, 1}, {u3, 0.1}, {u15, 0.1}}, StepMonitor :> Print[{a00, c00, d00, n00, s0, b0, u3, u15, fitness[a00, c00, d00, n00, s0, b0, u3, u15]}], MaxIterations -> 10, WorkingPrecision -> 30]

odes = {ss'[t] + a00/(1 + bb[t]) ss[t] == 0, bb'[t] - c00 bb[t] (1 - bb[t])/(1 + ss[t]) - d00 bb[t]^2 ((1 - bb[t])/bb[t])^n00 == -u3 dirac[t - 3, .5]} /. sol[[2]]; cinits = {ss[0] == s0, bb[0] == b0} /. sol[[2]]; ODES = Join[odes, cinits]; solode = NDSolve[ODES, {ss, bb}, {t, tk[[1]], tk[[8]]}][[1]];

gr0 = Plot[Evaluate[ss[t] /. solode], {t, tk[[1]], tk[[8]]}]; gr10 = ListPlot[Transpose[{tk, y1}], PlotStyle -> Red, PlotLabel -> "S(t)"]; gr2 = ListPlot[Transpose[{tk, y2}], PlotStyle -> Blue]; Show[gr10, gr0]

gr00 = Plot[Evaluate[bb[t] /. solode], {t, tk[[1]], tk[[8]]}]; gr02 = ListPlot[Transpose[{tk, y2}], PlotStyle -> Blue, PlotLabel -> "B(t)"]; Show[gr02, gr00]

enter image description here

  • 1
    NDSolve is a numerical function which can't handle the exact DiracDelta. Try an approximation for example dirac = Function {[x, eps}, Exp[-(x^2/(2 eps))]/Sqrt[2 Pi eps]] (small eps) – Ulrich Neumann Nov 27 '23 at 18:23
  • 3
    Have a look at the use of WhenEvent in NDSolve, because I think it could be used to solve your problem. – Stephen Luttrell Nov 27 '23 at 20:31
  • Comments have been moved to chat; please do not continue the discussion here. Before posting a comment below this one, please review the purposes of comments. Comments that do not request clarification or suggest improvements usually belong as an answer, on [meta], or in [chat]. Comments continuing discussion may be removed. – Kuba Nov 28 '23 at 16:33
  • @UlrichNeumann To be precise, NDSolve handles DiracDelta to some degree. You remember this?: https://mathematica.stackexchange.com/a/236224/1871 :) – xzczd Dec 01 '23 at 01:11

0 Answers0