Sphere Point Picking

Author

Eric W. Weisstein
March 30, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComputationalGeometry/SpherePointPicking.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/SpherePointPicking.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Initialization

<<Graphics`Shapes`;
<<Graphics`Graphics`;

SpherePlot[pts_,vp_]:=Module[{i,j},
Show[GraphicsArray[Table[Graphics3D[{PointSize[.03],pts[[i]],
EdgeForm[RGBColor[.5,0,0]],FaceForm[GrayLevel[1],GrayLevel[1]],Sphere[.99]},AspectRatio->Automatic,Boxed->False,Lighting->False,ViewPoint->vp[[j]]],{j,2},{i,3}]
],GraphicsSpacing->-.2]
]

Comparing Uniform and Nonuniform

SphericalNonUniformDistribution[num_]:=Table[{Cos[#1]Sin[#2],Sin[#1]Sin[#2],Cos[#2]}&[Random[Real,{0,2Pi}],Random[Real,{0,Pi}]],{num}]

SphericalDistribution[num_]:=Table[{Cos[#1]Sqrt[1-#2^2],Sin[#1]Sqrt[1-#2^2],#2}&[Random[Real,{0,2Pi}],Random[Real,{-1,1}]],{num}]

g={
PointSize[.01],Point/@SphericalNonUniformDistribution[10000],
{EdgeForm[RGBColor[.5,0,0]],FaceForm[GrayLevel[1],GrayLevel[1]],Sphere[.99]}
};

g2={
PointSize[.01],Point/@SphericalDistribution[10000],
{EdgeForm[RGBColor[.5,0,0]],FaceForm[GrayLevel[1],GrayLevel[1]],Sphere[.99]}
};

Show[GraphicsArray[
{
Graphics3D[g,Lighting->False,Boxed->False,ViewPoint->{0,0,2}],
Graphics3D[g,Lighting->False,Boxed->False,ViewPoint->{2,0,0}],Graphics3D[g2,Lighting->False,Boxed->False,ViewPoint->{0,0,2}],
Graphics3D[g2,Lighting->False,Boxed->False,ViewPoint->{2,0,0}]
}
],GraphicsSpacing->-.2]

u=cos ϕ

ParametricPlot3D[{Sqrt[1-u^2]Cos[v],Sqrt[1-u^2]Sin[v],u},{v,-Pi,Pi},{u,-1,1},Boxed->False,Axes->False,Method->{"ShrinkWrap"->True},ImageSize->Small]

UTheta[num_]:=Table[{Sqrt[1-#1^2]Cos[#2],Sqrt[1-#1^2]Sin[#2],#1}&[Random[Real,{-1,1}],Random[Real,{0,2π}]],{num}]

SpherePlot[(Point/@UTheta[#]&)/@{100,1000,5000},{{1.3,-2.4,2.},{0,0,2}}]//Timing

Marsaglia Method

Marsaglia[n_]:=Module[{pts=Select[Table[Random[Real,{-1,1}],{n},{2}],#.#<=1&]},
{2#1Sqrt[1-#1^2-#2^2],2#2Sqrt[1-#1^2-#2^2],1-2(#1^2+#2^2)}&@@@pts
]

SpherePlot[(Point/@Marsaglia[#]&)/@{100,1000,5000},{{1.3,-2.4,2.},{0,0,2}}]//Timing

Cook Method

Cook[n_]:=Module[{pts=Select[Table[Random[Real,{-1,1}],{n},{4}],#.#<=1&]},
{2(#2#4+#1#3),2(#3#4-#1#2),#1^2+#4^2-#2^2-#3^2}/(#1^2+#2^2+#3^2+#4^2)&@@@pts
]

SpherePlot[(Point/@Cook[#]&)/@{100,1000,5000},{{1.3,-2.4,2.},{0,0,2}}]//Timing

Distribution of Polar Angle

Histogram[ArcCos[2#-1]&/@Table[Random[Real],{10000}]]

FullSimplify[D[ArcCos[2v-1],v]]

PowerExpand[Simplify[1/D[ArcCos[2v-1],v]/.v->(Cos[ϕ]+1)/2]]

Plot[Sin[ϕ]/2,{ϕ,0,π}]

Integrate[Sin[ϕ]/2,{ϕ,0,π}]

FullSimplify[Integrate[1/2 Sin[ϕ],{ϕ,0,π}]]

FullSimplify[Integrate[ϕ Sin[ϕ]/2,{ϕ,0,π}]]

N[%]

FullSimplify[Integrate[ϕ^2Sin[ϕ]/2,{ϕ,0,π}]]

N[%]

data=ArcCos[2#-1]&/@Table[Random[Real],{50000}];

1/Length[data]Plus@@data

1/Length[data]Plus@@(data^2)