Code: Under Construction

Easy[{x_,y_}]:= (((x-1))^2)+4 (((x-y))^2) + x - 3 y
 Fred=DownValues[Easy][[1]];
Wilma=Fred[[1]]/.Easy->List
Wilma[[1,1]]
Fred[[2]]

Wilma[[1,1]]//Length

From

FullForm[Fred]

Function Definitions

The following, defines a number of test problems for our optimization.  They all have vector first argument with an integer second argument: 0 specifies the function; 1 the first derivative; and 2 the second derivative etc.

Clear[x,y,Easy]
Easy[{x_,y_},0]:=(((x-1))^2)+4 (((x-y))^2) + x - 3 y
Do[
Easy[{x_,y_},n]=D[Easy[{x,y},n-1],{{x,y}}],
{n,1,2}
]

Clear[x,y,Rosen]
Rosen[{x_,y_},0]:=(((x-1))^2)+100(((y-(x^2)))^2)
Do[
Rosen[{x_,y_},n]=D[Rosen[{x,y},n-1],{{x,y}}],
{n,1,2}
]

Clear[x,y,SIAM]
SIAM[{x_,y_},0]:=(((x-1))^2)+100(((y-(x^2)))^2)
Do[
SIAM[{x_,y_},n]=D[SIAM[{x,y},n-1],{{x,y}}],
{n,1,2}
]

Clear[x,y,ScaledSIAM]
ScaledSIAM[{x_,y_},0]:=SIAM[{100x,y},0];
Do[
ScaledSIAM[{x_,y_},n]=D[ScaledSIAM[{x,y},n-1],{{x,y}}],
{n,1,2}
]

Testing Function Definitions

It is always a good idea to test that a derivative etc, is correct.  Here is a silly test that the derivatives are correct.

GraphicDerivativeTest[y_,p_,{ϵMin_,ϵMax_},FnList_List]:=Module[
{pn=p/Norm[p],ϵ,f,m},
Print[StringForm["Finite Difference vs Derivative Comparison 
at `` 
in direction ``",y,p]];
GraphicsGrid[
Table[
LogLogPlot[Norm[((f[y+ϵ p,m]-f[y,m])/ϵ)-f[y,m+1].p],{ϵ,ϵMin,ϵMax},
AxesLabel->{"ϵ",""},
PlotLabel->StringForm["``:m=``",f, m]
],
{f,FnList},
{m,0,1}
]
]
]

Here is a test of the code and the function definitions

n=2;
{y,p}=RandomReal[{-1,1},{2,n}];
GraphicDerivativeTest[y,p,{(10^(-12)),(10^(-3))},{Easy,Rosen,SIAM,ScaledSIAM}]

Line Search

We have a variety of different descent conditions that we want to enforce. We have a number of strategies for finding α satisfying these conditions. We want to minimize expensive gradient evaluations in these test. As a secondary goal we want to minimize function evaluations in these tests.

As a result of these golas we need to pass function and gradient values in and out of the step size selection functions.

PickAlpha[{yIn_, fIn_, DfIn_},p_,αIn_,f_,"BackTrack"]:= Module[
{α=αIn,c1TimesSlope=(10^(-4)) (DfIn.p),MSmall=0.5,yVal,fVal},
While[
Sow[α,"α"];  (* Leaves a trace of the α values that can be reclaimed using Reap *)
yVal=yIn+ α p;
fVal=f[yVal,0 ];
fVal>fIn+c1TimesSlope α,
α=MSmall*α
];
{α,fVal,f[yVal,1]}
]

PickAlpha[{yIn_, fIn_, DfIn_},p_,αIn_,f_,"Wolfe"]:= Module[
{α=αIn,c1TimesSlope=(10^(-4)) (DfIn.p),c2TimesSlope=0.9 (DfIn.p),
MSmall=0.5,MBig=1.5, Adjust,
yVal,fVal, DfVal},
While[
Sow[α,"α"];  (* Leaves a trace of the α values that can be reclaimed using Reap *)
Adjust=Which[
yVal=yIn+ α p;fVal=f[yVal,0 ];fVal>fIn+c1TimesSlope α, MSmall,
DfVal=f[yVal,1]; DfVal.p<c2TimesSlope, MBig,
True, 1]; 
Adjust≠1,
α=Adjust*α
];
{α,fVal,DfVal}
]

PickAlpha[{yIn_, fIn_, DfIn_},p_,αIn_,f_,"StrongWolfe"]:= Module[
{α=αIn,c1TimesSlope=(10^(-4)) (DfIn.p),c2TimesAbsSlope=0.9 Abs[(DfIn.p)],
MSmall=0.5,MBig=1.5, Adjust,
yVal,fVal, DfVal},
While[
Sow[α,"α"];  (* Leaves a trace of the α values that can be reclaimed using Reap *)
Adjust=Which[
yVal=yIn+ α p;fVal=f[yVal,0 ];fVal>fIn+c1TimesSlope α, MSmall,
DfVal=f[yVal,1]; Abs[DfVal.p]>c2TimesAbsSlope, MBig,
True, 1]; 
Adjust≠1,
α=Adjust*α
];
{α,fVal,DfVal}
]

n=2;
αMin=(10^(-6));
yIn=RandomReal[{-1,1},n]
f=SIAM;
fIn=f[yIn,0];
DfIn=f[yIn,1];
p=-DfIn;
αIn=1.0 (10^(-5));
c1 = (10^(-4));
{OutVals, αs}=Reap[PickAlpha[{yIn,fIn,DfIn},p,αIn,f,"StrongWolfe"],"α"]
LogLogPlot[{f[yIn + α p,0],f[yIn,0]+ α c1 DfIn.p},{α,αMin, 1.0},
PlotRange->All,
Epilog->{PointSize[0.02],
Red, Point[ Log[{αIn,fIn}]],
Blue,Point[ Log[OutVals[[{1,2}]]]]}
]

Reap[PickAlpha[{yIn,fIn,DfIn},p,αIn,f,"BackTrack"],"α"]
Reap[PickAlpha[{yIn,fIn,DfIn},p,αIn,f,"Wolfe"],"α"]
Reap[PickAlpha[{yIn,fIn,DfIn},p,αIn,f,"StrongWolfe"],"α"]