3
$\begingroup$

Here is a naive coding of a projection of a point on a sphere. It runs very slow. Can it be changed to run faster without losing its essential analytic character?

Magnify[Manipulate[
  Show[ParametricPlot3D[{{x, 0, 1}, {0, y, 1}, {x, y, 1}, {x, x^2, 
      1}, {x*w, x*w^2, x}, {x, y, Sqrt[1 - x^2 - y^2]}, {x, 
      y, -Sqrt[1 - x^2 - y^2]}, {x/Sqrt[x^2 + (x^2)^2 + 1], (x^2)/
       Sqrt[x^2 + (x^2)^2 + 1], 
      1/Sqrt[x^2 + (x^2)^2 + 1]}, {-x/Sqrt[x^2 + (x^2)^2 + 1], -(x^2)/
       Sqrt[x^2 + (x^2)^2 + 1], -1/Sqrt[x^2 + (x^2)^2 + 1]}}, {x, -5, 
     5}, {y, -5, 5}, Axes -> False, Boxed -> False, 
    Mesh -> {{-5, 5}, {-5, 5}}, 
    RegionFunction -> Function[{x, y, z}, 0 < x^2 + y^2 < 16], 
    SphericalRegion -> True, (*RotationAction->"Clip",*)
    PlotStyle -> {Black, Black, 
      Directive[Opacity[0.5], Blue, Specularity[White, 50]], 
      Directive[ Red], Directive[ Red], 
      Directive[Opacity[0.5], Orange, Specularity[White, 50], 
       Mesh -> None], 
      Directive[Opacity[0.5], Orange, Specularity[White, 50], 
       Mesh -> None], Directive[Black], Directive[ Black]}], 
   Graphics3D[{Red, PointSize[.01], 
     Point[{{w/Sqrt[w^2 + (w^2)^2 + 1], (w^2)/Sqrt[w^2 + (w^2)^2 + 1],
         1/Sqrt[w^2 + (w^2)^2 + 1]}, {-w/Sqrt[
         w^2 + (w^2)^2 + 1], -(w^2)/Sqrt[w^2 + (w^2)^2 + 1], -1/Sqrt[
         w^2 + (w^2)^2 + 1]}, {w, w^2, 1}}]}]], {{w, 1.086}, 0.01, 
   3}], 1.7]
$\endgroup$
6
$\begingroup$

You've got a lot going on in your graphic that is possibly causing the slowdown. I have not done an exhaustive refactoring of your code, but hopefully considering this approach might help you.

First, I pulled apart your graphic and tried to find what was slowing things down. The ParametricPlot3D has a greater effect on the performance than does the Graphics3D component. In the former, I pulled out the various elements and timed how long it takes to draw them:

f = {{x, 0, 1}, {0, y, 1}, {x, y, 1}, {x, x^2, 1}, {x, y, 
    Sqrt[1 - x^2 - y^2]}, {x, 
    y, -Sqrt[1 - x^2 - y^2]}, {x/Sqrt[x^2 + (x^2)^2 + 1], (x^2)/
     Sqrt[x^2 + (x^2)^2 + 1], 
    1/Sqrt[x^2 + (x^2)^2 + 1]}, {-x/Sqrt[x^2 + (x^2)^2 + 1], -(x^2)/
     Sqrt[x^2 + (x^2)^2 + 1], -1/Sqrt[x^2 + (x^2)^2 + 1]}};
