High-Dimensional Nelder-Mead Optimization.

The Nelder-Mead algorithm is implemented in Mathematica as the function "NMinimize". We now give a simple application of the Nelder-Mead algorithm for a high-dimensional problem: finding minimal length networks connecting a family of vertices, some of which can be moved. 

First, we take a random collection of points in the unit square.

NPoints = 30;

IPts = RandomReal[{0,1},{NPoints,2}];

pplot = ListPlot[IPts,PlotStyle->Directive[PointSize[Large]]]

We now need the computational geometry package:

<<ComputationalGeometry`

We now want to plot our points and find their perimeter. The ``outside'' points belong to what's called the convex hull of our point set. We'll fix the positions of these points.

FixedPoints = ConvexHull[IPts];
VariablePoints = Complement[Range[NPoints],FixedPoints];

Triangulation = DelaunayTriangulation[IPts];

PointPlot[IPts_,FixedPoints_,VariablePoints_,Triangulation_] := {ListPlot[IPts[[FixedPoints]],PlotStyle->Directive[PointSize[Large],Blue]],
ListPlot[IPts[[VariablePoints]],PlotStyle->Directive[PointSize[Large],Red]],PlanarGraphPlot[IPts,Triangulation,LabelPoints->False]};

VarPlot[Vars_] := Module[{NewIPts},
NewIPts = IPts;
NewIPts[[VariablePoints]] = Partition[Vars,2];
PointPlot[NewIPts,FixedPoints,VariablePoints,Triangulation]
];

Show[PointPlot[IPts,FixedPoints,VariablePoints,Triangulation]]

We now add up all the distances between nodes in this graph.

NetworkLength [Pts_] := Sum[Sum[EuclideanDistance[Pts[[Triangulation[[i,1]]]],Pts[[Triangulation[[i,2,j]]]]],{j,1,Length[Triangulation[[i,2]]]}],{i,1,Length[Triangulation]}];

NetworkLength[IPts]

Our model high-dimensional problem will be to minimize NetworkLength over the possible positions of points given by VariablePoints. To do that, we need a version of the objective function which explicitly depends only on those variables. We write

f[VarPts_] :=Module[{NewIPts},
NewIPts = IPts;
NewIPts[[VariablePoints]] = Partition[VarPts,2];
NetworkLength[NewIPts]
]; 

f[Flatten[IPts[[VariablePoints]]]]

The last check shows that we are correctly evaluating things. We now call NMinimize with the Nelder-Mead code selected. We will keep track of the intermediate positions, which requires a little bit of hackery using Sow and Reap.

NewVars = Table[Symbol["a" <>ToString[i]],{i,1,Length[Flatten[IPts[[VariablePoints]]]]}];

We first try a numerical version of gradient descent (a very sophisticated "quasi-Newton" algorithm programmed into Mathematica which approximates derivatives and even Hessians of functions given without derivatives).

FMEvaluations = 0;
FMSteps = Reap[FindMinimum[f[NewVars],Transpose[{NewVars,Flatten[IPts[[VariablePoints]]]}],StepMonitor:> Sow[NewVars],EvaluationMonitor:>FMEvaluations++,MaxIterations->1000,AccuracyGoal->2]];
FMEvaluations

Here's the network length for the solution:

FMSteps[[1,1]]

We now try good old Nelder-Mead on the same problem.

NMEvaluations= 0;NMSteps = Reap[NMinimize[f[NewVars],NewVars,EvaluationMonitor:>NMEvaluations++,StepMonitor:> Sow[NewVars],Method->"NelderMead"]];
NMEvaluations

Here's the network length for the solution:

NMSteps[[1,1]]

Let's see the results for each method. We start with quasi-Newton:

Manipulate[Show[VarPlot[FMSteps[[2,1,i]]],PlotRange->{{0,1},{0,1}}],{i,1,Length[FMSteps[[2,1]]],1}]

And now we look at Nelder-Mead.

Manipulate[Show[VarPlot[NMSteps[[2,1,i]]],PlotRange->{{0,1},{0,1}}],{i,1,Length[NMSteps[[2,1]]],1}]