7
$\begingroup$

I'm happy with the result of the graph I made, but it runs very slowly. How can I make it lighter and faster?

f[x_] = c;
g[x_] = -3 x^3 + 2 x;
sol[c_] := Solve[{g[x] == c, 0 < x < Sqrt[2/3]}, x];
Manipulate[
 Show[Plot[{c, g[x]}, {x, 0, Sqrt[2/3]}, 
   PlotRange -> {{-0.1, 
      Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}}, 
   PlotStyle -> {Red, Blue}, 
   PlotLegends -> {"f(x)=c", 
     "g(x)=-3\!\(\*SuperscriptBox[\(x\), \(3\)]\)+2x"}, 
   Epilog -> {{Blue, PointSize@Large, 
      Text[Style["A", Black], {-0.02 + x /. sol[c][[1]], c + 0.02}], 
      Point[{x /. sol[c][[1]], c}]}, {Red, PointSize@Large, 
      Text[Style["B", Black], {0.02 + x /. sol[c][[2]], c + 0.02}], 
      Point[{x /. sol[c][[2]], c}]}}], 
  Plot[{c, g[x]}, {x, 0, x /. sol[c][[1]]}, 
   PlotRange -> {{-0.1, 
      Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}}, 
   PlotStyle -> {Red, Blue}, Filling -> {1 -> {{2}, {Blue}}}], 
  Plot[{c, g[x]}, {x, x /. sol[c][[1]], x /. sol[c][[2]]}, 
   PlotRange -> {{-0.1, 
      Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}}, 
   PlotStyle -> {Red, Blue}, Filling -> {1 -> {{2}, {Red}}}]], {{c, 
   4/9 + 0.001, "c="}, 0, (4 Sqrt[2])/9, Appearance -> "Open"}, 
 Button["Reset", c = 4/9 + 0.001]]

Blue and Red areas are equal

$\endgroup$
2
  • 1
    $\begingroup$ Try adding ContinuousAction -> False, TrackedSymbols :> {c} at the end and see if this helps. ContinuousAction -> False tells it not to evaluate until you release the mouse which speeds it up, $\endgroup$
    – Nasser
    Aug 27, 2023 at 9:10
  • 1
    $\begingroup$ Welcome to Mathematica StackExchange! Instead of solving the equation each time you change $c$, you can solve it once beforehand (because it has a closed-form solution): sol = Solve[g[x] == c, x, Reals]. Afterwards, use this result and filter out the solution that is inside your desired range ($0<x<\sqrt{2/3}$). $\endgroup$
    – Domen
    Aug 27, 2023 at 9:13

5 Answers 5

9
$\begingroup$

You can use a single Plot function and add the required annotations using the options MeshFunctions, Mesh and MeshStyle as follows:

