1
$\begingroup$

I need to find the maxima and minima of a function. I managed this analytically with no problem, but now I need to show in a graphic the intersection of the functions.

My function is:

f[x_, y_] := x^3 - x*y + y^2 +3

And the restriction : x^2 + 2*y^2 == 1

$\endgroup$
3
  • 3
    $\begingroup$ Bad English is endemic here, so don't worry. But we try to get good questions. Please post the code you already tried! $\endgroup$ – Dr. belisarius Dec 10 '14 at 21:41
  • $\begingroup$ Welcome to Mathematica.SE! I suggest the following: 1) As you receive help, try to give it too, by answering questions in your area of expertise. 2) Read the faq! 3) When you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge. Also, please remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign! $\endgroup$ – Dr. belisarius Dec 10 '14 at 21:41
  • 3
    $\begingroup$ "Sorry for my bad english" <-- You can start by trying to use proper capitalization ("I" vs "i") and including some punctuation. Yes, these things really make a difference in how easy it is to understand your question. $\endgroup$ – Szabolcs Dec 10 '14 at 21:51
5
$\begingroup$

Since your title refers to Lagrange optimization, I'm guessing you're seeking to find the maximum and minimum of a function f[x,y] subject to a constraint g[x,y]=0.

f[x_, y_] := x^3 - x*y + y^2 + 3;

g[x_, y_] := x^2 + 2*y^2 - 1;

myConstraintEq = Solve[g[x, y] == 0, {x, y}] // Quiet;

Show[

  Plot3D[f[x, y], {x, -2, 2}, {y, -2, 2}, PlotStyle -> Opacity[0.5]],

  Graphics3D[{
    {Red, PointSize[0.03], 
    Point[{x, y, f[x, y]} /. Last@FindMaximum[{f[x, y], g[x, y] == 0}, {x, y}]]}, 
    {Blue, PointSize[0.03], 
    Point[{x, y, f[x, y]} /. Last@FindMinimum[{f[x, y], g[x, y] == 0}, {x, y}]]}}],

  ParametricPlot3D[{
    {x, yy = y /. myConstraintEq[[1]], f[x, yy]}, 
    {x, yy = y /. myConstraintEq[[2]], f[x, yy]}}, 
    {x, -2, 2}, PlotStyle -> Green]

]

Lagrange image

$\endgroup$
5
  • 1
    $\begingroup$ Just an aesthetic comment: {x, y, f[x, y]} /. Last@FindMaximum[{f[x, y], g[x, y] == 0}, {x, y}] is nicer :) $\endgroup$ – Dr. belisarius Dec 11 '14 at 1:18
  • 1
    $\begingroup$ Yes... More elegant. I've changed the code accordingly. Thanks. $\endgroup$ – David G. Stork Dec 11 '14 at 3:03
  • $\begingroup$ Thanks for the help, but I have a tiny doubt if analytically i got 4 critical points the graphic should not display 4 points? $\endgroup$ – Inti Dec 11 '14 at 17:11
  • $\begingroup$ And maybe if it helps when asked the professors he told us use 3 variables like f[x,y,z] = z - f[x,y]. And sorry for no display the code T_T m still very noob in use the forum xD $\endgroup$ – Inti Dec 11 '14 at 17:13
  • $\begingroup$ There are likely four solutions where the derivative is zero, but only one MAXIMUM, one MINIMUM, and two INFLECTION POINTS. You can see this if you plot just the green curve alone. $\endgroup$ – David G. Stork Dec 13 '14 at 5:31
4
$\begingroup$

This is a corrected version of poor quality post I originally posted.

This is to classify the extreme values using Lagrange multiplier method. The bordered Hessian for 2D case with one constraint is calculated. Projections onto x-z and y-z plane are used just to show the minima and maxima (local and global for constraint):

