7

I am doing a brute force search for "gradient extremals" on the following example function

fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;

This involves finding the following zeros

gecond = With[{g = D[fv[{x, y}], {{x, y}}], h = D[fv[{x, y}], {{x, y}, 2}]},
 g.RotationMatrix[Pi/2].h.g == 0]

Which Reduce happily does for me:

geyvals = y /. Cases[List@ToRules@Reduce[gecond, {x, y}], {y -> _}];

geyvals is the three roots of a cubic polynomial, but the expression is a bit large to put here.

Now to my question: For different values of x, different numbers of these roots are real, and I would like to pick out the values of x where the solutions branch in order to piece together the gradient extremals along the valley floor (of fv). In the present case, since the polynomial is only cubic, I could probably do it by hand -- but I am looking for a simple way of having Mathematica do it for me?

Edit: To clarify: The gradient extremals stuff is just background -- and a simple way to set up a hard problem. I am not so interested in the specific solution to this problem as in a general hand-off way of spotting the branch points for polynomial roots. Have added an answer below with a working approach.

Edit 2: Since it seems that the actual problem is much more fun than root branching: rcollyer suggests using ContourPlot directly on gecond to get the gradient extremals. To make this complete we need to separate valleys and ridges, which is done by looking at the eigenvalue of the Hessian perpendicular to the gradient. Putting a check for "valleynes" in as a RegionFunction we are left with only the valley line:

valleycond = With[{
    g = D[fv[{x, y}], {{x, y}}], 
    h = D[fv[{x, y}], {{x, y}, 2}]},
  g.RotationMatrix[Pi/2].h.RotationMatrix[-Pi/2].g >= 0];
gbuf["gevalley"]=ContourPlot[gecond // Evaluate, {x, -2, 4}, {y, -.5, 1.2},
   RegionFunction -> Function[{x, y}, Evaluate@valleycond], 
   PlotPoints -> 41];

Which gives just the valley floor line. Including some contours and the saddle point:

fvSaddlept = {x, y} /. First@Solve[Thread[D[fv[{x, y}], {{x, y}}] == {0, 0}]]
gbuf["contours"] = ContourPlot[fv[{x, y}],
   {x, -2, 4}, {y, -.7, 1.5}, PlotRange -> {0, 1/2},
   Contours -> fv@fvSaddlept (Range[6]/3 - .01),
   PlotPoints -> 41, AspectRatio -> Automatic, ContourShading -> None];
gbuf["saddle"] = Graphics[{Red, Point[fvSaddlept]}];
Show[gbuf /@ {"contours", "saddle", "gevalley"}]

We end up with a plot like this:

Contour plot of fv with the valley line superposed

10
  • I did this by hand a few times, so +1. Hope someone find a way. Dec 14, 2010 at 5:36
  • @belisarius. Exactly -- have done it a few times, and it is a nuisance. This tim I can't be bothered since I really only need the result for a plot where, to be completely honest, a simple guess would look fine... Let's hope somebody has a clever idea :)
    – Janus
    Dec 14, 2010 at 6:37
  • @Janus, forgive my ignorance, but how does gecond give you the extremals? I'm just not seeing it.
    – rcollyer
    Dec 15, 2010 at 17:19
  • 1
    @Janus, nevermind. I found a paper that discusses them, specifically eqn 3.3 of springerlink.com/content/1432-881x/69/4 matches gecond exactly.
    – rcollyer
    Dec 15, 2010 at 17:46
  • @rcollyer: Thanks for the reference: I have hit a few reaction potential articles, but this issue seems to be a nice collection. It's actually trivial once you realize that the GE condition is equivalent to requiring the gradient to be an eigenvector of the curvature. I actually came from that direction and only found the work on 'gradient extremals' after having done quite a bit of rediscovery. J. Math. Phys. 23p732 has a nice coordinate-free discussion, but the topic goes back to Maxwell and Cayley :)
    – Janus
    Dec 16, 2010 at 5:01

4 Answers 4

5

Not sure if this (belatedly) helps, but it seems you are interested in discriminant points, that is, where both polynomial and derivative (wrt y) vanish. You can solve this system for {x,y} and throw away complex solutions as below.

fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;

gecond = With[{g = D[fv[{x, y}], {{x, y}}], 
   h = D[fv[{x, y}], {{x, y}, 2}]}, g.RotationMatrix[Pi/2].h.g]

In[14]:= Cases[{x, y} /. 
  NSolve[{gecond, D[gecond, y]} == 0, {x, y}], {_Real, _Real}]

