Performance Issue When Using Manipulate

Question

Any help would be appreciated!

I've been attempting to manipulate the graphics for time t. We need to have Di set to 11.2, however when it is set to any value greater than .1, we see a great deal of slowdown. Is there anyway to increase performance so that we don't see any slowdown? Adjusting Di affects the "vibration" between the two disks.

Clear[qzero];
Clear[Pthzero];
Clear[\[Lambda]];
Clear[Di];

sol = ParametricNDSolve[{q'[t] == Pq[t], 
theta'[t] == Ptheta[t]/q[t]^2, 
Pq'[t] == 
 Ptheta[t]^2/q[t]^3 - 
  2 Di \[Lambda] (1 -  Exp[-\[Lambda] (q[t] - 1)]) Exp[-\[Lambda] (q[t] - 1)], 
Ptheta'[t] == 0, q[0] == qzero, theta[0] == 0, Pq[0] == 0, 
Ptheta[0] == Pthzero}, {Pq, q, theta, Ptheta}, {t, 0, 500}, {PqO, 
thzero, qzero, Pthzero, \[Lambda], Di}];

m1 = 12*(1.99*10^-26);
radius1 = 70;
m2 = 16*(1.99*10^-26);
radius2 = 60;
re = 112.8;
Di = 10;

Manipulate[
  Graphics[{White, 
   Rectangle[{-300, -300}, {300, 300}], {Darker[Red], 
    Disk[{(m2/(m1 + m2))*re*
     Evaluate[q[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol]*
     Cos[Evaluate[
     theta[0, 0, qzero, Pthzero, 2.7965, Di][t] /. 
     sol]], (m2/(m1 + m2))*re*
   Evaluate[q[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol]*
   Sin[Evaluate[
     theta[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol]]}, 
 radius1]}, {Darker[Green], 
Disk[{(m1/(m1 + m2))*re*
   Evaluate[q[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol]*
   Cos[Evaluate[
      theta[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol] + 
     Pi], (m1/(m1 + m2))*re*
   Evaluate[q[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol]*
   Sin[Evaluate[
      theta[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol] + Pi]}, 
 radius2]}}], {qzero, .5, 
  2}, {Pthzero, -.0445633841, .0445633841}, {t, 0, 500}]

Answer 1

A number of things can be done to improve the responsiveness of Manipulate here. First, do not compute the same quantity more than once; see q1 and theta1. Second, set ContinuousAction -> False, so that calculations are not performed until a Slider stops moving. (See ContinuousAction documentation.) Finally, increase the speed of ParametricNDSolve itself by eliminating Ptheta as a variable, because it is a constant according to Ptheta'[t] == 0 in your code. In total, the revised code becomes:

Clear[Di];
sol = ParametricNDSolve[{q'[t] == Pq[t], theta'[t] == Pthzero/q[t]^2, 
  Pq'[t] == Pthzero^2/q[t]^3 - 2 Di λ (1 - Exp[-λ (q[t] - 1)]) Exp[-λ (q[t] - 1)], 
  q[0] == qzero, theta[0] == 0, Pq[0] == 0}, {Pq, q, theta}, {t, 0, 500}, 
  {PqO, thzero, qzero, Pthzero, λ, Di}];
m1 = 12*(1.99*10^-26); radius1 = 70; m2 = 16*(1.99*10^-26); radius2 = 60;
  re = 112.8; Di = 10;
Manipulate[ q1 = re*Evaluate[q[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol[[2]]];
  theta1 = Evaluate[theta[0, 0, qzero, Pthzero, 2.7965, Di][t] /. sol[[3]]]; 
  Graphics[{White, Rectangle[{-300, -300}, {300, 300}],
    {Darker[Red], Disk[{(m2/(m1 + m2))*q1*Cos[theta1], 
      (m2/(m1 + m2))*q1*Sin[theta1]}, radius1]}, 
    {Darker[Green], Disk[{(m1/(m1 + m2))*q1*Cos[theta1 + Pi], 
      (m1/(m1 + m2)) q1*Sin[theta1 + Pi]}, radius2]}}],
  {qzero, .5, 2}, {Pthzero, -.0445633841, .0445633841}, {t, 0, 500}, 
  ContinuousAction -> False]

There may be other ways to speed things up, but this seems like a good start.

Updated to replace SynchronousUpdating by ContinuousAction, prompted by comment by Kuba.

Answer 2

Here's my take. First, I'd use NDSolve because having the separate ParametericFunction solutions seems like the ODE has to be solved for each variable (am I wrong?). In any case, NDSolve seems simple enough since most of the parameters are Manipulate variables. Next, I'd separate the solution of the ODE from drawing the graphics by means of an extra Dynamic. This gives great responsiveness when the t slider is moved. It is still slow when the parameters qzero and Pthzero are changed. (See below for further improvements.)

Manipulate[
 With[{sol = With[{λ = 2.7965}, 
     First@NDSolve[{
        q'[$t] == Pq[$t], 
        theta'[$t] == Pthzero/q[$t]^2, 
        Pq'[$t] == Pthzero^2/q[$t]^3 - 
          2 Di λ (1 - Exp[-λ (q[$t] - 1)]) Exp[-λ (q[$t] - 1)], 
        q[0] == qzero, theta[0] == 0, Pq[0] == 0},
      {q, theta}, {$t, 0, t}]]},
  Graphics[
   Dynamic[     (* only graphics will be updated when t changes *)
    {White, Rectangle[{-300, -300}, {300, 300}],
     {Darker[Red], 
       Disk[{(m2/(m1 + m2))*re*q[t]*Cos[theta[t]],
             (m2/(m1 + m2))*re*q[t]*Sin[theta[t]]}, radius1]},
     {Darker[Green], 
       Disk[{(m1/(m1 + m2))*re*q[t]*Cos[theta[t] + Pi],
             (m1/(m1 + m2))*re*q[t]*Sin[theta[t] + Pi]}, radius2]}} /. sol],
   Frame -> True]
  ],
 {{qzero, 0.5}, 0.5, 2}, {Pthzero, -.0445633841, .0445633841}, {t, 0, 500}]

---

One drawback with ContinuousAction -> False is that you cannot monitor what is going on while the parameters change. Here are some ideas for addressing this. For large values of qzero and t, there is no real solution to small delays, as far as I can find. The delays would be acceptable to me, but I believe that is what the OP is asking to be addressed.

One way to speed things up is to make some parameters change with ControlActive. For instance, we can integrate the ODE only up to t while the slider is moving. (Clicking on the slider will evaluate the previous solution at the new value of t, so when the slider is released we need to calculate the solution to the end 500.)

We can speed up NDSolve by reducing PrecisionGoal and AccuracyGoal, but the computed solutions in the cases where the increase in speed in noticeable are rather inaccurate. To get a good speed up they need to be reduced to less than half the default (~8). With such a setting, when the slider is released and the settings restored to Automatic, the disks jump a little, so you are still not able to track the behavior very accurately.

Example call of NDSolve.

NDSolve[<ODE above>, {q, theta},
 {$t, 0, ControlActive[t, 500]}, 
 PrecisionGoal -> ControlActive[3, Automatic], 
 AccuracyGoal -> ControlActive[2, Automatic]]

---

Finally, I've occasionally encounter underflow and overflow errors at high values of the parameters. Perhaps integrating out to 500 is unnecessary, at least in a Manipulate. Here is an example of q[t] just out to t == 50 (Pthzero = 0.0023999999999999994`, qzero = 1.552):

Plot[q[t] /. sol, {t, 0, 50}]