Multiple-colored regions on a Sphere in Mathematica

Question

The problem: I would like to draw a sphere where the bottom half is one color, and the top half is split into 3 equal regions, each with its own color.

I have come up with the following code, by following the example from drawing a line on a torus here on Stack Overflow (Plotting a contour on a torus)

yourFunc = Function[{u, v}, v - Pi/2]
yourFunc2 = Function[{u, v}, u - 4 Pi/3]
yourFunc3 = Function[{u, v}, u - 2 Pi/3]
yourFunc4 = Function[{u, v}, u - 2 Pi]

ParametricPlot3D[{
    Cos[u] Sin[v], Sin[v] Sin[u], Cos[v]
}, {
    u, 0, 2 Pi
}, {
    v, 0, Pi
}, 
MeshFunctions -> {
    Function[{x, y, z, u, v}, yourFunc[u, v]], 
    Function[{x, y, z, u, v}, yourFunc2[u, v]],
    Function[{x, y, z, u, v}, yourFunc3[u, v]], 
    Function[{x, y, z, u, v}, yourFunc4[u, v]]
},
Mesh -> {{0}},
MeshShading -> {
    {{{Red}, {Green}, {Blue}, {Yellow}}},
    {{{Orange}, {Cyan}, {Magenta}, {Black}}},
    {{{White}, {Black}, {White}, {Black}}}
},
MeshStyle -> Directive[Green, Thick],
PlotPoints -> 100, 
PlotStyle -> Opacity[3/5]
]

This will draw lines how I want it, but I have not been able to figure out how to draw each of the 4 regions with different colors. No matter how I played with it, I can only get 3. I've tried using MeshShading, as seen here, and also tried with a ColorFunction, but that didn't get me anything.

I hope that I'm making this more complicated than it has to be.

Answer 1

