9
$\begingroup$

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.

$\endgroup$
8
$\begingroup$

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

Mathematica graphics

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

Mathematica graphics

$\endgroup$
  • $\begingroup$ this is instructive, espMeshShading and progresses approach in question (so +1) The alternative of putting pieces together, which I used, seems easier to deal with (perhaps) unwanted 'longitude' lines, though I have to suppress the 0/2Pi seam of bottom hemisphere. :) $\endgroup$ – ubpdqn Nov 8 '14 at 2:19
  • $\begingroup$ @ubpdqn Yes, yours works pretty well with the boundary, but it's not very hard to add the lines to mine via copy/paste/edit. The problem with combining several surface plots is that often there are little gaps, bercause the points on the boundaries usually do not coincide. (It happens with yours if you set all boundaries to None. The thickness of the boundary hides the gaps.) You don't get gaps with MeshShading. (I hate that seam in the parametrized sphere - with or without the boundary. +1 to you, too) $\endgroup$ – Michael E2 Nov 8 '14 at 5:12
  • $\begingroup$ agree gaps ... trade-offs. $\endgroup$ – ubpdqn Nov 8 '14 at 5:29
  • $\begingroup$ really like 3...neat trick...always learning, btw used your ghost trails for recreation: wp.me/p1or7L-BD $\endgroup$ – ubpdqn Nov 8 '14 at 8:44
  • 1
    $\begingroup$ @ubpdqn Cool "signature"! $\endgroup$ – Michael E2 Nov 8 '14 at 15:24
5
$\begingroup$
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]

enter image description here

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]

enter image description here

$\endgroup$
2
$\begingroup$

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

enter image description here

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]

enter image description here

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

enter image description here

enter image description here

$\endgroup$
  • $\begingroup$ thank you another wonderful lesson, +1, of course:-). I should have read Mesh documentation for SphericalPlot3D...very nice $\endgroup$ – ubpdqn Nov 8 '14 at 22:19
  • $\begingroup$ thank you indeed @ubpdqn; i just learned myself, thanks to your answer and Michael's, that default MeshFunctions for SphericalPlot3D is also {#4&, #5&}. $\endgroup$ – kglr Nov 8 '14 at 22:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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