# How to speed up Manipulate with Graphics3D

How do I speed up the Manipulate of the Graphics3D objects here? It is currently painfully slow, and I'm at a loss.

I have reviewed many other posts and implemented what I could based on them, but it has had minimal effect on the speed. I have tried implementing:

• Reducing the angles used to 10 degree steps
• Memoization
• Dynamic (applied at various levels to various functions)
• Initialization code for Manipulate
• TrackedSymbols option for Manipulate
• Using With (both inside and outside Manipulate for the functions currently in Initialization)

I am building a demonstration of the rotation of vectors through the Euler angles. I have excluded the last rotation because the speed is already so slow.

(Apologies in advance for posting the entire code and the poor formatting here and there, which I've chosen to leave as is so that it can be copied and pasted into Mathematica.)

Manipulate[
Graphics3D[{
(* Size a graphics box to make visualization area constant *)
graphicsBox,

(* Original coordinate axes *)
origCoordAxes,

(* Vectors rotated once *)
vectorsRotatedOnce[ψ],

(* Vectors rotated twice *)

vectorsRotatedTwice[ψ, θ],

(* Plane surface first rotation *)

planeSurfaceFirstRotation[ψ],

(* Plane surface second rotation *)

planeSurfaceSecondRotation[ψ, θ]
},
BoxStyle -> Directive[Opacity[.1]],
ViewVertical -> {0, 0, -1},
ViewPoint -> {-12, -10, -5}
],

{{ψ, 60}, 1, 91, 10},
{{θ, 40}, 1, 91, 10},

Initialization :> (
x0 = {2, 0, 0};
y0 = {0, 2, 0};
z0 = {0, 0, 2};
x1[ψ_] := x1[ψ] = RotationMatrix[ψ Degree, z0]. x0;
y1[ψ_] := y1[ψ] = RotationMatrix[ψ Degree, z0]. y0;
z1[ψ_] := z1[ψ] = RotationMatrix[ψ Degree, z0]. z0;
x2[ψ_, θ_] := x2[ψ, θ] = RotationMatrix[θ Degree, y1[ψ]]. x1[ψ];
y2[ψ_, θ_] := y2[ψ, θ] = RotationMatrix[θ Degree, y1[ψ]]. y1[ψ];
z2[ψ_, θ_] := z2[ψ, θ] = RotationMatrix[θ Degree, y1[ψ]]. z1[ψ];

graphicsBox = Sequence[
EdgeForm[None], Opacity,
Cuboid[{0, 0, 0}, {1.25, 1.25, 1.25}],
Cuboid[{0, 0, 0}, {-1.25, -1.25, -1.25}]
];

origCoordAxes = Sequence[
Black, Opacity[.25],
Arrow[Tube[{{0, 0, 0}, {1, 0, 0}}, 0.005]],
Text[Style["\!$$\*SubscriptBox[\(x$$, $$0$$]\)", Black, Large], {1.2, 0, 0}],
Arrow[Tube[{{0, 0, 0}, {0, 1, 0}}, 0.005]],
Text[Style["\!$$\*SubscriptBox[\(y$$, $$0$$]\)", Black, Large], {0, 1.2, 0}],
Arrow[Tube[{{0, 0, 0}, {0, 0, 1}}, 0.005]],
Text[Style["\!$$\*SubscriptBox[\(z$$, $$0$$]\)", Black, Large], {0, 0, 1.2}]
];

vectorsRotatedOnce[ψ_] := vectorsRotatedOnce[ψ] =
Sequence[
Red, Opacity,
Arrow[Tube[{{0, 0, 0}, x1[ψ]}, 0.01]],
Text[Style["\!$$\*SubscriptBox[\(x$$, $$1$$]\)", Black, Large], (1.2 x1[ψ])],
Text[Style["ψ", Lighter@Blue, Large], ((1/3) ( x1[ψ] + x0))],
Green,
Arrow[Tube[{{0, 0, 0}, y1[ψ]}, 0.01]],
Text[Style["\!$$\*SubscriptBox[\(y$$, $$1$$]\)", Black,  Large], (1.2 y1[ψ])],
Text[Style["ψ", Lighter@Blue, Large], ((1/3) ( y1[ψ] + y0))],
Blue,
Arrow[Tube[{{0, 0, 0}, z1[ψ]}, 0.01]],
Text[ Style["\!$$\*SubscriptBox[\(z$$, $$1$$]\)", Black,Large], (1.2 z1[ψ])]
];

vectorsRotatedTwice[ψ_, θ_] :=
vectorsRotatedTwice[ψ, θ] =
Sequence[
Lighter@Red, Opacity[.3],
Arrow[Tube[{{0, 0, 0}, x2[ψ, θ]}, 0.01]],
Text[ Style["\!$$\*SubscriptBox[\(x$$, $$2$$]\)", Black, Large], (1.2 x2[ψ, θ])],
Text[ Style["θ", Lighter@Green, Large, Opacity], ((1/3) ( x2[ψ, θ] + x1[ψ]))],
Lighter@Green,
Arrow[Tube[{{0, 0, 0}, y2[ψ, θ]}, 0.01]],
Lighter@Blue,
Arrow[Tube[{{0, 0, 0}, z2[ψ, θ]}, 0.01]],
Text[Style["\!$$\*SubscriptBox[\(z$$, $$2$$]\)", Black,Large], (1.2 z2[ψ, θ])],
Text[Style["θ", Lighter@Green, Large,  Opacity], ((1/3) ( z2[ψ, θ] + z1[ψ]))]
];

planeSurfaceFirstRotation[ψ_] :=
planeSurfaceFirstRotation[ψ] =
Sequence[
Opacity[.2],
Directive[Blue, Glow[Blue], Specularity],
Dynamic@Rotate[surfaceX2[ψ Degree][], 0, {0, 0, 1}],
Dynamic@Rotate[surfaceX2[ψ Degree][], π/2, {0, 0, 1}]
];

planeSurfaceSecondRotation[ψ_, θ_] :=
planeSurfaceSecondRotation[ψ, θ] =
Sequence[
Opacity[.2],
Directive[Green, Glow[Green], Specularity],
Dynamic@Rotate[Rotate[surfaceX2[θ Degree][], ψ Degree, {0, 0, 1}],
3 π/2, x1[ψ]],
Dynamic@Rotate[Rotate[surfaceX2[θ Degree][], ψ Degree - π/2,{0, 0, 1}], 3 π/2, x1[ψ]]
];

surfaceX2[α_] := surfaceX2[α] =
ParametricPlot3D[{r Cos[u], r Sin[u], 0}, {u, 0, α}, {r,
0, 1.5},
Mesh -> None,
Axes -> None,
Boxed -> True,
Lighting -> {{"Ambient", Blue}},
PerformanceGoal -> "Speed"
];
),
TrackedSymbols :> {ψ, θ}
]

• Works rather zippy for me - what are your hardware specs? Tube and Arrow[Tube...] can slow down rendering quite a bit - perhaps simply using an Arrow will help acceleration. – Yves Klett Nov 26 '13 at 8:32
• It's smooth and responsive on my 2011 iMac with 12GB RAM, even with PerformanceGoal -> "Quality"... It might help a bit if the box didn't keep changing size... – cormullion Nov 26 '13 at 8:44
• Add ImageSize -> {400, 400} at end of your Graphics3D call. All the shifting is actually making it slow down a little ! and if you do not care about seeing each step, you can add ContinuousAction -> False and that will make faster. – Nasser Nov 26 '13 at 8:47
• @zentient: see here for greek letters :) – Öskå Nov 26 '13 at 10:41
• Do you have software rendering (BSPTree or similar, see mathematica.stackexchange.com/a/190/131) activated? That really slows down rendering compared to hardware-acceleration. – Yves Klett Nov 26 '13 at 11:35

