11
$\begingroup$

I looked but haven't found an answer to this one: I'd like to create a region that represents a sector of a ball, bounded between radii $r_1$ and $r_2$, polar angles $\theta_1$ and $\theta_2$, and azimuthal angles $\varphi_1$ and $\varphi_2$. There seems to be no built-in functionality to achieve this directly. Do I have to assemble the region from parametric surfaces representing the spherical parts of the boundary, and trapezoids for the plane parts?

$\endgroup$
1

3 Answers 3

15
$\begingroup$
sphericalSegment[{r1_, r2_}, {θ1_, θ2_}, {ϕ1_, ϕ2_}] := 
 Module[{plot, pts, surf, bdy},
  plot = ParametricPlot3D[{Cos[θ] Sin[ϕ], Sin[θ] Sin[ϕ], Cos[ϕ]},
    {θ, θ1, θ2}, {ϕ, ϕ1, ϕ2}, 
    Mesh -> None, BoundaryStyle -> Black];
  pts = First@Cases[plot, GraphicsComplex[p_, ___] :> p, Infinity];
  surf = First@Cases[plot, Polygon[p_] :> p, Infinity];
  bdy = First@Cases[plot, Line[p_] :> p, Infinity];
  GraphicsComplex[
   Join[r1*pts, r2*pts],
   {EdgeForm[],
    Polygon[surf], Polygon[Reverse /@ surf + Length@pts],
    Polygon[Join[#, Reverse@# + Length@pts], 
       VertexNormals -> Cross[Subtract @@ pts[[#]], pts[[First@#]]]] & /@ 
     Partition[bdy, 2, 1, 1]},
   VertexNormals -> Join[-pts, pts]
   ]
  ]

Graphics3D[
 sphericalSegment[{0.95, 1.1}, {0, Pi/3}, {Pi/6, Pi/2}]
 ]

Mathematica graphics

$\endgroup$
7
  • $\begingroup$ Awesome solution, thanks! $\endgroup$
    – Pirx
    Sep 11, 2016 at 4:26
  • $\begingroup$ +1, but how did you know that you had to write Reverse /@ surf rather than just surf? $\endgroup$
    – C. E.
    Sep 11, 2016 at 10:54
  • 1
    $\begingroup$ @C.E. (1) I've done it many times, so I do it without thinking. Sometimes I wonder if it's always necessary, but I do it anyway. (2) Polygons have an orientation (e.g. used by FaceForm[]). Reversing the points reverses the orientation. Note the VertexNormals are reversed, too (negatives of each other). I think if r1 > r2, you'll still get a good-looking segment, but with the notions of inside/outside reversed. $\endgroup$
    – Michael E2
    Sep 11, 2016 at 13:08
  • $\begingroup$ ok, good to know. Thanks. $\endgroup$
    – C. E.
    Sep 11, 2016 at 21:20
  • 1
    $\begingroup$ @Adam Add at the end before the last } and after Partition[bdy, 2, 1, 1]: {Black, Thick, Line[bdy], Line[bdy + Length@pts], Line[Transpose@{#, # + Length@pts} &@Flatten@Nearest[pts -> "Index", Flatten[Table[{Cos[θ] Sin[ϕ], Sin[θ] Sin[ϕ], Cos[ϕ]}, {θ, {θ1, θ2}}, {ϕ, {ϕ1, ϕ2}}], 1]]]} $\endgroup$
    – Michael E2
    Dec 3, 2020 at 3:43
5
$\begingroup$

Definition of the region:

reg := (r1^2 <= x^2 + y^2 + z^2 <= r2^2 && (* conditions on radius *)
        θ1 <= ArcTan[z, Sqrt[x^2 + y^2]] <=  θ2 && (* conditions on polar angle *)
        φ1 <= ArcTan[x, y] <= φ2 (* conditions on azimuthal angle *)
        );

Definition of the parameters:

{r1, r2, θ1, θ2, φ1, φ2} = {2, 2.2, 30°, 180°, 15°, 85°};

Plots:

RegionPlot3D[ImplicitRegion[reg, {x, y, z}],
             PlotPoints -> 80, Boxed -> False, ViewAngle -> 20°]

spherical sector

RegionPlot3D[reg, {x, -2.5, 2.5}, {y, -2.5, 2.5}, {z, -2.5, 2.5}, Axes -> False, 
             PlotPoints -> 80, Boxed -> False, ViewAngle -> 20°, Mesh -> None]

spherical sector

$\endgroup$
3
  • $\begingroup$ Much more compact code, but RegionPlot is often somewhat "rough around the edges". I think there's a trick to get this to look better by going through DiscretizedRegion somehow. Too tired to look it up now, but that might work. Overall your code above is quite elegant, thanks! $\endgroup$
    – Pirx
    Sep 11, 2016 at 4:29
  • 2
    $\begingroup$ @Pirx, you might want to see this. $\endgroup$ Dec 11, 2016 at 3:12
  • $\begingroup$ Ahah, very nice. Thanks! $\endgroup$
    – Pirx
    Dec 11, 2016 at 4:11
4
$\begingroup$

The NURBS representation of a spherical sector is particularly convenient, and has the advantage of not having to carry too many Polygon[] objects:

sphericalSegment[{r1_, r2_}, {θ1_, θ2_}, {φ1_, φ2_}] /; r1 < r2 :=
         Module[{cknots = {0, 0, 0, 1, 1, 1}, lknots = {0, 0, 1, 1},
                 θa = θ2 - θ1, φa = φ2 - φ1, a1, a2, cp, cθ, cφ, p1, p2, ws, wθ, wφ},
                cθ = Cos[θa/2]; cφ = Cos[φa/2];
                a1 = {Cos[θ1], Sin[θ1]}; a2 = {Cos[θ2], Sin[θ2]};
                p1 = {Sin[φ1] , Cos[φ1]}; p2 = {Sin[φ2], Cos[φ2]};
                cp = Map[Function[pt, Append[#1 pt, #2]],
                         {a1, Normalize[(a1 + a2)/2]/cθ, a2}] & @@@
                     {p1, Normalize[(p1 + p2)/2]/cφ, p2};
                ws = Outer[Times, {1, cφ, 1}, {1, cθ, 1}];
                wθ = Outer[Times, {1, 1}, {1, cθ, 1}];
                wφ = Outer[Times, {1, 1}, {1, cφ, 1}];
                {BSplineSurface[r1 Reverse[cp, 2], SplineDegree -> 2,
                                SplineKnots -> {cknots, cknots}, SplineWeights -> ws],
                 BSplineSurface[Outer[Times, {r1, r2}, cp[[1]], 1], SplineDegree -> {1, 2},
                                SplineKnots -> {lknots, cknots}, SplineWeights -> wθ],
                 BSplineSurface[Outer[Times, {r1, r2}, Reverse[cp[[All, 1]]], 1],
                                SplineDegree -> {1, 2}, SplineKnots -> {lknots, cknots},
                                SplineWeights -> wφ], 
                 BSplineSurface[Outer[Times, {r1, r2}, cp[[All, -1]], 1],
                                SplineDegree -> {1, 2}, SplineKnots -> {lknots, cknots},
                                SplineWeights -> wφ],
                 BSplineSurface[Outer[Times, {r1, r2}, Reverse[cp[[-1]]], 1],
                                SplineDegree -> {1, 2}, SplineKnots -> {lknots, cknots},
                                SplineWeights -> wθ],
                 BSplineSurface[r2 cp, SplineDegree -> 2,
                                SplineKnots -> {cknots, cknots}, SplineWeights -> ws]}]

Some examples:

Graphics3D[{EdgeForm[], sphericalSegment[{9/10, 1}, {0, π/3}, {π/6, π/2}]}]

a spherical segment

Graphics3D[{EdgeForm[], sphericalSegment[{9/10, 1}, {π/3, 3 π/4}, {π/2, π}]}]

another spherical segment

$\endgroup$
6
  • $\begingroup$ P. S. If needed, one can add BaseStyle -> {BSplineSurface3DBoxOptions -> {Method -> {"SplinePoints" -> 40}}}, similar to what was done here. $\endgroup$ Dec 11, 2016 at 3:24
  • $\begingroup$ Can this be used to generate arbitrary spherical polygon for given vertices? (I just don't have time to investigate :)) If you want I will ask an official question. $\endgroup$
    – Kuba
    Apr 19, 2017 at 20:31
  • $\begingroup$ @Kuba, no, this is only good for making spherical quadrilaterals, or isosceles spherical triangles. Making an arbitrary spherical polygon with NURBS looks tough, from what I've researched. $\endgroup$ Apr 20, 2017 at 0:58
  • $\begingroup$ Thanks. That's a pity. Does the fact that I don't care about very precise approximation changes anything? $\endgroup$
    – Kuba
    Apr 20, 2017 at 13:54
  • $\begingroup$ @Kuba, you might want to look at this thread in the meantime; someday, when I find time, I'll try implementing the NURBS method for spherical polygons. $\endgroup$ Apr 20, 2017 at 13:59

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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