12
$\begingroup$

I would like to do it on the surface of a sphere instead of a plane:

RegionPlot[{1/
4 (-4 Sqrt[5]
    Cos[x]^2 + (-5 + 3 Sqrt[5]) (1 - 3 Cos[2 y]) Sin[
    x]^2 + (-5 - Sqrt[5] + (-5 + 3 Sqrt[5]) Cos[2 y]) Sin[x]^2 + 
  4 (-5 + 3 Sqrt[5]) Cos[y] Sin[2 x]) < -3, 1/4 (-4 Sqrt[5] Cos[x]^2 + (-5 + 3 Sqrt[5]) (1 - 3 Cos[2 y]) Sin[x]^2 + (-5 - Sqrt[5] + (-5 + 3 Sqrt[5]) Cos[2 y]) Sin[x]^2 + 4 (-5 + 3 Sqrt[5]) Cos[y] Sin[2 x]) >= -3}, {x, 0, Pi}, {y, 0, 2*Pi}, Frame -> False, ImagePadding -> 0 , PlotRangePadding -> None, PlotPoints -> 35, PlotStyle -> {Red, Gray},   PlotLegends -> {"Contextual Region", "Classical Region"}]

Can you help me? Thanks.

$\endgroup$
0

3 Answers 3

13
$\begingroup$

Here is an alternative way.

