# Density plot on the surface of a sphere

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.

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]


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]


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]


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


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


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


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