Сферическая координатная графика в Mathematica

Question

Возможно ли создать графику сферической системы координат, как это в Mathematica, или мне следует использовать Photoshop? Я спрашиваю, потому что мне нужна графика высокого разрешения, но многие файлы в интернете зернистые при увеличении.

Вот изображение:

Answer 1

Фигура состоит из простых геометрических фигур, которые можно легко воссоздать в Mathematica с помощью уравнений. Вот пример, близкий к этому сюжету, в котором IMO менее загроможден, чем выше, но вы всегда можете использовать эти идеи для точного воссоздания вашего изображения.

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}}
 ]

, который дает вам это

Несмотря на то, что можно точно установить углы и стрелки, в некоторых местах (например, 13 Pi / 20) я только приблизительно их приблизил. Вы действительно не можете различить окончательную цифру, но если вы придирчивы, вы можете изменить их и точно зафиксировать позиции.

Answer 2

Преимущество этого альтернативного решения заключается в том, что он создается с использованием 3D-директив. Таким образом, было легко обернуть внутри Манипуляции, и вы можете перетащить его с помощью мыши, чтобы изменить точку обзора:

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]}]