Return to Answer

added 411 characters in body

edited Apr 7, 2012 at 17:58

32.6k
3
105
164

Here are a few comments

First, I believe that you have switched the roles of $\phi$ and $\theta$ in your first definition. Thus, a slight edit of your code yields the following

pts = Apply[{ArcCos[2 #2 - 1], 2 #1*Pi} &, RandomReal[1, {10000, 2}], 1]; pts3D = {Sin[#[[1]]]*Cos[#[[2]]], Sin[#[[1]]]*Sin[#[[2]]], Cos[#[[1]]]} & /@ pts; Graphics3D[Point[pts3D]]

Now, pts3D is already a nice uniform distribution on the sphere. Is this all you want??

NextIf you do need to go through the energy minimization, then you can use FindMinimum since it does allow the variables to be tensors, soand your original find minimumFindMinimum command is fine. The problem is that you haven't restricted your definition of energy to work only with numeric values. Thus, you can minimize the energy (with compilation for speed) like so:

Clear[energy];energy1[p:{{_?NumericQ,_?NumericQ}..}] := Module[{cart}, pts  cart = Apply[{ArcCos[2Sin[#1]*Cos[#2], #2Sin[#1]*Sin[#2], -Cos[#1]} 1]&, 2p, #1*Pi}1]; Total[Outer[Exp[-Norm[#1 - #2]] &, RandomReal[1cart, {10cart, 2}]1], 1];2] pts3D]; cEnergy2 = Compile[{Sin[#[[1]]]*Cos[#[[2]]]{p,_Real,2}},Module[{cart},  Sin[#[[1]]]*Sin[#[[2]]] cart = Map[{Sin[#[[1]]]*Cos[#[[2]]],   Sin[#[[1]]]*Sin[#[[2]]],Cos[#[[1]]]} &, /@p, pts;1]; energy[p: Sum[Exp[-Sqrt[(u-v).(u-v)]],{u,cart},{_?NumericQv,cart}] ], CompilationTarget -> "C", RuntimeOptions -> "Speed"]; energy2[p:{{_?NumericQ, _?NumericQ} ..}] := cEnergy2[p];  Total[Outer[Exp[-Norm[#1 SeedRandom[1]; pts=Apply[{ArcCos[2 #2- #2]]1], 2#1*Pi}&, pRandomReal[1, p{20, 1]2}], 2];1]; FindMinimum[energy[p]FindMinimum[energy2[p], {p, pts3Dpts}]//AbsoluteTiming FindMinimum[energy1[p],{p,pts}]//AbsoluteTiming

I think this produces the result that you want. Speed

Note that I've used compilation in to speed up the code by a factor of nearly twenty on my machine. But the time complexity is still an issuesuch that even 100 points is out of reach.

Here are a few comments

First, I believe that you have switched the roles of $\phi$ and $\theta$ in your first definition. Thus, a slight edit of your code yields the following

pts = Apply[{ArcCos[2 #2 - 1], 2 #1*Pi} &, RandomReal[1, {10000, 2}], 1]; pts3D = {Sin[#[[1]]]*Cos[#[[2]]], Sin[#[[1]]]*Sin[#[[2]]], Cos[#[[1]]]} & /@ pts; Graphics3D[Point[pts3D]]

Now, pts3D is already a nice uniform distribution on the sphere.

Next, FindMinimum does allow the variables to be tensors, so your original find minimum command is fine. The problem is that you haven't restricted your definition of energy to work only with numeric values. Thus, you can minimize the energy like so:

Clear[energy]; pts = Apply[{ArcCos[2 #2 - 1], 2 #1*Pi} &, RandomReal[1, {10, 2}], 1]; pts3D = {Sin[#[[1]]]*Cos[#[[2]]], Sin[#[[1]]]*Sin[#[[2]]], Cos[#[[1]]]} & /@ pts; energy[p:{{_?NumericQ, _?NumericQ, _?NumericQ} ..}] :=  Total[Outer[Exp[-Norm[#1 - #2]] &, p, p, 1], 2]; FindMinimum[energy[p], {p, pts3D}]

I think this produces the result that you want. Speed is still an issue.

Here are a few comments

First, I believe that you have switched the roles of $\phi$ and $\theta$ in your first definition. Thus, a slight edit of your code yields the following

pts = Apply[{ArcCos[2 #2 - 1], 2 #1*Pi} &, RandomReal[1, {10000, 2}], 1]; pts3D = {Sin[#[[1]]]*Cos[#[[2]]], Sin[#[[1]]]*Sin[#[[2]]], Cos[#[[1]]]} & /@ pts; Graphics3D[Point[pts3D]]

Now, pts3D is already a nice uniform distribution on the sphere. Is this all you want??

If you do need to go through the energy minimization, then you can use FindMinimum since it does allow the variables to be tensors, and your original FindMinimum command is fine. The problem is that you haven't restricted your definition of energy to work only with numeric values. Thus, you can minimize the energy (with compilation for speed) like so:

energy1[p:{{_?NumericQ,_?NumericQ}..}] := Module[{cart},   cart = Apply[{Sin[#1]*Cos[#2], Sin[#1]*Sin[#2], Cos[#1]} &, p, 1]; Total[Outer[Exp[-Norm[#1 - #2]] &, cart, cart, 1], 2] ]; cEnergy2 = Compile[{{p,_Real,2}},Module[{cart},   cart = Map[{Sin[#[[1]]]*Cos[#[[2]]],   Sin[#[[1]]]*Sin[#[[2]]],Cos[#[[1]]]} &, p, 1];  Sum[Exp[-Sqrt[(u-v).(u-v)]],{u,cart},{v,cart}] ], CompilationTarget -> "C", RuntimeOptions -> "Speed"]; energy2[p:{{_?NumericQ,_?NumericQ}..}] := cEnergy2[p];  SeedRandom[1]; pts=Apply[{ArcCos[2 #2-1], 2#1*Pi}&,RandomReal[1,{20,2}],1]; FindMinimum[energy2[p],{p,pts}]//AbsoluteTiming FindMinimum[energy1[p],{p,pts}]//AbsoluteTiming

I think this produces the result that you want.

Note that I've used compilation in to speed up the code by a factor of nearly twenty on my machine. But the time complexity is such that even 100 points is out of reach.

Source Link

answered Apr 7, 2012 at 17:19

Mark McClure

32.6k
3
105
164

Here are a few comments

First, I believe that you have switched the roles of $\phi$ and $\theta$ in your first definition. Thus, a slight edit of your code yields the following

pts = Apply[{ArcCos[2 #2 - 1], 2 #1*Pi} &, RandomReal[1, {10000, 2}], 1]; pts3D = {Sin[#[[1]]]*Cos[#[[2]]], Sin[#[[1]]]*Sin[#[[2]]], Cos[#[[1]]]} & /@ pts; Graphics3D[Point[pts3D]]

Now, pts3D is already a nice uniform distribution on the sphere.

Clear[energy]; pts = Apply[{ArcCos[2 #2 - 1], 2 #1*Pi} &, RandomReal[1, {10, 2}], 1]; pts3D = {Sin[#[[1]]]*Cos[#[[2]]], Sin[#[[1]]]*Sin[#[[2]]], Cos[#[[1]]]} & /@ pts; energy[p:{{_?NumericQ, _?NumericQ, _?NumericQ} ..}] := Total[Outer[Exp[-Norm[#1 - #2]] &, p, p, 1], 2]; FindMinimum[energy[p], {p, pts3D}]

I think this produces the result that you want. Speed is still an issue.