time2 = Table[ 
  ParametricPlot3D[f[[1 ;; i]], {x, -5, 5}, {y, -5, 5}, Axes -> False,
      Boxed -> False, Mesh -> {{-5, 5}, {-5, 5}}, 
     SphericalRegion -> True]; // AbsoluteTiming, {i, Length@f}]

I performed this analysis with time1 and without time2 (shown) the RegionFunction getting the following results:

time1 = {{1.351077, Null}, {3.455198, Null}, {3.594206, Null}, {6.287360, 
  Null}, {9.004912, Null}, {10.013767, Null}, {14.450210, 
  Null}, {18.088035, Null}}

time2 = {{0.413024, Null}, {0.855247, Null}, {0.887051, Null}, {1.356276, 
  Null}, {2.078317, Null}, {2.454537, Null}, {3.956425, 
  Null}, {5.527316, Null}}

I draw from these data that (a) it takes a long time to draw about half of your components and (b) the RegionFunction isn't helping much either.

Add in the specularity directives and I think you need to reconsider your expectations for smooth and quick response times.

In any case, it looks like a large chunk of your ParametricPlot3D is updated after moving the slider and it doesn't need to be. Let's move that outside of the Manipulate then. (I tried keeping it the Manipulate using Initialization -> ... but received time outs.)

preplot = 
  ParametricPlot3D[{{x, 0, 1}, {0, y, 1}, {x, y, 1}, {x, x^2, 1}, {x, 
     y, Sqrt[1 - x^2 - y^2]}, {x, 
     y, -Sqrt[1 - x^2 - y^2]}, {x/Sqrt[x^2 + (x^2)^2 + 1], (x^2)/
      Sqrt[x^2 + (x^2)^2 + 1], 
     1/Sqrt[x^2 + (x^2)^2 + 1]}, {-x/Sqrt[x^2 + (x^2)^2 + 1], -(x^2)/
      Sqrt[x^2 + (x^2)^2 + 1], -1/Sqrt[x^2 + (x^2)^2 + 1]}}, {x, -5, 
    5}, {y, -5, 5}, Axes -> False, Boxed -> False, 
   Mesh -> {{-5, 5}, {-5, 5}}, 
   RegionFunction -> Function[{x, y, z}, 0 < x^2 + y^2 < 16], 
   SphericalRegion -> True,(*RotationAction\[Rule]"Clip",*)
   PlotStyle -> {Black, Black, 
     Directive[Opacity[0.5], Blue, Specularity[White, 50]], 
     Directive[Red], Directive[Red], 
     Directive[Opacity[0.5], Orange, Specularity[White, 50], 
      Mesh -> None], 
     Directive[Opacity[0.5], Orange, Specularity[White, 50], 
      Mesh -> None], Directive[Black], Directive[Black]}];
Magnify[Manipulate[Show[preplot,
   ParametricPlot3D[{x*w, x*w^2, x}, {x, -5, 5}, {y, -5, 5}, 
    Axes -> False, Boxed -> False, Mesh -> {{-5, 5}, {-5, 5}}, 
    RegionFunction -> Function[{x, y, z}, 0 < x^2 + y^2 < 16], 
    SphericalRegion -> True,(*RotationAction\[Rule]"Clip",*)
    PlotStyle -> {Directive[Red]}], 
   Graphics3D[{Red, PointSize[.01], 
     Point[{{w/Sqrt[w^2 + (w^2)^2 + 1], (w^2)/Sqrt[w^2 + (w^2)^2 + 1],
         1/Sqrt[w^2 + (w^2)^2 + 1]}, {-w/
         Sqrt[w^2 + (w^2)^2 + 1], -(w^2)/Sqrt[w^2 + (w^2)^2 + 1], -1/
         Sqrt[w^2 + (w^2)^2 + 1]}, {w, w^2, 1}}]}]], {{w, 1.086}, 
   0.01, 3}], 1.7]

Now you have slightly improved performance, at least in that the elements of your ParametricPlot3D that are not dependent on w won't get updated.

I don't know what essential analytic character means to you. I would continue to peel-back your code in order to identify what elements are creating the performance issues. Then you can decide if those elements are truly necessary. I hope some of these suggestions are worthwhile.

I suggest taking a look at the following for additional guidance.

$\endgroup$
  • $\begingroup$ Thanks bobthechemist. I didn't know or at least understand the preplot technique. I am going to take your advice and try to eliminate anything superfluous in the manipulate. $\endgroup$ – Jim Hatton Aug 4 '14 at 15:42

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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