Spherical co-ordinate graphics in Mathematica - wolfram-mathematica

Question

Is it possible to create graphics of spherical co-ordinate system like this in mathematica or should I use photoshop? I'm asking because I want a high resolution graphic, but lot of the files on internet are grainy when zoomed.
Here is the image:

Answer 1

The figure is made up of simple geometric shapes and these can be easily recreated in Mathematica using equations. Here is one that is close to this plot, which IMO is less cluttered than the above, but you can always use these ideas to recreate your image exactly.
Clear[ellipsePhi, ellipseTheta, circle]
circle[x_] = {Cos[x], Sin[x]};
ellipsePhi[x_, a_: - Pi/2] = {Cos[x - a]/3, Sin[x + a]};
ellipseTheta[x_, a_: 0] = {Cos[x + a], Sin[-x - a]/2};
(*Main circle*)
ParametricPlot[circle[x], {x, 0, 2 Pi},
PlotStyle -> Black,
Epilog -> First /# {
(*Ellipses*)
ParametricPlot[{ellipsePhi[x], ellipsePhi[-x], ellipseTheta[-x],
ellipseTheta[x]}, {x, 0, Pi},
PlotStyle -> {{Black, Dashed}, Black}],
(*Co-ordinate axes*)
Graphics[
Table[GeometricTransformation[{Arrowheads[0.03],
Arrow[{{0, 0}, {1.2, 0}}]},
ReflectionMatrix[circle[x]]], {x, {Pi/2, -Pi/4, Pi/8}}]],
(*mark point, rho, phi & theta directions*)
ParametricPlot[{ellipsePhi[x, Pi/2], ellipseTheta[-x, 13 Pi/20]}, {x,
0, Pi/4},
PlotStyle -> {{Red, Thick}, {Blue, Thick}}] /.
Line[x__] :> Sequence[Arrowheads[0.03], Arrow[x]],
Graphics[{{Directive[Darker#Green, Thick], Arrowheads[0.03],
Arrow[{{0, 0}, ellipsePhi[-3 Pi/4]}]},
{Directive[Purple], Disk[ellipsePhi[-3 Pi/4], 0.02]}}],
(*text*)
Graphics[{
Text[Style["x", Italic, Larger], 1.25 circle[5 Pi/4]],
Text[Style["y", Italic, Larger], 1.25 circle[0]],
Text[Style["z", Italic, Larger], 1.25 circle[Pi/2]],
Text[Style["\[Rho]", Italic, Larger], 0.4 circle[4 Pi/11]],
Text[Style["\[CurlyPhi]", Italic, Larger],
1.1 ellipsePhi[Pi + Pi/5]],
Text[Style["\[Theta]", Italic, Larger],
1.1 ellipseTheta[13 Pi/20 - Pi/8]],
Text[Style["P", Italic, Larger], 1.2 ellipsePhi[-3 Pi/4 + Pi/24]]}]
},
Axes -> False, PlotRange -> 1.3 {{-1, 1}, {-1, 1}}
]
which gives you this
Although it is possible to set the angles & arrows precisely, in some places (e.g., 13 Pi/20), I've only roughly approximated it. You really can't tell the difference in the final figure, but if you're picky you can change them and fix the positions exactly.

Answer 2

This alternative solution has the advantage of being created using 3D directives. As such, it was easy to wrap inside a Manipulate and you can drag it with your mouse to change the viewpoint:
Manipulate[
Module[{x = Sin[\[Phi]] Cos[\[Theta]], y = Sin[\[Phi]] Sin[\[Theta]],
z = Cos[\[Phi]]},
Show[
ParametricPlot3D[
{{Cos[t], Sin[t], 0},
{0, Sin[t], Cos[t]},
{Sin[t], 0, Cos[t]}},
{t, 0, 2 \[Pi]}, PlotStyle -> Black, Boxed -> False,
Axes -> False, AxesLabel -> {"x", "y", "z"}],
ParametricPlot3D[0.5*{Cos[t], Sin[t], 0}, {t, 0, \[Theta]}],
ParametricPlot3D[
RotationTransform[\[Theta], {0, 0, 1}][{Sin[t]/2, 0,
Cos[t]/2}], {t, 0, \[Phi]}],
Graphics3D[{
{{Blue, Thick,
Arrow[{{0, 0, 0}, #}] & /# {{1, 0, 0}, {0, 1, 0}, {0, 0,
1}, {x, y, z}}},
{Opacity[0.1],
Red, Polygon[{{0, 0, 0}, {x, y, 0}, {x, y, z}}],
Green, Polygon[{{0, 0, 0}, {x, 0, 0}, {x, y, 0}}]}},
{Opacity[0.05], Sphere[{0, 0, 0}]},
{Text["O", {-.03, -.03, -.03}],
Text["X", {1.1, 0, 0}],
Text["Q", {x, y, 0}, {1, 1}],
Text["P", {x, y, z}, {0, -1}],
Text["Y", {0, 1.1, 0}],
Text["Z", {0, 0, 1.1}],
Text["r", {x/2, y/2, 0}, {1, 1}],
Text[
"\[Theta]", {Cos[\[Theta]/2]/2, Sin[\[Theta]/2]/2, 0}, {1,
1}],
Text["\[Phi]",
RotationTransform[\[Theta], {0, 0, 1}][{Sin[\[Phi]/2]/2, 0,
Cos[\[Phi]/2]/2}], {1, 1}]}}]]],
{{\[Phi], \[Pi]/4}, 0.01, \[Pi]/2}, {{\[Theta], \[Pi]/4}, 0.01,
2 \[Pi]}]