SliceContourPlot3D[f[x, y], "CenterSphere", {x, 0, \[Pi]}, {y, 0, 2 \[Pi]}, {z, 0, 1}, 
 ColorFunction -> (If[# < 0, Red, Gray] &), 
 ColorFunctionScaling -> False, PlotPoints -> 100, 
 PlotLegends -> Automatic]

enter image description here

If you like you can use ContourStyle -> Opacity[0]

SliceContourPlot3D[f[x, y], "CenterSphere", {x, 0, \[Pi]}, {y, 0, 2 \[Pi]}, {z, 0, 1}, 
 ColorFunction -> (If[# < 0, Red, Gray] &), 
 ColorFunctionScaling -> False, ContourStyle -> Opacity[0], 
 PlotPoints -> 100, PlotLegends -> Automatic]

enter image description here

$\endgroup$
9
$\begingroup$
rp = RegionPlot[{1/4 (-4 Sqrt[5] Cos[x]^2 + 
     (-5 + 3 Sqrt[5]) (1 - 3 Cos[2 y]) Sin[x]^2 +
     (-5 - Sqrt[5] + (-5 + 3 Sqrt[5]) Cos[2 y]) Sin[x]^2 +
     4 (-5 + 3 Sqrt[5]) Cos[y] Sin[2 x]) < -3, 
    1/4 (-4 Sqrt[5] Cos[x]^2 + 
     (-5 + 3 Sqrt[5]) (1 - 3 Cos[2 y]) Sin[x]^2 + 
     (-5 - Sqrt[5] + (-5 + 3 Sqrt[5]) Cos[2 y]) Sin[x]^2 +
     4 (-5 + 3 Sqrt[5]) Cos[y] Sin[2 x]) >= -3},
  {x, 0, Pi}, {y, 0, 2*Pi}, Frame -> False, ImagePadding -> 0, 
   PlotRangePadding -> None, PlotPoints -> 35, PlotStyle -> {Red, Gray}];

ParametricPlot3D[{Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}, {v, 0, Pi}, {u, 0, 2 Pi}, 
 PlotStyle -> Texture[Image @ rp], 
 TextureCoordinateFunction -> ({#, #2} &), 
 Lighting -> "Neutral", 
 Mesh -> None]

enter image description here

$\endgroup$
6
$\begingroup$

I may have misinterpreted the question. The x and y ranges suggest spherical coordinates. So, for the sake of clarification,:

f[x_, y_] := 
 1/4 (-4 Sqrt[
      5] Cos[x]^2 + (-5 + 3 Sqrt[5]) (1 - 3 Cos[2 y]) Sin[x]^2 + (-5 -
        Sqrt[5] + (-5 + 3 Sqrt[5]) Cos[2 y]) Sin[x]^2 + 
    4 (-5 + 3 Sqrt[5]) Cos[y] Sin[2 x])
p3 = Plot3D[f[x, y], {x, 0, Pi}, {y, 0, 2 Pi}, ColorFunction -> Hue, 
   MeshFunctions -> {#1 &, #2 &}, Mesh -> 10, ImageSize -> 200];
cp = ContourPlot[f[x, y], {x, 0, Pi}, {y, 0, 2 Pi}, 
   ColorFunction -> Hue, ImageSize -> 200];
max = NMaximize[f[x, y], {x, y}][[1]];
min = NMinimize[f[x, y], {x, y}][[1]];
rs = Rescale[f[#1, #2], {min, max}] &;
tab = Transpose@
   Table[{Hue[Rescale[j, {min, max}]], j}, {j, min, max, 0.1}];
pp = ParametricPlot3D[{Sin[u] Cos[v], Sin[u] Sin[v], Cos[u]}, {u, 0, 
    Pi}, {v, 0, 2 Pi}, ColorFunction -> (Hue[rs[#4, #5]] &), 
   ColorFunctionScaling -> False, MeshFunctions -> {#4 &, #5 &}, 
   Mesh -> {10, 10}, MeshStyle -> Directive[{Thick, Black}], 
   PlotPoints -> 200, 
   PlotLegends -> BarLegend[{tab[[1]], {min, max}}, tab[[2]]], 
   ImageSize -> 200];
Row[{cp, p3, pp}]

enter image description here

Update Further answer in relation to comment:

ParametricPlot3D[{Sin[u] Cos[v], Sin[u] Sin[v], Cos[u]}, {u, 0, 
  Pi}, {v, 0, 2 Pi}, 
 ColorFunction -> (If[f[#4, #5] < -3, Red, Gray] &), 
 ColorFunctionScaling -> False, Mesh -> None, Axes -> False, 
 Boxed -> False, Background -> Black, PlotPoints -> 200, 
 ImageSize -> 200]
ContourPlot[f[x, y], {x, 0, Pi}, {y, 0, 2 Pi}, Contours -> {-3}, 
 ContourShading -> {Red, Gray}]

enter image description here

Update

Further to another comment. The PlotPoints have been reduced to facilitate interactivity (further reductions reduce quality of plot).

Manipulate[Module[{pp =
    ParametricPlot3D[s[u, v], {u, 0, Pi}, {v, 0, 2 Pi}, 
     ColorFunction -> (If[f[#4, #5] < -3, Red, Gray] &), 
     ColorFunctionScaling -> False, Mesh -> None, Axes -> False, 
     Boxed -> False, Background -> Black, PlotPoints -> 75, 
     ImageSize -> 200], cp},
  Row[{ContourPlot[f[x, y], {x, 0, Pi}, {y, 0, 2 Pi}, 
     Contours -> {-3}, ContourShading -> {Red, Gray}, 
     Epilog -> {PointSize[0.04], Point[pt]}, ImageSize -> 200],
    Show[pp, 
     Graphics3D[{Yellow, PointSize[.04], 
       Point[s @@ pt]}]]}]], {{pt, {Pi/2, Pi}}, {0, 0}, {Pi, 2 Pi}}, 
 Initialization :> (f[x_, y_] := 
    1/4 (-4 Sqrt[
         5] Cos[x]^2 + (-5 + 3 Sqrt[5]) (1 - 3 Cos[2 y]) Sin[
          x]^2 + (-5 - Sqrt[5] + (-5 + 3 Sqrt[5]) Cos[2 y]) Sin[
          x]^2 + 4 (-5 + 3 Sqrt[5]) Cos[y] Sin[2 x]);
   s[u_, v_] := {Sin[u] Cos[v], Sin[u] Sin[v], Cos[u]};)]

enter image description here

$\endgroup$
4
  • $\begingroup$ Yes, x and y are spherical coordinates. What I'd really like to do is to see a region plot on the surface of a sphere. This plot should depend on x and y values. Coloring should include two colors depending on whether the function is above or below -3. $\endgroup$ Commented Dec 7, 2019 at 10:48
  • 1
    $\begingroup$ @FiratDiker I plotted this like this to show the contours and how they ‘fold’ onto sphere. The show different regions compared with the provided answers. I’ll post your requirement when I have time. $\endgroup$
    – ubpdqn
    Commented Dec 7, 2019 at 10:51
  • $\begingroup$ May I show a specific point on the sphere? $\endgroup$ Commented Dec 12, 2019 at 16:17
  • $\begingroup$ Yes. You can combined with Graphics3D using Show $\endgroup$
    – ubpdqn
    Commented Dec 12, 2019 at 21:03

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.