Visualising the Spherical Harmonics

hgrie, 8 Nov 2010

Plots Re and Im of the Spherical Harmonics as colours on the surface of a unit sphere.
Note: On the sphere, the Spherical Harmonics are re-scaled such that their value lies between -1 and 1; usually, their range is between -a and a, with a<1. But plotting it this way made it more "impressive". 

Legend: Prime meridian and both poles are marked.
	Figures can be rotated by left-mouse-drag.
	Meshes on both spheres and 3-d plots are choosen as 15 Degree size.

As Colours on Surface of a Sphere

Define the module to plot the function: SphericalHarmonicsPlot[l, m]

SphericalHarmonicsPlot[l_,m_]:=
Module[
{maxRe,maxIm,magRe,magIm,offsetRe,offsetIm},
If[!NumberQ[l] ∨!NumberQ[m]∨!IntegerQ[l]∨!IntegerQ[m]∨l<0∨l<Abs[m],
Print[StringForm["Value l=``, m=`` not in legitimate range. (l, m), must be integers with l≥|m|≥0. -- Exiting.",l,m]];Abort[]];
maxRe=If[l==0&&m==0,1,FindMaximum[Re[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.4}}][[1]]];
maxIm=If[m==0,1,FindMaximum[Im[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.1}}][[1]]];
magRe=1/2 1/maxRe;magIm=1/2 1/maxIm;offsetRe=maxRe;offsetIm=maxIm;
Print[StringForm["(Subscript[Y, ````])(θ,ϕ) = `` = ``  ",l,m,FullSimplify[SphericalHarmonicY[l,m,θ,ϕ]],ComplexExpand[SphericalHarmonicY[l,m,θ,ϕ]]],
Plot[0,{x,-1,1},ColorFunction->Function[{x},Hue[x]],Frame->{True,False},FrameLabel->{"Colour value (normalised to maximum of (Re,Im)[(Subscript[Y, lm])(θ,ϕ)])",None},PlotStyle->{AbsoluteThickness[50]},AspectRatio->0.2,ImageSize->330]];
GraphicsGrid[{{
Show[
SphericalPlot3D[1,{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionRe=Re[magRe(offsetRe+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionRe]]],
ColorFunctionScaling->False,
Axes->None,PlotLabel->StringForm["Re[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Re[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1},{0,0,1},{1,0,1},{1,0,-1}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9,0,0.9}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9,0,-0.9}]}]],
Show[
SphericalPlot3D[1,{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionIm=Im[magIm(I offsetIm+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionIm]]],
ColorFunctionScaling->False,
Axes->None,PlotLabel->StringForm["Im[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Im[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1},{0,0,1},{1,0,1},{1,0,-1}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9,0,0.9}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9,0,-0.9}]}]]},
{Plot3D[Re[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Re[(Subscript[Y, ````])(θ,ϕ)]",l,m]},
Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}, PerformanceGoal -> "Speed"],
Plot3D[Im[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Im[(Subscript[Y, ````])(θ,ϕ)]",l,m]},Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}, PerformanceGoal -> "Speed"]
}},ImageSize->{1000,800}]
]

Executions

SphericalHarmonicsPlot[2,1]

Contour Deformation from a Sphere to the Spherical Harmonics

Define plot which shows transition from coloured surface on sphere to Ylm: SphericalHarmonicsDeformationPlot[l, m, scale-for-Sphere, scale-for-Ylm]

SphericalHarmonicsDeformationPlot[l_,m_,scaleSphere_,scaleY_]:=
Module[
{maxRe,maxIm,magRe,magIm,offsetRe,offsetIm},
If[!NumberQ[l] ∨!NumberQ[m]∨!IntegerQ[l]∨!IntegerQ[m]∨l<0∨l<Abs[m],
Print[StringForm["Value l=``, m=`` not in legitimate range. (l, m), must be integers with l≥|m|≥0. -- Exiting.",l,m]];Abort[]];
maxRe=If[l==0&&m==0,1,FindMaximum[Re[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.4}}][[1]]];
maxIm=If[m==0,1,FindMaximum[Im[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.1}}][[1]]];
magRe=1/2 1/maxRe;magIm=1/2 1/maxIm;offsetRe=maxRe;offsetIm=maxIm;
Print[StringForm["(Subscript[Y, ````])(θ,ϕ) = `` = ``  ",l,m,FullSimplify[SphericalHarmonicY[l,m,θ,ϕ]],ComplexExpand[SphericalHarmonicY[l,m,θ,ϕ]]],
Plot[0,{x,-1,1},ColorFunction->Function[{x},Hue[x]],Frame->{True,False},FrameLabel->{"Colour value (normalised to maximum of (Re,Im)[(Subscript[Y, lm])(θ,ϕ)])",None},PlotStyle->{AbsoluteThickness[50]},AspectRatio->0.2,ImageSize->330]];
GraphicsGrid[{{
Show[
SphericalPlot3D[scaleSphere+scaleY magRe Re[SphericalHarmonicY[l,m,θ,ϕ]],{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionRe=Re[magRe(offsetRe+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionRe]]],
ColorFunctionScaling->False,PlotStyle->Directive[Opacity[0.8]],
Axes->None,PlotLabel->StringForm["Re[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Re[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed"],
SphericalPlot3D[0.98scaleSphere,{θ,0,Pi},{ϕ,0,2Pi},PlotStyle->Directive[Opacity[0.3]],Lighting->"Ambient",Mesh->None(*MeshStyle->{Opacity[0.5]}*), PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1Max[scaleSphere,scaleY maxRe]},{0,0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,-1Max[scaleSphere,scaleY maxRe]}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,0.9Max[scaleSphere,scaleY maxRe]}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,-0.9Max[scaleSphere,scaleY maxRe]}]}]],
Show[
SphericalPlot3D[scaleSphere+scaleY magIm Im[SphericalHarmonicY[l,m,θ,ϕ]],{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionIm=Im[magIm(I offsetIm+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionIm]]],
ColorFunctionScaling->False,PlotStyle->Directive[Opacity[0.8]],
Axes->None,PlotLabel->StringForm["Im[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Im[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed"],
SphericalPlot3D[0.98scaleSphere,{θ,0,Pi},{ϕ,0,2Pi},PlotStyle->Directive[Opacity[0.3]],Lighting->"Ambient",Mesh->None(*MeshStyle->{Opacity[0.5]}*), PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1Max[scaleSphere,scaleY maxRe]},{0,0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,-1Max[scaleSphere,scaleY maxRe]}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,0.9Max[scaleSphere,scaleY maxRe]}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,-0.9Max[scaleSphere,scaleY maxRe]}]}]]},
{Plot3D[Re[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Re[(Subscript[Y, ````])(θ,ϕ)]",l,m]},
Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{0.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}, PerformanceGoal -> "Speed"],
Plot3D[Im[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Im[(Subscript[Y, ````])(θ,ϕ)]",l,m]},Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{0.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}, PerformanceGoal -> "Speed"]
}},ImageSize->{1000,800}]
]

Define the functions to do the transition gradually by manipulating: SlidingSphericalHarmonicsPlot[l, m]

SlidingSphericalHarmonicsPlot[l_,m_]:=Manipulate[
Module[
{maxRe,maxIm,magRe,magIm,offsetRe,offsetIm},
If[!NumberQ[l] ∨!NumberQ[m]∨!IntegerQ[l]∨!IntegerQ[m]∨l<0∨l<Abs[m],
Print[StringForm["Value l=``, m=`` not in legitimate range. (l, m), must be integers with l≥|m|≥0. -- Exiting.",l,m]];Abort[]];
maxRe=If[l==0&&m==0,1,FindMaximum[Re[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.4}}][[1]]];
maxIm=If[m==0,1,FindMaximum[Im[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.1}}][[1]]];
magRe=1/2 1/maxRe;magIm=1/2 1/maxIm;offsetRe=maxRe;offsetIm=maxIm;
GraphicsGrid[{{Show[
SphericalPlot3D[scaleSphere+scaleY Re[SphericalHarmonicY[l,m,θ,ϕ]],{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionRe=Re[magRe(offsetRe+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionRe]]],
ColorFunctionScaling->False,PlotStyle->Directive[Opacity[0.8]],
Axes->None,PlotLabel->StringForm["Re[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Re[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed",PlotRange->All],
SphericalPlot3D[0.98scaleSphere,{θ,0,Pi},{ϕ,0,2Pi},PlotStyle->Directive[Opacity[0.4]],Lighting->"Ambient",
(*Mesh->None,*)Mesh->{11,23},MeshStyle->{{Opacity[0.4],Gray}}, PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1Max[scaleSphere,scaleY maxRe]},{0,0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,-1Max[scaleSphere,scaleY maxRe]}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,0.9Max[scaleSphere,scaleY maxRe]}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,-0.9Max[scaleSphere,scaleY maxRe]}]}]],
Show[
SphericalPlot3D[scaleSphere+scaleY Im[SphericalHarmonicY[l,m,θ,ϕ]],{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionIm=Im[magIm(I offsetIm+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionIm]]],
ColorFunctionScaling->False,PlotStyle->Directive[Opacity[0.8]],
Axes->None,PlotLabel->StringForm["Im[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Im[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed",PlotRange->All],
SphericalPlot3D[0.98scaleSphere,{θ,0,Pi},{ϕ,0,2Pi},PlotStyle->Directive[Opacity[0.4]],Lighting->"Ambient",
(*Mesh->None,*)Mesh->{11,23},MeshStyle->{{Opacity[0.4],Gray}}, PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1Max[scaleSphere,scaleY maxIm]},{0,0,1Max[scaleSphere,scaleY maxIm]},{1Max[scaleSphere,scaleY maxIm],0,1Max[scaleSphere,scaleY maxIm]},{1Max[scaleSphere,scaleY maxIm],0,-1Max[scaleSphere,scaleY maxIm]}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9Max[scaleSphere,scaleY maxIm],0,0.9Max[scaleSphere,scaleY maxIm]}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9Max[scaleSphere,scaleY maxIm],0,-0.9Max[scaleSphere,scaleY maxIm]}]}]]}},
ImageSize->800]
],
{{scaleSphere,1,"Sphere radius" (*Dynamic[StringForm["Sphere radius R= ``",Round[scaleSphere,0.1]]]*)},Union[{0.025,0.05,0.075},Table[0.1 i,{i,0,10}]]},
{{scaleY,0,StringForm["(Subscript[Y, ``]) height scaled by factor",ToString[StringForm["````",l,m]]](*Dynamic[StringForm["(Subscript[Y, lm]) height scaled by factor``",scaleY]]*)},Table[0.1 i,{i,0,10}]},
ControlPlacement->Top,ControlType->Setter,AppearanceElements->{"HideControlsButton","ResetButton","ManipulateMenu"},
FrameLabel->{GraphicsGrid[{{
Plot3D[Re[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Re[(Subscript[Y, ``])(θ,ϕ)]",ToString[StringForm["````",l,m]]]},
Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{0.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}],
Plot3D[Im[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Im[(Subscript[Y, ``])(θ,ϕ)]",ToString[StringForm["````",l,m]]]},
Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{0.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}]}},ImageSize->800,Spacings->Scaled[0.1]],
None,
Column[{StringForm["(Subscript[Y, ``])(θ,ϕ) = `` = ``",ToString[StringForm["````",l,m]],FullSimplify[SphericalHarmonicY[l,m,θ,ϕ]],ComplexExpand[SphericalHarmonicY[l,m,θ,ϕ]]],
Dynamic[StringForm["Surface parameterisation: `` + `` (Re,Im)[(Subscript[Y, ``])(θ,ϕ)]      ``",
N[Round[10scaleSphere]/10],N[Round[10scaleY]/10],ToString[StringForm["````",l,m]],
Plot[0,{x,-1,1},ColorFunction->Function[{x},Hue[x]],Frame->{True,False},FrameLabel->{StringForm["Colour value (normalised to maximum of (Re,Im)[(Subscript[Y, ``])(θ,ϕ)])",ToString[StringForm["````",l,m]]],None},
PlotStyle->{AbsoluteThickness[50]},AspectRatio->0.2,ImageSize->350]]]}],
None}]

Define the functions to do the transition gradually by manipulating, with bar for l and m: SlidingSphericalHarmonicsPlotLM

SlidingSphericalHarmonicsPlotLM:=Manipulate[
Module[
{maxRe,maxIm,magRe,magIm,offsetRe,offsetIm},
maxRe=If[l==0&&m==0,1,FindMaximum[Re[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.4}}][[1]]];
maxIm=If[m==0,1,FindMaximum[Im[SphericalHarmonicY[l,m,θ,ϕ]],{{θ,0.4},{ϕ,0.1}}][[1]]];
magRe=1/2 1/maxRe;magIm=1/2 1/maxIm;offsetRe=maxRe;offsetIm=maxIm;
GraphicsGrid[{{Show[
SphericalPlot3D[scaleSphere+scaleY Re[SphericalHarmonicY[l,m,θ,ϕ]],{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionRe=Re[magRe(offsetRe+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionRe]]],
ColorFunctionScaling->False,PlotStyle->Directive[Opacity[0.8]],
Axes->None,PlotLabel->StringForm["Re[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Re[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed",PlotRange->All],
SphericalPlot3D[0.98scaleSphere,{θ,0,Pi},{ϕ,0,2Pi},PlotStyle->Directive[Opacity[0.4]],Lighting->"Ambient",
(*Mesh->None,*)Mesh->{11,23},MeshStyle->{{Opacity[0.4],Gray}}, PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1Max[scaleSphere,scaleY maxRe]},{0,0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,1Max[scaleSphere,scaleY maxRe]},{1Max[scaleSphere,scaleY maxRe],0,-1Max[scaleSphere,scaleY maxRe]}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,0.9Max[scaleSphere,scaleY maxRe]}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9Max[scaleSphere,scaleY maxRe],0,-0.9Max[scaleSphere,scaleY maxRe]}]}]],
Show[
SphericalPlot3D[scaleSphere+scaleY Im[SphericalHarmonicY[l,m,θ,ϕ]],{θ,0,Pi},{ϕ,0,2Pi},
ColorFunction->Function[{x,y,z,θ,ϕ,r},Module[{functionIm=Im[magIm(I offsetIm+SphericalHarmonicY[l,m,θ,ϕ])]},Hue[functionIm]]],
ColorFunctionScaling->False,PlotStyle->Directive[Opacity[0.8]],
Axes->None,PlotLabel->StringForm["Im[(Subscript[Y, ````])(θ,ϕ)] = ``  ",l,m,Simplify[ComplexExpand[Im[SphericalHarmonicY[l,m,θ,ϕ]]]]],PlotPoints->40,Mesh->{11,23}, PerformanceGoal -> "Speed",PlotRange->All],
SphericalPlot3D[0.98scaleSphere,{θ,0,Pi},{ϕ,0,2Pi},PlotStyle->Directive[Opacity[0.4]],Lighting->"Ambient",
(*Mesh->None,*)Mesh->{11,23},MeshStyle->{{Opacity[0.4],Gray}}, PerformanceGoal -> "Speed"],
Graphics3D[{Opacity[0.5],Polygon[{{0,0,-1Max[scaleSphere,scaleY maxIm]},{0,0,1Max[scaleSphere,scaleY maxIm]},{1Max[scaleSphere,scaleY maxIm],0,1Max[scaleSphere,scaleY maxIm]},{1Max[scaleSphere,scaleY maxIm],0,-1Max[scaleSphere,scaleY maxIm]}}]}],
Graphics3D[{Text[Style[N,FontSize->18],{0.9Max[scaleSphere,scaleY maxIm],0,0.9Max[scaleSphere,scaleY maxIm]}]}],
Graphics3D[{Text[Style[S,FontSize->18],{0.9Max[scaleSphere,scaleY maxIm],0,-0.9Max[scaleSphere,scaleY maxIm]}]}]]}},
ImageSize->800]
],
{{l,2,"l"},Table[i,{i,0,4}]},
{{m,1,"m"},Dynamic[Table[i,{i,-l,l}]]},
{{scaleSphere,1,"Sphere radius" (*Dynamic[StringForm["Sphere radius R= ``",Round[scaleSphere,0.1]]]*)},Union[{0.025,0.05,0.075},Table[0.1 i,{i,0,10}]]},
{{scaleY,0,StringForm["(Subscript[Y, ``]) height scaled by factor",ToString[StringForm["````",l,m]]](*Dynamic[StringForm["(Subscript[Y, lm]) height scaled by factor``",scaleY]]*)},Table[0.1 i,{i,0,10}]},
ControlPlacement->Top,ControlType->Setter,AppearanceElements->{"HideControlsButton","ResetButton","ManipulateMenu"},
FrameLabel->{Dynamic[GraphicsGrid[{{
Plot3D[Re[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Re[(Subscript[Y, ``])(θ,ϕ)]",ToString[StringForm["````",l,m]]]},
Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{0.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}],
Plot3D[Im[SphericalHarmonicY[l,m,θ Degree,ϕ Degree]],{θ,0,π/Degree},{ϕ,0,2π/Degree},PlotRange->All,ColorFunction->Function[{θ,ϕ,z},Hue[z]],AxesLabel->{"θ [deg]","ϕ [deg]",StringForm["Im[(Subscript[Y, ``])(θ,ϕ)]",ToString[StringForm["````",l,m]]]},
Ticks->{Join[Table[{N[n π/6 /Degree],N[n π/6 /Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18 /Degree],,{0.01,0}},{n,0,18}]],
Join[Table[{N[n π/3/Degree],N[n π/3/Degree],{0.02,0}},{n,0,6}],Table[{N[n π/18/Degree],,{0.01,0}},{n,0,36}]],
Automatic},Mesh->{11,23}]}},ImageSize->800,Spacings->Scaled[0.1]]],
None,
Column[{Dynamic[StringForm["(Subscript[Y, ``])(θ,ϕ) = `` = ``",ToString[StringForm["````",l,m]],FullSimplify[SphericalHarmonicY[l,m,θ,ϕ]],ComplexExpand[SphericalHarmonicY[l,m,θ,ϕ]]]],
Dynamic[StringForm["Surface parameterisation: `` + `` (Re,Im)[(Subscript[Y, ``])(θ,ϕ)]      ``",
N[Round[10scaleSphere]/10],N[Round[10scaleY]/10],ToString[StringForm["````",l,m]],
Plot[0,{x,-1,1},ColorFunction->Function[{x},Hue[x]],Frame->{True,False},FrameLabel->{Dynamic[StringForm["Colour value (normalised to maximum of (Re,Im)[(Subscript[Y, ``])(θ,ϕ)])",ToString[StringForm["````",l,m]]]],None},
PlotStyle->{AbsoluteThickness[50]},AspectRatio->0.2,ImageSize->350]]]}],
None}]

Executions

SphericalHarmonicsDeformationPlot[2,0,0.1(*scaleSphere*),1(*scaleYlm*)]

SlidingSphericalHarmonicsPlot[2,1]

SlidingSphericalHarmonicsPlotLM