3
$\begingroup$

I have a code that works for a single equation. How to I use NestList for two equation that are coupled? Below is the code for single equation,

 Remove[x, f];
 \[Lambda][r_] := Module[{f, l}, f[x_] := r x (1 - x);
 l[x_] = Log[Abs[D[f[x], x]]];
 Mean[l[NestList[f, 0.1, 1*^2]]]];
 Plot[\[Lambda][r], {r, 0, 4}, PlotStyle -> Thickness[.01], 
 AxesLabel -> {"r", "\[Lambda](r)"}]

The output is

enter image description here

My attempt for two coupled equation (note: that I used equations uncoupled for testing purpose, but it should work for coupled as well):

 Remove[x, y, f];
 \[Lambda][r_] := 
 Module[{f, l}, f[{x_, y_}] := {r x (1 - x), r y (1 - y)};
 l[{x_, y_}] = {Log[Abs[D[First[f[x, y]], x]]], 
 Log[Abs[D[Last[f[x, y]], y]]]};
 Mean[l[NestList[f, {0.1, 0.1},  1*^2]]]];
 ListPlot[Table[\[Lambda][r], {r, 0, 1}], 
 PlotStyle -> {Dashed, Thickness[.01]}, 
 AxesLabel -> {"r", "\[Lambda](r)"}]

I believe that my source of problem starts with the NestList and Mean.

addendum: My second attempt at the problem,