f[x_, y_] := x^3 - x*y + y^2 + 3
g[x_, y_] := x^2 + 2*y^2
l[x_, y_, m_] := f[x, y] - m (g[x, y] - 1)
cp = Solve[Grad[l[x, y, m], {x, y, m}] == 0, {x, y, m}, Reals];
cph = N[{x, y, m} /. cp];
pnt = {#1, #2, f[#1, #2]} & @@@ cph;
p3 = Plot3D[f[x, y], {x, -2, 2}, {y, -2, 2}, Mesh -> None, 
   PlotStyle -> Opacity[0.6]];
pp = ParametricPlot3D[{Cos[t], Sin[t]/Sqrt[2], 
    f[Cos[t], Sin[t]/Sqrt[2]]}, {t, 0, 2 Pi}];
borhf[u_, v_, w_] := 
 Module[{gg = Grad[g[x, y], {x, y}], hs = D[l[x, y, m], {{x, y}, 2}]},
  Normal@SparseArray[{{1, 1} -> 
       0, {1, 2} -> -gg[[1]], {1, 3} -> -gg[[2]], {2, 
        1} -> -gg[[1]], {3, 1} -> -gg[[2]], 
      Sequence @@ 
       Flatten@MapThread[#1 -> #2 &, {Table[{i, j}, {i, 2, 3}, {j, 2, 
            3}], hs}, 2]}, {3, 3}] /. {x -> u, y -> v, m -> w}]
class = Sign[-Det[#] & /@ (borhf @@@ cph)];
classt = Thread[{pnt, class}];
sort = SortBy[classt, #[[1, 3]] &];
max = sort[[1, 1]];
min = sort[[-1, 1]];
rules = {-1 :> Red, 1 :> Purple};
classp = class /. rules;
gp = GroupBy[classt, Last -> First];
g3 = Graphics3D[({#2 /. rules, PointSize[0.04], Point[#1]} & @@@ 
      sort)~Join~{PointSize[0.02], Yellow, Point[{min, max}]}];
sf[x_, r_] := Style[x, r /. rules];
grd = Grid[{{"Point", "Sign Det Bordered Hessian"}}~
    Join~({sf[#1, #2], sf[#2, #2]} & @@@ sort), Alignment -> Left, 
   Frame -> All, BaseStyle -> {FontFamily -> "Kartika"}, 
   Background -> {None, {None, Yellow, None, None, Yellow}}];
pleg = PointLegend[{Purple, Purple, Red, Red}, {"Min", "Local Min", 
    "Local Max", "Max"}, 
   LegendMarkers -> {Graphics[{PointSize[0.04], Purple, 
       Disk[{0, 0}, 0.2], PointSize[0.02], Yellow, 
       Disk[{0, 0}, 0.1]}], Automatic, Automatic, 
     Graphics[{PointSize[0.04], Red, Disk[{0, 0}, 0.2], 
       PointSize[0.02], Yellow, Disk[{0, 0}, 0.1]}]}];
im1 = Framed@
   Legended[Show[p3, pp, g3, ImageSize -> 300], 
    Placed[Column[{pleg, grd}], Below]]'
xz[t_] := {Cos[t], f[Cos[t], Sin[t]/Sqrt[2]]};
yz[t_] := {Sin[t]/Sqrt[2], f[Cos[t], Sin[t]/Sqrt[2]]};
pp1 = ParametricPlot[xz[t], {t, 0, 2 Pi}, 
   Epilog -> {{#2 /. rules, PointSize[0.04], Point[#1[[{1, 3}]]]} & @@@
       classt, {PointSize[0.02], Yellow, 
      Point[{min[[{1, 3}]], max[[{1, 3}]]}]}}, 
   PlotRange -> {{-2, 2}, {1.5, 4.5}}, Frame -> True, 
   PlotLabel -> "Projection onto x-z plane", ImageSize -> 200];
pp2 = ParametricPlot[yz[t], {t, 0, 2 Pi}, 
   Epilog -> {{#2 /. rules, PointSize[0.04], Point[#1[[{2, 3}]]]} & @@@
       classt, {PointSize[0.02], Yellow, 
      Point[{min[[{2, 3}]], max[[{2, 3}]]}]}}, 
   PlotRange -> {{-2, 2}, {1.5, 4.5}}, Frame -> True, 
   PlotLabel -> "Projection onto y-z plane", ImageSize -> 200];
im2 = Framed@Legended[Row[{pp1, pp2}], Placed[pleg, Below]]

enter image description here

enter image description here

Note:

You can plot f and constraint in one plot using MeshFunctions:

Show[Plot3D[f[x, y], {x, -3, 3}, {y, -3, 3}, 
  MeshFunctions -> (#1^2 + 2 #2^2 &), Mesh -> {{1}}, 
  MeshStyle -> Blue], g3]

enter image description here

$\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.