First, option combination MeshFunctions -> {g[#] &} and Mesh -> {{c}} identifies the solutions to g[x] == c without the need for Solve and subsequent replacements.

Next, we use an undocumented feature that allows using functions as the option setting for MeshStyle to add desired styling and labels to mesh points:

meshStyle = {AbsolutePointSize[10], 
    ReplaceAll[Point[{a_, b_}] :> 
     {Blue, Point @ a, Text["A", a, {1, -2}], 
      Red, Point @ b, Text["B", b, {-1, -2}]}] @ #} &;

Then, just add the option MeshStyle -> meshStyle to Plot to get desired annotations:

Manipulate[
 Plot[{c, g[x]}, {x, 0, Sqrt[2/3]}, 
  PlotRange -> {{-0.1, Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}},
  PlotStyle -> {Red, Blue}, 
  PlotLegends -> {"f(x)=c", 
    "g(x)=-3\!\(\*SuperscriptBox[\(x\), \(3\)]\)+2x"}, 
  Filling -> {2 -> {c, {Blue, Red}}},
  MeshFunctions -> {g[#] &}, 
  Mesh -> {{c}}, 
  MeshStyle -> meshStyle, 
  PerformanceGoal -> "Quality", 
  DisplayFunction -> ReplaceAll[{p_Polygon, _Polygon} :> p]], 
 {{c, 4/9 + 0.001, "c="}, 0, (4 Sqrt[2])/9, Appearance -> "Open"}, 
 Button["Reset", c = 4/9 + 0.001]]

enter image description here

$\endgroup$
6
$\begingroup$

Speed principle: Recalculate with each update only those things that need recalculating.

How vigorously to pursue this goals should be moderated by another principle: If Manipulate is responsive enough, then the code is fast enough.

This "lesson" pursues the first principle vigorously and pretty much ignores the second one. The purpose of the example code below is to illustrate what can be done and what it might cost. For instance, base plots do not usually need to be updated and the elements that need updating can be recalculated separately. But Plot[] is usually fast enough and recalculating the base plot is usually acceptable. Below we ignore this and calculate the base plot separately. This costs us the convenience of Filling, since the filling needs to be recalculated each time c is changed. The cost is some programming — easy programming (for me) but time and testing (for me and anyone else). Solve[] also needs calculating only once. Like Plot[], Solve[] is often fast enough, and it is here. The actual slowdown in the OP's code is the result of calling Solve[] and Plot[] so many times. Every sol[c] calls Solve[] to repeat its calculation. Below we call Solve[] once in the initialization, and use the result repeated. Its one of the few times that using Set instead of SetDelayed is useful in defining a function.

f[x_] = c;
g[x_] = -3 x^3 + 2 x;

Manipulate[
 With[{
   (* split graph into blue, red segments *)
   lines = SplitBy[graph, Sign[Last[#] - c] &],
   xint = sol[c]},
  Show[
   Graphics[{ (* put shading under graph *)
     Blue, Polygon[Join[{{xint[[1]], c}, {0., c}}, lines[[1]]]],
     Red, 
     Polygon[Join[{{xint[[2]], c}, {xint[[1]], c}}, lines[[2]]]],
     AbsoluteThickness[1.6], Line[{{0, c}, {Sqrt[2/3], c}}]
     }]
   , plot
   , Graphics[{ (* put intersection points on top of graph *)
     {Blue, PointSize@Large,
      Text[Style["A", Black], {xint[[1]], c}, {1.5, -1.5}],
      Point[{xint[[1]], c}]},
     {Red, PointSize@Large,
      Text[Style["B", Black], {xint[[2]], c}, {-1.5, -1.5}],
      Point[{xint[[2]], c}]}}]
   , Axes -> True
   , PlotRange -> {{-0.1, 
      Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}}
   ]
  ]
 , {{c, 4/9 + 0.001, "c="}, 0.001, (4 Sqrt[2])/9 - 0.00001, 
  Appearance -> "Open"}
 , {{plot, plot}, None}
 , {{graph, graph}, None}
 , {{sol, sol}, None}
 , Button["Reset", c = 4/9 + 0.001]
 , Initialization :> (
   plot = Plot[{f[x], g[x]}, {x, 0, Sqrt[2/3]},
     PlotStyle -> {Red, Blue},
     (* alternative form for legend: *)
     PlotLegends -> {HoldForm[f[x]] == f[x], 
       HoldForm[g[x]] == g[x]}];
   (* two Line[] objects, one for f and one for g: *)
   graph = Last@Cases[Normal@plot, Line[p_] :> p, Infinity];
   sol[g0_] = 
    Flatten@Normal@
      SolveValues[{g[x] == g0, 0 <= x < Sqrt[2/3], 
        0 < g0 < MaxValue[{g[x], 0 < x < Sqrt[2/3]}, x]}, {x}])
 ]
$\endgroup$
1
  • $\begingroup$ Thanks for the reply, it runs very nicely. I don't understand exactly what you did but I'll sit down and study it. $\endgroup$ Aug 27, 2023 at 15:35
5
$\begingroup$
  • Not the fully answer,only remove the right blue part.
g[x_] = -3 x^3 + 2 x;
Manipulate[
 Block[{plot = 
    Plot[{c, g[x]}, {x, 0, Sqrt[2/3]}, 
     Filling -> {1 -> {{2}, {Red, Blue}}}, PlotStyle -> {Red, Blue}, 
     PerformanceGoal -> "Quality"]},
  Delete[plot, Position[plot, Polygon[{_}]] // Last]], {c, .01, 1}]

enter image description here

$\endgroup$
3
$\begingroup$
$Version

(* "13.3.1 for Mac OS X x86 (64-bit) (July 24, 2023)" *)

Clear["Global`"]

f[x_] = c;

g[x_] = -3 x^3 + 2 x;

sol[c_] = Solve[{g[x] == c, 0 < x < Sqrt[2/3]}, x, Reals];

Manipulate

Manipulate[
 Module[{x1 = x /. sol[c][[1]], x2 = x /. sol[c][[2]]},
  Show[
   Plot[{ConditionalExpression[c, x <= x2], g[x],
     ConditionalExpression[c, x > x2]},
    {x, 0, Sqrt[2/3]},
    PlotRange -> {-0.03, (4 Sqrt[2])/9 + 0.1},
    PlotStyle -> {Red, Blue},
    Filling -> 2 -> {1},
    FillingStyle -> {LightBlue, LightRed},
    PlotLegends -> (StringForm["``\[ThinSpace]=\[ThinSpace]``", #, 
         ReleaseHold[#]] & /@
       {HoldForm[f[x]], HoldForm[g[x]]}),
    Epilog -> {
      Text[#[[1]], {#[[2]], c}, 
         1.5 {Sign[Sqrt[2]/3 - #[[2]]], -1}] & /@
       {{"A", x1}, {"B", x2}},
      PointSize@Large,
      {Blue, Point[{x1, c}]},
      {Red, Point[{x2, c}]}}]]],
 {{c, Round[4/9, 0.001], "c\[ThickSpace]=\[ThinSpace]"}, 0.001, 
  Floor[4 Sqrt[2]/9, 0.001],
  0.001, Appearance -> {"Open", "Labeled"}},
 Button["Reset", c = Round[4/9, 0.001]]]

enter image description here

$\endgroup$
2
$\begingroup$

An easy way to reduce continuous manipulation evalution is to dicretize the parameter to some 20 values, enough for visualisation as - known from cinema - by a With statement with a step function

  With[{c = Floor[20 cf]/20},.... 

f[x_] = c;
g[x_] = -3 x^3 + 2 x;
sol[c_] := Solve[{g[x] == c, 0 < x < Sqrt[2/3]}, x];
Manipulate[
 With[{c = Floor[20 cf]/20}, 
  Show[Plot[{c, g[x]}, {x, 0, Sqrt[2/3]}, 
    PlotRange -> {{-0.1, 
       Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}}, 
    PlotStyle -> {Red, Blue}, 
    PlotLegends -> {"f(x)=c", 
      "g(x)=-3\!\(\*SuperscriptBox[\(x\), \(3\)]\)+2x"}, 
    Epilog -> {{Blue, PointSize@Large, 
       Text[Style["A", Black], {-0.02 + x /. sol[c][[1]], c + 0.02}], 
       Point[{x /. sol[c][[1]], c}]}, {Red, PointSize@Large, 
       Text[Style["B", Black], {0.02 + x /. sol[c][[2]], c + 0.02}], 
       Point[{x /. sol[c][[2]], c}]}}], 
   Plot[{c, g[x]}, {x, 0, x /. sol[c][[1]]}, 
    PlotRange -> {{-0.1, 
       Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}}, 
    PlotStyle -> {Red, Blue}, Filling -> {1 -> {{2}, {Blue}}}], 
   Plot[{c, g[x]}, {x, x /. sol[c][[1]], x /. sol[c][[2]]}, 
    PlotRange -> {{-0.1, 
       Sqrt[2/3] + 0.1}, {-0.1, (4 Sqrt[2])/9 + 0.1}}, 
    PlotStyle -> {Red, Blue}, Filling -> {1 -> {{2}, {Red}}}]]], {{cf,
    4/9 + 0.001, "c="}, 0, (4 Sqrt[2])/9, Appearance -> "Open"}, 
 Button["Reset", cf = 4/9 + 0.001]]
$\endgroup$

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.