I almost answered my own question by modifying the code and avoiding Mean Function. However, numerical results are a bit weird.

 Remove[x, y, f, lya, \[Lambda], l, xinit, n, iterations, skip, ans1, \
 ans2, ff, ffp, dfp, lya2, xlist2, l2, ndrop2, xinit2, n2]

 iterations = 200;
 skip = 2;

 f[x_] := 4 \[Lambda] x (1 - x);

 lya[l_, xinit_, n_, ndrop_] := (\[Lambda] = l; 
 xlist = Drop[NestList[f, xinit, n],
 ndrop + 1]; Apply[Plus, Log[Abs[f'[xlist]]]]/Length[xlist])

 ans1 = lya[0.91, 0.7, iterations, skip]

 Plot[lya[\[Lambda], 0.7, iterations, skip], {\[Lambda], 0.5, 1.0}, 
  AxesOrigin -> {0.5, 0}, 
  AxesLabel -> {"\[Lambda]", 
  "\!\(\*SubscriptBox[\(\[Lambda]\), \(L\)]\)"}]
 

and the answer is,

 0.22816

Solution to the code with one function

Since I want to solve coupled logistic equations say

$x'= a y ( 1 - x)$

$y'= a x ( 1 - y)$

But to make it easier and to verify the correctness of the code I modify equation (uncouple them) to make it simpler,

$x'= a x ( 1 - x)$

$y'= a y ( 1 - y)$

And the above code is modified to handle two equations (list of equations) as follows,

 Remove[x, y, \[Lambda], ff, ffp, dfp, lya2, xlist2, l2, ndrop2, 
 xinit2, n2];

 ff[{x_, y_}] = 
 Evaluate[{4 \[Lambda] x (1 - x), 4 \[Lambda] y (1 - y)}];
 ffp[x_, y_] := 
 Evaluate[{4 \[Lambda] x (1 - x), 4 \[Lambda] y (1 - y)}];
 dfp[x_, y_] = Abs[Evaluate[Grad[ffp[x, y], {x, y}] . {1, 1}]];

 lya2[l2_, xinit2_, n2_, ndrop2_] := (\[Lambda] = l2; 
 xlist2 = Drop[NestList[ff, xinit2, n2],
 ndrop2 + 1];
 Apply[Plus, 
 Log[Transpose[
  Function[{x, y}, dfp[x, y]][Sequence @@ Transpose[xlist2]]]]]/
 Length[xlist2])

 ans2 = lya2[0.91, {0.7, 0.7}, iterations, skip]

 Plot[lya2[\[Lambda], {0.7, 0.7}, iterations, skip][[1]], {\[Lambda], 
 0.5, 1.0}, AxesOrigin -> {0.5, 0}, 
 AxesLabel -> {"\[Lambda]", 
 "\!\(\*SubscriptBox[\(\[Lambda]\), \(L\)]\)"}]

 Plot[lya2[\[Lambda], {0.7, 0.7}, iterations, skip][[2]], {\[Lambda], 
 0.5, 1.0}, AxesOrigin -> {0.5, 0}, 
 AxesLabel -> {"\[Lambda]", 
 "\!\(\*SubscriptBox[\(\[Lambda]\), \(L\)]\)"}]

 (*   compare answers  *)
 ans1 == ans1
 ans1 == ans2[[1]]  
 ans1 == ans2[[2]]

and the answer for the above code is

 {0.243622, 0.243622}

enter image description here

enter image description here

 True
 False
 False

For iterations=30 I get all True. False starts after 40 iterations. It is puzzling to me as to why it happens. Equations are identical. Perhaps, additional functions used in second code add error to it. Or perhaps my approach is not correct even though I am getting the same plots. But if you try iterations=5000 and skip=2000, the code for listed equations shows completely wrong plots.

Update 1:

Following suggestions by @Varnavides, it worked for this particular equation except for some other equation, see below:

 Clear[ff, dfp, lya, ff2, dfp2, lya2]

Remove[ff, dfp, lya, ff2, dfp2, lya2]

ff3[\[Lambda]_][{x_, y_}] = {4 \[Lambda] x, 4 \[Lambda] y (1 -  y)};

ff2[\[Lambda]_][{x_, y_}] = {4 \[Lambda] x (1 - x), 
4 \[Lambda] y (1 - y)};
dfp2[\[Lambda]_][{x_, y_}] = 
Abs[Grad[ff2[\[Lambda]][{x, y}], {x, y}] . {1, 1}];

lya2[\[Lambda]2_, xinit2_, n2_, ndrop2_] := 
Block[{xlist2}, 
xlist2 = Drop[NestList[ff2[\[Lambda]2], xinit2, n2], ndrop2 + 1];
Log[Transpose[dfp2[\[Lambda]2][Transpose[xlist2]]]] // Mean]

lya2[0.91, {0.7, 0.7}, 4, 1]

{-0.152808, -0.152808}

xlist2 = Drop[NestList[ff2[0.91], {0.7, 0.7}, 4], 2]

{{0.655537, 0.655537}, {0.821942, 0.821942}, {0.532727, 0.532727}}

xlist3 = Transpose[xlist2]

{{0.655537, 0.821942, 0.532727}, {0.655537, 0.821942, 0.532727}}

dfp2[0.91][Transpose[xlist2]]

{{1.13231, 2.34374, 0.238251}, {1.13231, 2.34374, 0.238251}}

Equation ff2 is is fine, but equation ff3 is not. It fails to Transpose. Using ff3, there is a missing curly brackets in output. Why curly brackets are vanishing?

$\endgroup$

1 Answer 1

4
$\begingroup$

Edit 01:

I suspect your issue arises from using global variables in your function definitions. Here's a simple re-write of your code, passing λ as a parameter and using Block to localize the xlist variable. The results seem to agree to large iteration numbers:

Clear[ff, dfp, lya, ff2, dfp2, lya2]
ff[λ_][x_] = 4 λ x (1 - x);
dfp[λ_][x_] = Abs[D[ff[λ][x], x]];

lya[λ_, xinit_, n_, ndrop_] := Block[{xlist},
  xlist = Drop[NestList[ff[λ], xinit, n], ndrop + 1];
  Log[dfp[λ][xlist]] // Mean]

ff2[λ_][{x_, y_}] = {4 λ x (1 - x), 
   4 λ y (1 - y)};
dfp2[λ_][{x_, y_}] = 
  Abs[Grad[ff2[λ][{x, y}], {x, y}] . {1, 1}];

lya2[λ2_, xinit2_, n2_, ndrop2_] := Block[{xlist2},
  xlist2 = Drop[NestList[ff2[λ2], xinit2, n2], ndrop2 + 1];
  Log[Transpose[dfp2[λ2][Transpose[xlist2]]]] // Mean]

lya[0.91, 0.7, 200, 2]
lya2[0.91, {0.7, 0.7}, 200, 2]

0.243622
{0.243622, 0.243622}

Original Post:

I'll use a canonical example of a coupled iterative equation to illustrate the concept, namely the De-jong attractor:

dejong[{x_, y_}] = With[{a = 1.6, b = 1.9, c = 0.3, d = 1.5}, 
{Sin[a y] - Cos[b x],Sin[c x] - Cos[d y]}]
NestList[dejong, {1., 1.}, 10^4] // Point // Graphics

enter image description here

The two things to note are:

  1. Make sure your function accepts the same form of arguments as it outputs, i.e. you would change your function from f[x_, y_]={..,..} to f[{x_, y_}]={..,..}
  2. The third argument of NestList is the number of iterations, so it expects a single integer value.

With these two changes your example above gets close to working, although if I understand correctly you'd want to express l[{x_,y_}]={..,..} symbolically and simply Nest over that. Note that currently your example above passes the entire list output to l. This works for your single equation case as Log and Abs are Listable and thread over their arguments.

$\endgroup$
8
  • $\begingroup$ Thanks for suggestion. But I still run into problems. This time Function Mean. I updated my attempted code with your ideas. $\endgroup$
    – Aschoolar
    Jul 7, 2021 at 14:54
  • 1
    $\begingroup$ It's not clear to me what you're trying to achieve. Perhaps editing your question using some math formulas could help? Currently your single equation formulation is doing the following (e.g. for r=0.1) : iterating f_{n+1} = 0.1*f_n*(1-f_n) for 100 iterations; taking the log of the absolute value of the symbolic derivative of each of these l_n = Log[Abs[0.1*(1-f_n)-0.1*f_n]] and then taking the mean of those 100 values. Is this really what you meant to do? Or were you trying to do something like l_{n+1}=Log[Abs[0.1*(1-l_n)-0.1*l_n]] and iterate that for 100 iterations? $\endgroup$ Jul 7, 2021 at 15:14
  • 1
    $\begingroup$ Please edit your question to give an example (using equations) of two coupled iterative equations you'd like to solve. The way it's currently set up, you can do something like this \[Lambda][r_] := Module[{f, l}, f[{x_, y_}] := {r x (1 - x), r y (1 - y)}; l[{x_, y_}] = { Log[Abs[D[First[f[{x, y}]], x]]], Log[Abs[D[Last[f[{x, y}]], y]]] }; Mean[Transpose[l[Transpose[NestList[f, {0.1, 0.1}, 1*^2]]]]]] but it doesn't seem like what you want to do.. Again, note that the Transposes are needed since the entire list output of NestList gets passed to l $\endgroup$ Jul 7, 2021 at 20:18
  • 1
    $\begingroup$ Either editing your post, or answering yourself are appropriate. If you still have unanswered questions you'd like help with, editing will likely be most useful to you. $\endgroup$ Jul 7, 2021 at 22:52
  • 1
    $\begingroup$ I added extra code and my second solution attempt. Almost there. A new problem pops up which is numerical. $\endgroup$
    – Aschoolar
    Jul 7, 2021 at 23:19

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.