Spinning top: how to plot position on a sphere?

Question

I am modelling a spinning top on a sphere and I want to obtain plots such as these

I have solved the equations of motion

B = 1;
a = 1;
sol = NDSolve[{p'[t] == (B - a*Cos[th[t]])/(Sin[th[t]]^2), 
th''[t] == (p'[t]*(p'[t]*Cos[th[t]] - a) + 1)*Sin[th[t]], 
th[0] == 1, p[0] == 0, th'[0] == 0}, {p, p', th, th'}, {t, 0, 10} ]

Then to plot the points I evaluate

a = Flatten[Table[th[t] /. sol, {t, 0, 10}]]
b = Flatten[Table[p[t] /. sol, {t, 0, 10}]]
res = Transpose[{Table[1, {t, 0, 10}], a, b
}] (*I want all points on a unit sphere*)

Then following what is in this question I do

Graphics3D@{Sphere[{0, 0, 0}, 1], 
Point[CoordinateTransformData["Spherical" -> "Cartesian", 
  "Mapping", #] & /@ res]}

But I get back all sorts of errors as below

Why so? It looks like this is because my angles phi get quite large as I got around the sphere (n rotations would be 2nPi).

The outputs of NDSolve are the following:

I think the issue can be solved if all the coordinates theta and phi can be mapped into the range allowed by the coordinate transformation. Mathematica seems to require phi between -pi and pi. So theta should be between 0 and pi. How do I do this? (Very new to mathematica)

Answer 1

As you have already identified, the problem with CoordinateTransformData[ "Spherical" -> "Cartesian", "Mapping", {r, θ, ϕ}] is that it wants to treat spherical coordinates as invertible map. Thus, it wants the second argument to lie in the interval $[0,\pi]$ and the third argument to lie in the interval $[-\pi ,\pi]$. You can achieve this by using Modas follows:

res1 = res;
res1[[All, 2]] = Mod[res1[[All, 2]], Pi];
res1[[All, 3]] = Mod[res1[[All, 3]], 2 Pi, -Pi];

Now, the plot

Graphics3D[{
 Sphere[{0, 0, 0}, 1], 
 Point[CoordinateTransformData["Spherical" -> "Cartesian", "Mapping", #] & /@ res1]
 }]

should work.

Answer 2

There are some problems with CoordinateTransform and CoordinateTransformData that can be avoided by simply not using these functions. Here's the problem: say we want start the top spinning at $\theta=0$. Try putting the $(r,\theta,\phi)$ coordinates of $(1,0,1)$ into CoordinateTransform

CoordinateTransform["Spherical"->"Cartesian", {1,0,1} ]

and it gives an error because the transformation is not defined at $\theta=0$. Also, the Mod function is not exactly right for the $(r,\theta,\phi)$ coordinates of $(1,1,\pi)$ because

Mod[π, 2 π, -π]

gives $-\pi$, which is also an undefined value of the transformation. Try it with

CoordinateTransform["Spherical" -> "Cartesian", 
    {1, 1, Mod[π, 2 π, -π]}]

to see the error. Of course you may never see these error messages, but you could.

One way to avoid these problems is to not use the CoordinateTransform function at all. Consider the actual $(x,y,z)$ coordinates of your trajectory:

xyz = Table[{Cos[p[t]] Sin[th[t]],
     Sin[p[t]] Sin[th[t]],
     Cos[th[t]]} /. First[sol],
   {t, 0, 10, 1/10}];

We can plot these coordinates like this:

Graphics3D[{Green, Point[First[xyz]],
  Thick, Red, Line[xyz],
  Black, Point[Last[xyz]],
  Arrow[{{0, 0, -1}, {0, 0, 1}}],
  Blue, Opacity[1/5], Sphere[]}, ImageSize -> 200]

The arrow in the plot is so we can see which way is up.

The advantage of using the $(x,y,z)$ coordinates is that we do not have to worry about those what happens when $\theta$ and/or $\phi$ are "out of range".