I played with this a bit to try to speed it up. Usually I don't like touching code that is this long, but your code was well organized so it was easy to see what was going on, and it was easy to remove parts and test them separately.

What I did first was to remove all optimization attempts that I was not convinced had any significant effect. Let's find out what part of the code is causing the slowdown before trying to optimize it.

So, I removed memoization, TrackedSymbols (seems unnecessary), Dynamic (unnecessary).

Then I changed ψ and θ to have continuous values instead of discrete. Discrete values were not needed since we removed memoization, and having discrete angles creates makes the animation look choppy, even if performance is good. So now I had {{ψ, 60}, 0.1, 90.}, {{θ, 40}, 0.1, 90.} in Manipulate. Also note that using integers in computations is slower than using machine precision numbers. Using discrete values had the side effect of doing all computations with integers.

Next, I changed all Sequence to List, the reasoning being that Sequence seemed unnecessary and would cause some additional computations to be done (though I really doubt those had an effect on performance).

Next, I removed graphicsBox and related things. To keep the plot area constant, I added the following options to Graphics3D:

 PlotRange-> 2 {{-1,1},{-1,1},{-1,1}},
SphericalRegion -> True


Side note: This is unrelated to performance or your question, but I would prefer the ViewPoint to be closer to the origin. The large distance causes the perspective to be so flat that I find it hard to mentally follow the rotation. This is of course your decision :-)

