11
$\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$
12
$\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$
8
$\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$
5
$\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$
  • $\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$ – Fırat Diker Dec 7 '19 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 Dec 7 '19 at 10:51
  • $\begingroup$ Thanks so much. $\endgroup$ – Fırat Diker Dec 7 '19 at 11:06
  • $\begingroup$ May I show a specific point on the sphere? $\endgroup$ – Fırat Diker Dec 12 '19 at 16:17
  • $\begingroup$ Yes. You can combined with Graphics3D using Show $\endgroup$ – ubpdqn Dec 12 '19 at 21:03

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.