1. The normal mesh functions are u (#4 &) and v (#5 &). So we can just use Mesh without special mesh functions.

ParametricPlot3D[{Cos[u] Sin[v], Sin[v] Sin[u], Cos[v]}, {u, 0, 2 Pi}, {v, 0, Pi},
 Mesh -> {{0, 2 Pi/3, 4 Pi/3}, {Pi/2}}, 
 MeshShading -> 
  Map[Directive[Opacity[0.6], #] &, {{Red, Green, Blue}, {Yellow, Yellow, Yellow}}, {2}],
 MeshStyle -> Directive[Green, Thick], BoundaryStyle -> Directive[Green, Thick]]

When using MeshStyle, one also often has to set the BoundaryStyle to match. The boundary comes from the boundary of the domain of the parametrization, not of the sphere.

2. If the mesh/boundary lines in the lower half are not wanted, then the lines will have to be parameterized individually and combined with a plot of the sphere with MeshStyle -> None. Edit-- Since the question came up, here's how to do the lines just around each patch:

lines = Table[
    ParametricPlot3D[{Cos[u] Sin[v], Sin[v] Sin[u], Cos[v]},
     {v, 0, Pi/2}, PlotStyle -> Directive[Green, Thick]],
    {u, {0, 2 Pi/3, 4 Pi/3}}] ~Append~
   With[{v = Pi/2}, 
    ParametricPlot3D[{Cos[u] Sin[v], Sin[v] Sin[u], Cos[v]},
     {u, 0, 2 Pi}, PlotStyle -> Directive[Green, Thick]]];
Show[
 ParametricPlot3D[{Cos[u] Sin[v], Sin[v] Sin[u], Cos[v]},
  {u, 0, 2 Pi}, {v, 0, Pi},
  Mesh -> {{0, 2 Pi/3, 4 Pi/3}, {Pi/2}}, 
  MeshShading -> 
   Map[Directive[Opacity[0.6], #] &, {{Red, Green, Blue}, {Yellow, Yellow, Yellow}}, {2}],
  MeshStyle -> None, BoundaryStyle -> None],
 lines]
(* image essentially the same as the one below *)

3. Then for fun, a direct construction, which also isn't that hard for a sphere. Note that Partition[array, {2, 2}, {1, 1}] partitions a 2D array into quadrilaterals -- a nice trick, although it needs some flattening and reordering. It's also appropriate for our sphere.

sphere[u_, v_] := {Cos[u] Sin[v], Sin[v] Sin[u], Cos[v]};
sphericalpatch[{u1_, u2_}, {v1_, v2_}, dt_] := 
 Module[{n, pts = N@Table[sphere[u, v], {u, u1, u2, dt}, {v, v1, v2, dt}]},
  n = Length@First@pts;
  pts = Flatten[pts, 1];
  GraphicsComplex[pts,
   {Polygon[
     Flatten[
      Map[Flatten[#][[{1, 2, 4, 3}]] &, 
       Partition[Partition[Range@Length@pts, n], {2, 2}, {1, 1}], {2}], 1]
     ]},
   VertexNormals -> pts]
  ]

With[{dt = 2 Pi/48},
 Graphics3D[{Opacity[0.6], EdgeForm[],
   Red, sphericalpatch[{0, 2 Pi/3}, {0, Pi/2}, dt],
   Green, sphericalpatch[{2 Pi/3, 4 Pi/3}, {0, Pi/2}, dt],
   Blue, sphericalpatch[{4 Pi/3, 2 Pi}, {0, Pi/2}, dt],
   Yellow, sphericalpatch[{0, 2 Pi}, {Pi/2, Pi}, dt],
   Opacity[1], Green, Thick,
   Line[Table[sphere[u, #] & /@ Range[0, Pi/2, dt],
     {u, {0, 2 Pi/3, 4 Pi/3}}]],
   Line[sphere[#, Pi/2] & /@ Range[0, 2 Pi, dt]]
   }]
 ]

Answer 2

Show[SphericalPlot3D[1, ##, Mesh -> None] & @@@ 
  MapThread[{{s, Sequence @@ #1}, {t, Sequence @@ #2}, 
     PlotStyle -> #3} &, {{{0, \[Pi]/2}, {0, \[Pi]/2}, {0, \[Pi]/
      2}, {\[Pi]/2, \[Pi]}}, {{0, (2 \[Pi])/3}, {(2 \[Pi])/3, (
      4 \[Pi])/3}, {(4 \[Pi])/3, 2 \[Pi]}, {0, 2 \[Pi]}}, {Red, Green,
      Blue, Yellow}}], PlotRange -> All, Axes -> None, Boxed -> False]

or perhaps this is closer to intended final result:

Show[SphericalPlot3D[1, ##, Mesh -> None] & @@@ 
  MapThread[{{s, Sequence @@ #1}, {t, Sequence @@ #2}, 
     PlotStyle -> {#3, Opacity[0.6]}, BoundaryStyle -> #4} &,
   {{{0, \[Pi]/2}, {0, \[Pi]/2}, {0, \[Pi]/2}, {Pi/
       2, \[Pi]}}, {{0, (2 \[Pi])/3}, {(2 \[Pi])/3, (4 \[Pi])/
       3}, {(4 \[Pi])/3, 2 \[Pi]}, {0, 2 \[Pi]}}, {Red, Green, Blue, 
     Yellow}, {Directive[Green, Thick], Directive[Green, Thick], 
     Directive[Green, Thick], None}}], PlotRange -> All, 
 Axes -> False, Boxed -> False]

Answer 3

If the mesh lines are not needed, SphericalPlot can be used in a much simpler form:

sp1 = SphericalPlot3D[1, {θ, 0, π}, {ϕ, 0, 2 π}, Mesh -> {1, 2},
        MeshShading->Thread[{{Red, Blue, Yellow}, Green}], MeshStyle->None, Lighting->"Neutral"]

If you do need the mesh lines, you can do

sp2 = SphericalPlot3D[1, {θ, 0, π/2}, {ϕ, 0, 2 π}, 
        Mesh->{0, 2},  PlotStyle->None, MeshStyle->Directive[Thick, Green]]
Show[sp1, sp2]

Or, as in @ubpdqn's answer, define a function that takes 4 arguments to produce the two plots:

spF = SphericalPlot3D[1, {θ, 0, # π}, {ϕ, 0, 2 π}, Mesh -> {#2, 2}, 
       MeshStyle -> #3, MeshShading -> #4, PlotStyle -> None, Lighting -> "Neutral"] &;

args = {{1, 1, None, Thread[{{Red, Blue, Opacity[.8, Yellow]}, Green}]},
        {1/2, 0, Directive[Thick, Cyan], None}};

Show @@ spF @@@ args