Next, I removed the separate objects in the Graphics3D to see which had the greatest performance effect. planeSurfaceFirstRotation and planeSurfaceSecondRotation seemed to have a stronger effect on performance than the other two, so I decided to optimize surfaceX2:

surfaceX2[α_]  := With[{r=1.5},
{EdgeForm[None],
Polygon@Join[
Table[{r Cos[u],r Sin[u],0}, {u,0,α,0.1}],
{{r Cos[α],r Sin[α],0}, {0,0,0}}]}
];


Now it returns graphics primitives, so I removed the [] part from functions that use it. Another note here: you had Axes -> None, Boxed -> True, Lighting -> {{"Ambient", Blue}} in your parametric plot command. These had no effect at all because the graphics primitives were extracted from the result and placed in a different Graphics3D.

At this point dragging the Manipulate sliders updates the graphics with the same frame rate as rotating it with the mouse. So I assume that at this point the performance is limited by rendering the graphics on screen, not by building the symbolic Graphics3D object. The easiest way to speed things up is to avoid transparent objects. If I make all objects opaque, the animation is completely smooth on my computer. Personally, I prefer the looks with everything opaque except the surfaceX2, but removing all opacity (including from the box) will speed things up noticeably.

Here's your code, modified as I described, except for removing opacity (some cleanup will be needed as I didn't format it as well as you did). On my machine the end result is noticeably (but not very significantly) smoother than with the original code.

