Drawing circular patches around arbitrary points on a sphere

Here is a routine that renders a spherical cap on a unit sphere as a NURBS surface:

sphericalCap[{θ_, φ_}, α_] := With[{c = Cos[α/2]},
         Style[BSplineSurface[Map[RotationTransform[{{0, 0, 1}, 
                                  Append[{Cos[θ], Sin[θ]} Sin[φ], Cos[φ]]}], 
               Map[Function[pt, Append[#1 pt, #2]],
                   {{1, 0}, {1, 1}, {-1, 1}, {-1, 0}, {-1, -1}, {1, -1}, {1, 0}}] & @@@
                   {{0, 1}, {Sin[α/2]/c, 1}, {Sin[α], Cos[α]}}], 
               SplineClosed -> {False, True}, SplineDegree -> 2, 
               SplineKnots -> {{0, 0, 0, 1, 1, 1},
                               {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1}}, 
               SplineWeights -> Outer[Times, {1, c, 1}, {1, 1/2, 1/2, 1, 1/2, 1/2, 1}]], 
               BSplineSurface3DBoxOptions -> {Method -> {"SplinePoints" -> 25}}]]

Examples:

Graphics3D[{Opacity[0.7, Black], sphericalCap[{0, 0}, π/6]}, Axes -> True]

an inky cap

BlockRandom[SeedRandom["spherecaps"];
            Graphics3D[{EdgeForm[], Table[{Append[RandomColor[], 2/3], 
                        sphericalCap[{RandomReal[{0, 2 π}], RandomReal[{0, π}]}, 
                                     RandomReal[{0, π/4}]]}, {10}]}]]

various colored spherical caps

Graphics3D[{Directive[EdgeForm[], GrayLevel[1/5],
                      Glow[Blend[{Brown, Yellow}, 1/4]], Specularity[Gray, 25]], 
            sphericalCap[{ArcTan @@ Most[#], ArcCos[Last[#]]},
                         ArcCos[(80 + 9 Sqrt[5])/109]/2] & /@ 
            N[PolyhedronData["TruncatedIcosahedron", "VertexCoordinates"]/
              PolyhedronData["TruncatedIcosahedron", "Circumradius"]]}, 
           Boxed -> False, Lighting -> "Neutral"]

spherical caps on a truncated icosahedron


Show[
 SphericalPlot3D[1, {θ, 0, π}, {ϕ, 0, 2 π}, Mesh -> None,  RegionFunction -> 
        Function[{x, y, z, θ, ϕ, r}, Norm[{x, y, z} - {1, 1, 0}] > 1], PlotStyle -> Red], 
 SphericalPlot3D[1, {θ, 0, π}, {ϕ, 0, 2 π}, Mesh -> None, RegionFunction -> 
        Function[{x, y, z, θ, ϕ, r}, Norm[{x, y, z} - {1, 1, 0}] < 1], PlotStyle -> Blue]]

Mathematica graphics


Here's a way using MeshFunctions and MeshShading that generalized to any number of points.

pts = Normalize /@ RandomReal[{-1, 1}, {2, 3}];
angles = Table[{Pi/3}, Length@pts];
SphericalPlot3D[1, {θ, 0, Pi}, {ϕ, 0, 2 Pi}, 
 MeshFunctions -> 
  Table[With[{v0 = v0}, 
    Function[{x, y, z, θ, ϕ}, 
     VectorAngle[{x, y, z}, v0]]], {v0, pts}],
 Mesh -> angles,
 MeshShading -> {{Black, Black}, {Black, Automatic}},
 BoundaryStyle -> None]

Mathematica graphics

More random points, random angles:

SeedRandom[7];
pts = Normalize /@ RandomReal[{-1, 1}, {3, 3}];
angles = RandomReal[0.66, {Length@pts, 1}];
shading = ReplacePart[
   ConstantArray[Black, Table[2, Length@pts]], 
   Table[-1, Length@pts] -> Automatic];
SphericalPlot3D[1, {θ, 0, Pi}, {ϕ, 0, 2 Pi},
 PlotPoints -> 50, 
 MeshFunctions -> 
  Table[With[{v0 = v0}, 
    Function[{x, y, z, θ, ϕ}, 
     VectorAngle[{x, y, z}, v0]]], {v0, pts}],
 Mesh -> angles,
 MeshShading -> shading,
 BoundaryStyle -> None, MeshStyle -> None]

Mathematica graphics