How would I modify my mathematica module to detect all minima of a polynomial with degree n?

Question

As of right now my module is able to detect the minima closest to the input point given. The module:

Newton[x0_, fun_] := Module[{der, xcurlist = {x0}, xold = x0 - 1, xcur = x0, deltax, deltay, MinimaList={} ii = 1}, 
 Monitor[While[ii++ < 1000 && xold != xcur,
   xold = xcur;
   der = (fun[xcur + .001] - fun[xcur])/.001;
   deltax = .001*Abs[der];
   deltay = -deltax*der;
   If[Abs[deltay] > .1, deltay = .1*Sign[deltay]];
   xcur = xcur + deltay;
   AppendTo[xcurlist, xcur]];, 
   xcur];
 AppendTo[MinimaList,xcurlist[[-1]]]]

The function I'm testing has 2 minima:

k[x_] := 1 - 2 x^2 + 3 x^3 + 4.7 x^4

It's plot:

(Note: my module only gets close to the minima and approximates it. This is something I'll work on fixing myself but for right now I'd like to get the module to detect both minima)

It's finding the minima by approaching the function's derivative==0 of course

Right minima:

Newton[2,k]

I get the rightmost minima approx of x~0.3004

Actual value by using FindRoot of k'[x]==0 is 0.280421

Left minima:

Newton[-1,k]

I get the left minima approx of x~-0.7637

Actual value by using FindRoot of k'[x]==0 is -0.759031

But I logically want it to detect that there are 2 minima for this polynomial, and n minima for any other degree polynomial. Once given a starting point it will run 1000 iterations until it approaches the first minima, then set the point after the minima as a new starting point and find the next one so that it gets 3 values to match the k'[x] degree. One of those 3 being the local maxima. Another obstacle is ignoring the maxima which I thought maybe an IF loop would help with by detecting whether k'[x->]<0 (x to the right of the maxima) and k'[<-x]>0 (x to the left of the maxima) would mean the point between is a local maxima and then be removed from the minima list. However I haven't gotten anything to work. Another idea is once it can detect all points where k'[x]==0 it should make 3 separate lists. Then remove the maxima. Finally with what's left we have List[[-1]] of the two lists append to the final Minima list and the minima list is the output.

So AppendTo[MinimaList,xcur[[-1]]] for each iteration at the end of the module works.

Bill Bill · Accepted Answer · 2020-05-16T03:59:28

To get all the exact minima for any polynomial may be impossible.

To get all the exact minima for your example is possible. Note replacing 4.7 with 47/10 to get exact results.

k[x_] := 1 - 2 x^2 + 3 x^3 + 47/10 x^4;
sols=Solve[D[k[x],x]==0,x]

returns

{{x -> 0}, {x -> (-45 - Sqrt[9545])/188}, {x -> (-45 + Sqrt[9545])/188}}

and

Simplify[Map[{x,Sign[D[k[x],{x,2}]]}/.#&,sols]]

returns

{{0, -1},
 {(-45 - Sqrt[9545])/188, 1},
 {(-45 + Sqrt[9545])/188, 1}}

where the first item in each list is the exact value of x where this happens, the second item is 1 for a minima or is -1 for a maxima by the second derivative test.

and

Cases[%,{_,1}]

selects only the minima and returns

{{(-45 - Sqrt[9545])/188, 1},
 {(-45 + Sqrt[9545])/188, 1}}

The decimal approximations for those exact values are

N[%]

{{-0.759035,1.},
 {0.280311,1.}}

Check this very carefully to make certain there are no mistakes and then you should be able to adapt this for use in your Module.

How would I modify my mathematica module to detect all minima of a polynomial with degree n?

1 Answers