Manipulate[
Graphics3D[{

(* Original coordinate axes *)
origCoordAxes,

(* Vectors rotated once *)
vectorsRotatedOnce[ψ],

(* Vectors rotated twice *)

vectorsRotatedTwice[ψ, θ],

(* Plane surface first rotation *)

planeSurfaceFirstRotation[ψ],

(* Plane surface second rotation *)

planeSurfaceSecondRotation[ψ, θ]
},
BoxStyle -> GrayLevel[.75],
ViewVertical -> {0, 0, -1},
ViewPoint -> {-12, -10, -5},
PlotRange-> 2{{-1,1},{-1,1},{-1,1}},
SphericalRegion->True
],

{{ψ, 60}, 0.1, 90.},
{{θ, 40}, 0.1, 90.},

Initialization :> (
x0 = {2, 0, 0};
y0 = {0, 2, 0};
z0 = {0, 0, 2};
x1[ψ_] :=  RotationMatrix[ψ Degree, z0]. x0;
y1[ψ_] :=  RotationMatrix[ψ Degree, z0]. y0;
z1[ψ_] :=  RotationMatrix[ψ Degree, z0]. z0;
x2[ψ_, θ_] :=  RotationMatrix[θ Degree, y1[ψ]]. x1[ψ];
y2[ψ_, θ_] :=  RotationMatrix[θ Degree, y1[ψ]]. y1[ψ];
z2[ψ_, θ_] :=  RotationMatrix[θ Degree, y1[ψ]]. z1[ψ];

origCoordAxes = List[
Black, Opacity[.25],
Arrow[Tube[{{0, 0, 0}, {1, 0, 0}}, 0.005]],
Text[Style["\!$$\*SubscriptBox[\(x$$, $$0$$]\)", Black, Large], {1.2, 0, 0}],
Arrow[Tube[{{0, 0, 0}, {0, 1, 0}}, 0.005]],
Text[Style["\!$$\*SubscriptBox[\(y$$, $$0$$]\)", Black, Large], {0, 1.2, 0}],
Arrow[Tube[{{0, 0, 0}, {0, 0, 1}}, 0.005]],
Text[Style["\!$$\*SubscriptBox[\(z$$, $$0$$]\)", Black, Large], {0, 0, 1.2}]
];

vectorsRotatedOnce[ψ_] :=
List[
Red, Opacity,
Arrow[Tube[{{0, 0, 0}, x1[ψ]}, 0.01]],
Text[Style["\!$$\*SubscriptBox[\(x$$, $$1$$]\)", Black, Large], (1.2 x1[ψ])],
Text[Style["ψ", Lighter@Blue, Large], ((1/3) ( x1[ψ] + x0))],
Green,
Arrow[Tube[{{0, 0, 0}, y1[ψ]}, 0.01]],
Text[Style["\!$$\*SubscriptBox[\(y$$, $$1$$]\)", Black,  Large], (1.2 y1[ψ])],
Text[Style["ψ", Lighter@Blue, Large], ((1/3) ( y1[ψ] + y0))],
Blue,
Arrow[Tube[{{0, 0, 0}, z1[ψ]}, 0.01]],
Text[ Style["\!$$\*SubscriptBox[\(z$$, $$1$$]\)", Black,Large], (1.2 z1[ψ])]
];

vectorsRotatedTwice[ψ_, θ_] :=
List[
Lighter@Red, Opacity[.3],
Arrow[Tube[{{0, 0, 0}, x2[ψ, θ]}, 0.01]],
Text[ Style["\!$$\*SubscriptBox[\(x$$, $$2$$]\)", Black, Large], (1.2 x2[ψ, θ])],
Text[ Style["θ", Lighter@Green, Large, Opacity], ((1/3) ( x2[ψ, θ] + x1[ψ]))],
Lighter@Green,
Arrow[Tube[{{0, 0, 0}, y2[ψ, θ]}, 0.01]],
Lighter@Blue,
Arrow[Tube[{{0, 0, 0}, z2[ψ, θ]}, 0.01]],
Text[Style["\!$$\*SubscriptBox[\(z$$, $$2$$]\)", Black,Large], (1.2 z2[ψ, θ])],
Text[Style["θ", Lighter@Green, Large,  Opacity], ((1/3) ( z2[ψ, θ] + z1[ψ]))]
];

planeSurfaceFirstRotation[ψ_] :=
List[
Opacity[.2],
Directive[Blue, Glow[Blue], Specularity],
Rotate[surfaceX2[ψ Degree], 0, {0, 0, 1}],
Rotate[surfaceX2[ψ Degree], π/2, {0, 0, 1}]
];

planeSurfaceSecondRotation[ψ_, θ_] :=
List[
Opacity[.2],
Directive[Green, Glow[Green], Specularity],
Rotate[Rotate[surfaceX2[θ Degree], ψ Degree, {0, 0, 1}],
3 π/2, x1[ψ]],
Rotate[Rotate[surfaceX2[θ Degree], ψ Degree - π/2,{0, 0, 1}], 3 π/2, x1[ψ]]
];

surfaceX2[α_]  := With[{r=1.5},
{EdgeForm[None],Polygon@Join[Table[{r Cos[u],r Sin[u],0},{u,0,α,0.1}],{{r Cos[α],r Sin[α],0},{0,0,0}}]}
];
)
]

• Many, many thanks! The code now produces a very admirable, smooth Manipulate, for which I am (and hopefully many students will be) grateful. Your suggestions, plus changing the 3D rendering engine to "HardwareDepthBuffer", made a huge difference. One point of note: when I run your code, I think a non-Graphics3D object snuck into the code, perhaps via the surfaceX2 function (?), which the Graphics3D command doesn't want to execute. Either way, a stellar result. – TransferOrbit Nov 28 '13 at 17:38