Out[14]= {{-0.0158768, -15.2464}, {1.05635, -0.963629}, {1., 
  0.0625}, {1., 0.0625}}
1
  • Thanks, Daniel! You are right, these are exactly the points I was chasing -- catches both the branch-points and root crossings: For a parametrized polynomial P(a,x), the a-values where the roots branch or cross are exactly the a-values with a multiple root, so that P(a,x)==0 and dP(a,x)/dx=0.
    – Janus
    Jan 14, 2011 at 5:26
3

If you only want to plot the result then use StreamPlot[] on the gradients:

grad = D[fv[{x, y}], {{x, y}}];
StreamPlot[grad, {x, -5, 5}, {y, -5, 5}, 
           RegionFunction -> Function[{x, y}, fv[{x, y}] < 1],
           StreamScale -> 1]

You may have to fiddle around with the plot's precision, StreamStyle, and the RegionFunction to get it perfect. Especially useful would be using the solution for the valley floor to seed StreamPoints programmatically.

1
  • Thanks, Timo. The problem with streamplot is that the 'fall-lines', as the resulting lines are known, are mathematically guaranteed to diverge from the stationary paths (the gradient extremes), see e.g. J. Math. Phys. 23p732. Especially so in the interesting regions :) Also: I have a nice algorithm for finding the valley -- this question was more about the root branching.
    – Janus
    Dec 15, 2010 at 1:01
3

Updated: see below.

I'd approach this first by visualizing the imaginary parts of the roots:

plot of the imaginary parts of the roots

This tells you three things immediately: 1) the first root is always real, 2) the second two are the conjugate pairs, and 3) there is a small region near zero in which all three are real. Additionally, note that the exclusions only got rid of the singular point at x=0, and we can see why when we zoom in:

zoom in of above photo with x between 0 and 1.5

We can then use the EvalutionMonitor to generate the list of roots directly:

Map[Module[{f, fcn = #1}, 
            f[x_] := Im[fcn];
            Reap[Plot[f[x], {x, 0, 1.5}, 
                  Exclusions -> {True, f[x] == 1, f[x] == -1}, 
                  EvaluationMonitor :> Sow[{x, f[x]}][[2, 1]] // 
            SortBy[#, First] &];]
   ]&, geyvals]

(Note, the Part specification is a little odd, Reap returns a List of what is sown as the second item in a List, so this results in a nested list. Also, Plot doesn't sample the points in a straightforward manner, so SortBy is needed.) There may be a more elegant route to determine where the last two roots become complex, but since their imaginary parts are piecewise continuous, it just seemed easier to brute force it.

Edit: Since you've mentioned that you want an automatic method for generating where some of the roots become complex, I've been exploring what happens when you substitute in y -> p + I q. Now this assumes that x is real, but you've already done that in your solution. Specifically, I do the following

In[1] := poly = g.RotationMatrix[Pi/2].h.g /. {y -> p + I q} // ComplexExpand;
In[2] := {pr,pi} = poly /. Complex[a_, b_] :> a + z b & // CoefficientList[#, z] & //
         Simplify[#, {x, p, q} \[Element] Reals]&;

where the second step allows me to isolate the real and imaginary parts of the equation and simplify them independent of each other. Doing this same thing with the generic 2D polynomial, f + d x + a x^2 + e y + 2 c x y + b y^2, but making both x and y complex; I noted that Im[poly] = Im[x] D[poly, Im[x]] + Im[y] D[poly,[y]], and this may hold for your equation, also. By making x real, the imaginary part of poly becomes q times some function of x, p, and q. So, setting q=0 always gives Im[poly] == 0. But, that does not tell us anything new. However, if we

In[3] := qvals = Cases[List@ToRules@RReduce[ pi == 0 && q != 0, {x,p,q}], 
          {q -> a_}:> a];

we get several formulas for q involving x and p. For some values of x and p, those formulas may be imaginary, and we can use Reduce to determine where Re[qvals] == 0. In other words, we want the "imaginary" part of y to be real and this can be accomplished by allowing q to be zero or purely imaginary. Plotting the region where Re[q]==0 and overlaying the gradient extremal lines via

With[{rngs = Sequence[{x,-2,2},{y,-10,10}]},
Show@{
 RegionPlot[Evaluate[Thread[Re[qvals]==0]/.p-> y], rngs],
 ContourPlot[g.RotationMatrix[Pi/2].h.g==0,rngs 
      ContourStyle -> {Darker@Red,Dashed}]}]

gives

x-y plot showing gradient extremals and region where there are 3 real roots

which confirms the regions in the first two plots showing the 3 real roots.

5
  • I like the idea about using the built-in logic of Plot to zoom in on the key points. Playing around with it, it seems to take some post processing to spot the sharp bends.
    – Janus
    Dec 15, 2010 at 7:11
  • +1 for massive effort! And a tickmark for simply contour plotting gecond: it is not strictly an answer to the root branching -- but it is a clever solution to my actual problem. Have added some extra background on valleys/ridges to my question.
    – Janus
    Dec 17, 2010 at 2:30
  • @janus, If I knew I'd get the checkmark for plotting the extremals, I would have done it much, much sooner. :)
    – rcollyer
    Dec 17, 2010 at 2:56
  • I agree it's not quite kosher to checkmark for a not-strictly-an-answer, but it doesn't seem as if anybody else is working on the root branching and I really never thought about just doing the ContourPlot, so it did solve my actual problem...
    – Janus
    Dec 17, 2010 at 5:05
  • @Janus, don't worry about it. He nailed it while Iwas just taking a stab in the dark. so, not a worry.
    – rcollyer
    Jan 14, 2011 at 20:27
0

Ended up trying myself since the goal really was to do it 'hands off'. I'll leave the question open for a good while to see if anybody finds a better way.

The code below uses bisection to bracket the points where CountRoots changes value. This works for my case (spotting the singularity at x=0 is pure luck):

In[214]:= findRootBranches[Function[x, Evaluate@geyvals[[1, 1]]], {-5, 5}]
Out[214]= {{{-5., -0.0158768}, 1}, {{-0.0158768, -5.96046*10^-9}, 3}, {{0., 0.}, 2}, {{5.96046*10^-9, 1.05635}, 3}, {{1.05635, 5.}, 1}}

Implementation:

Options[findRootBranches] = {
   AccuracyGoal -> $MachinePrecision/2,
   "SamplePoints" -> 100};

findRootBranches::usage = 
  "findRootBranches[f,{x0,x1}]: Find the the points in [x0,x1] \
  where the number of real roots of a polynomial changes.
  Returns list of {<interval>,<root count>} pairs.
  f: Real -> Polynomial as pure function, e.g f=Function[x,#^2-x&]." ; 

findRootBranches[f_, {xa_, xb_}, OptionsPattern[]] := Module[
  {bisect, y, rootCount, acc = 10^-OptionValue[AccuracyGoal]},
  rootCount[x_] := {x, CountRoots[f[x][y], y]};

  (* Define a ecursive bisector w/ automatic subdivision *)
  bisect[{{x1_, n1_}, {x2_, n2_}} /; Abs[x1 - x2] > acc] := 
   Module[{x3, n3},
    {x3, n3} = rootCount[(x1 + x2)/2];
    Which[
     n1 == n3, bisect[{{x3, n3}, {x2, n2}}],
     n2 == n3, bisect[{{x1, n1}, {x3, n3}}],
     True, {bisect[{{x1, n1}, {x3, n3}}], 
      bisect[{{x3, n3}, {x2, n2}}]}]];

  (* Find initial brackets and bisect *)
  Module[{xn, samplepoints, brackets},
   samplepoints = N@With[{sp = OptionValue["SamplePoints"]},
      If[NumberQ[sp], xa + (xb - xa) Range[0, sp]/sp, Union[{xa, xb}, sp]]];
   (* Start by counting roots at initial sample points *)
   xn = rootCount /@ samplepoints;
   (* Then, identify and refine the brackets *)
   brackets = Flatten[bisect /@ 
      Cases[Partition[xn, 2, 1], {{_, a_}, {_, b_}} /; a != b]];
   (* Reinclude the endpoints and partition into same-rootcount segments: *)
   With[{allpts = Join[{First@xn}, 
       Flatten[brackets /. bisect -> List, 2], {Last@xn}]},
    {#1, Last[#2]} & @@@ Transpose /@ Partition[allpts, 2]
    ]]]
2
  • -1: This doesn't spot the cases where two roots cross each other.
    – Janus
    Dec 15, 2010 at 7:12
  • Ok, so finding the precise location of a root crossing is very doable, since Mathematica can do series expansions of root objects: x/.First@Solve[0==Normal@Quiet@Series[r1-r2,{x,x0,1}],x]. Now, how to spot potential crossings is not so obvious...
    – Janus
    Dec 16, 2010 at 6:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.