6
$\begingroup$

Thanks to my previous question I have plotted the function with the following code:

a[x_, y_] := (x^2 - 3 - 9*y)^2 + 50*y^2
ParametricPlot3D[{x, #, a[x, #]} & /@ {0, 2, 4, 6, 8, 10, 12}, {x, -13, 13}, 
  BoxRatios -> 1, ImageSize -> 350, Boxed -> False]

Now I want to join the minima. How should I proceed?

$\endgroup$
10
$\begingroup$
a[x_, y_] := (x^2 - 3 - 9*y)^2 + 50*y^2

Plot3D with MeshFunctions

Using a single Plot3D with multiple MeshFunctions:

Plot3D[a[x, y], {x, -13, 13}, {y, -.001, 12.1},
 PlotStyle -> Opacity[.5], BoundaryStyle -> None, Boxed -> False, BoxRatios -> 1,
 MeshFunctions -> {#2 &, 
          ConditionalExpression[Derivative[1, 0][a][#, #2], Derivative[2, 0][a][#, #2] > 0] &}, 
 Mesh -> {{0, 2, 4, 6, 8, 10, 12}, {0}},
 MeshStyle -> Dynamic@{Directive[{Thick, Hue[RandomReal[]]}],
    {Directive[{Gray, Thick}], Directive[{Gray, Thick}]}} ]

enter image description here

Plot3D with Exclusions:

Plot3D[a[x, y], {x, -13, 13}, {y, -.001, 12.1}, Boxed -> False, BoxRatios -> 1, 
 Exclusions -> {ConditionalExpression[Derivative[1, 0][a][x, y], 
                Derivative[2, 0][a][x, y] > 0]},
 ExclusionsStyle -> Red, ColorFunction -> Hue,
 PlotStyle -> Opacity[.5], BoundaryStyle -> None, 
 MeshFunctions -> {#2 &}, Mesh -> {{0, 2, 4, 6, 8, 10, 12}},
 MeshStyle -> {Directive[{Thick, Hue[RandomReal[]]}]} ]

enter image description here

ParametricPlot3D

soln = y /. Assuming[{x > -1/3},
    FullSimplify[Solve[{ConditionalExpression[Derivative[1, 0][a][y, x],
          Derivative[2, 0][a][y, x] > 0] == 0, x > -1/3}, y]]];

$\left\{-\sqrt{9 x+3},\sqrt{9 x+3}\right\}$

b[x_] := {#, x, a[#, x]} & /@ soln

{ $\left\{-\sqrt{9 x+3},x,50 x^2\right\}$, $ \left\{\sqrt{9 x+3},x,50 x^2\right\} $}

ParametricPlot3D[{b[x], {x, #, a[x, #]} & /@ {0, 2, 4, 6, 8, 10, 12}},
 {x, -13, 13},  PlotStyle -> {Thickness[.01], Thick},
 ColorFunction -> Hue, Boxed -> False, BoxRatios -> 1]

enter image description here

| improve this answer | |
$\endgroup$
7
$\begingroup$

Because the local minima in $x$ are the zeros of the $x$-derivative, you could do something like this:

Plot3D[a[x, y], {x, -13, 13}, {y, 0, 12}, 
 MeshFunctions -> {Derivative[1, 0][a]}, Mesh -> {{0}}]

enter image description here

This also includes the local maxima, but you can get rid of them by requiring the second derivative in $x$ to be positive. Then we remove the surface itself, and we have the lines you want:

Plot3D[a[x, y], {x, -13, 13}, {y, 0, 12}, 
 MeshFunctions -> {Derivative[1, 0][a]}, Mesh -> {{0}}, 
 RegionFunction -> (Derivative[2, 0][a][##] > 0 &),
 PlotStyle -> None, BoundaryStyle -> None]

enter image description here

Use Show to put it together with the original plot.

enter image description here


The nice thing is that it still works when minima can appear and disappear:

Show[Plot3D[a[x, y], {x, -13, 13}, {y, -6, 12}, Mesh -> None, 
  BoxRatios -> 1, PlotStyle -> Opacity[0.6]], 
 Plot3D[a[x, y], {x, -13, 13}, {y, -6, 12}, 
  MeshFunctions -> {Derivative[1, 0][a]}, Mesh -> {{0}}, 
  RegionFunction -> (Derivative[2, 0][a][#1, #2] > 0 &), 
  PlotStyle -> None, BoundaryStyle -> None, ClippingStyle -> None]]

enter image description here

| improve this answer | |
$\endgroup$
4
$\begingroup$

You can determine the minima with

pts = Transpose[Module[{yy = #, sol1, sol2},
     sol1 = FindMinimum[a[x, yy], {x, -13}];
     sol2 = FindMinimum[a[x, yy], {x, 13}];
     {{sol1[[2, 1, 2]], yy, sol1[[1]]}, {sol2[[2, 1, 2]], yy, 
       sol2[[1]]}}
     ] & /@ {0, 2, 4, 6, 8, 10, 12}]

and then show them together with your original plot

    Show[ParametricPlot3D[{x, #, a[x, #]} & /@ {0, 2, 4, 6, 8, 10, 12}, {x, -13, 13}, 
          BoxRatios -> 1, ImageSize -> 350, Boxed -> False], 
         Graphics3D[{Red, Line[pts[[1]]]}], 
         Graphics3D[{Red, Line[pts[[2]]]}]
        ]

enter image description here

| improve this answer | |
$\endgroup$
4
$\begingroup$

If I got you right, you want to plot two lines going through the minimums. If yes, try the following:

This makes the lists of the points of minimums:

 a[x_, y_] := (x^2 - 3 - 9*y)^2 + 50*y^2 ;
lstA = (NMinimize[{a[x, #], x < 11}, x] & /@ {0, 2, 4, 6, 8, 10, 
      12}) /. {c_, {Rule[a_, b_]}} -> {b, c};
lstB = (NMinimize[{a[x, #], x > -11 && x <= 0}, x] & /@ {0, 2, 4, 6, 
      8, 10, 12}) /. {c_, {Rule[a_, b_]}} -> {b, c};
lst3A = Transpose[{Transpose[lstA][[1]], {0, 2, 4, 6, 8, 10, 12}, 
    Transpose[lstA][[2]]}];
lst3B = Transpose[{Transpose[lstB][[1]], {0, 2, 4, 6, 8, 10, 12}, 
    Transpose[lstB][[2]]}];

and this makes a plot:

    Show[{

  ParametricPlot3D[{x, #, a[x, #]} & /@ {0, 2, 4, 6, 8, 10, 
     12}, {x, -13, 13}, BoxRatios -> 1, ImageSize -> 350, 
   Boxed -> False],
  Graphics3D[{Red, Thickness[0.003], Line[lst3A], Green, 
    Thickness[0.003], Line[lst3B]}]

  }]

which is shown below:

enter image description here

Have fun!

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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