RE: Tricky visualization of maximization problem
- To: mathgroup at smc.vnet.net
- Subject: [mg71011] RE: [mg71004] Tricky visualization of maximization problem
- From: "David Park" <djmp at earthlink.net>
- Date: Sat, 4 Nov 2006 23:07:06 -0500 (EST)
Uwe,
Here is my attempt at visualizing this.
f[x1_, x2_] := x1^2 + 4*x1*x2 + 3*x2^2
c[x1_, x2_] := x1^2 + x2^2 == 1
{maxvalue, xysols} = Maximize[{f[x, y], c[x, y]}, {x, y}]
{2 + Sqrt[5], {x -> Root[1 - 5*#1^2 + 5*#1^4 & , 2],
y -> Root[1 - 5*#1^2 + 5*#1^4 & , 1]}}
maxvalue // N
4.23607
{x, y} /. xysols // N
{-0.525731, -0.850651}
(I believe there is another maximum point near x == 1/2 and y == 0.866, but
Mathematica returns only a single global maximum point.)
I need to know the low point in the plot region to draw the projected xy
point.
Minimize[{f[x, y], -1.1 < x < 1.1 \[And] -1.1 < y < 1.1}, {x, y}]
{-0.403333, {x -> -1.1, y -> 0.733333}}
I then do the plot using DrawGraphics. I use a single color but shaded
surface using neutral lighting. The maximum point is also projected to the
the lower z plane. I used databased ticks on all three axes marking the
actual values for x, y at the maximum, and the maximum value on the z axis.
The constraint line and maximum point are raised slightly above the surface
to prevent intersecting the surface faces. There is quite a bit of detail in
the graphic.
Needs["DrawGraphics`DrawingMaster`"]
Module[{size = 1.1, zmin = -0.4, xmax, ymax, numfun, xticks, yticks,
zticks},
{xmax, ymax} = {x, y} /. xysols // N;
numfun = If[IntegerQ[#], #, NumberForm[#, {4, 3}]] &;
xticks =
CustomTicks[Identity, databased[{-1, xmax, 1}],
CTNumberFunction -> numfun];
yticks =
CustomTicks[Identity, databased[{-1, ymax, 1}],
CTNumberFunction -> numfun];
zticks = CustomTicks[Identity, databased[{0, maxvalue, 8}]];
Draw3DItems[
{(* Draw surface *)
SurfaceColor[LightSteelBlue],
EdgeForm[ColorMix[LightSteelBlue, Black][0.4]],
Draw3D[f[x, y], {x, -size, size}, {y, -size, size}],
(* Draw the constraint line *)
Black,
ImplicitDraw[c[x, y], {x, -size, size}, {y, -size, size},
PlotPoints -> 100] // RaiseTo3D[f[#1, #2] + 0.05 &],
(* Mark the maximum point *)
Red, AbsolutePointSize[6],
Point[{xmax, ymax, f[xmax, ymax] + 0.05}],
Point[{xmax, ymax, zmin}],
Black,
Line[{{xmax, -size, zmin}, {xmax, size, zmin}}],
Line[{{-size, ymax, zmin}, {size, ymax, zmin}}]},
NeutralLighting[0.2, 0.5, 0.1],
Axes -> True,
AxesLabel -> {x, y, None},
AxesEdge -> {{-1, -1}, {1, -1}, {1, 1}},
Ticks -> {xticks, yticks, zticks},
BoxRatios -> {1, 1, 1},
PlotLabel -> SequenceForm["\tMaximizing ", f[x, y], ", on ", c[x, y]],
ViewPoint -> {2.388, -1.545, 1.833},
TextStyle -> {FontSize -> 12, FontWeight -> "Bold"},
Background -> Linen,
ImageSize -> 500]
];
The following defines a single frame for an animation. For this I
parameterized the constraint equation. That might not always be so easy to
do. It was also some work to stop the animation frames from jumping. The
problem is caused because it is not directly easy to control the display
space outside of a frame or box (a serious deficiency in Mathematica
graphics). In this case I controlled the frame space by changing the integer
databased axes ticks to long blank strings. Then when the current x tick
value moves to negative values it does not push the box to the right.
frame[\[Theta]_] :=
Module[{size = 1.1, zmin = -0.4, xval, yval, xmax, ymax, numfun, xticks,
yticks, zticks},
{xval, yval} = {Cos[\[Theta]], Sin[\[Theta]]} // N;
{xmax, ymax} = {x, y} /. xysols // N;
numfun =
If[IntegerQ[#], " ",
NumberForm[#, {4, 3}, NumberPadding -> {" ", "0"}]] &;
xticks =
CustomTicks[Identity, databased[{-1, xval, 1}],
CTNumberFunction -> numfun];
yticks =
CustomTicks[Identity, databased[{-1, yval, 1}],
CTNumberFunction -> numfun];
zticks =
CustomTicks[Identity, databased[{0, f[xval, yval], 8}],
CTNumberFunction -> numfun];
Draw3DItems[
{(* Draw surface *)
SurfaceColor[LightSteelBlue],
EdgeForm[ColorMix[LightSteelBlue, Black][0.4]],
Draw3D[f[x, y], {x, -size, size}, {y, -size, size}],
(* Draw the constraint line *)
Black,
ImplicitDraw[c[x, y], {x, -size, size}, {y, -size, size},
PlotPoints -> 100] // RaiseTo3D[f[#1, #2] + 0.05 &],
(* Mark the current point *)
Red, AbsolutePointSize[6],
Point[{xval, yval, f[xval, yval] + 0.05}],
Point[{xval, yval, zmin}],
Black,
Line[{{xval, -size, zmin}, {xval, size, zmin}}],
Line[{{-size, yval, zmin}, {size, yval, zmin}}]},
NeutralLighting[0.2, 0.5, 0.1],
Axes -> True,
AxesLabel -> {x, y, None},
AxesEdge -> {{-1, -1}, {1, -1}, {1, 1}},
Ticks -> {xticks, yticks, zticks},
BoxRatios -> {1, 1, 1},
PlotRange -> {{-size, size}, {-size, size}, {zmin, 9.5}},
PlotLabel ->
SequenceForm["\tMaximizing ", f[x, y], ", on ", c[x, y]],
ViewPoint -> {2.388, -1.545, 1.833},
TextStyle -> {FontSize -> 12, FontWeight -> "Bold"},
Background -> Linen,
ImageSize -> 500]
];
The following creates the animation.
Animate[frame[\[Theta]], {\[Theta], 0, 2*Pi - 2*(Pi/48), 2*(Pi/48)}]
SelectionMove[EvaluationNotebook[], All, GeneratedCell]
FrontEndTokenExecute["OpenCloseGroup"]; Pause[0.5];
FrontEndExecute[{FrontEnd`SelectionAnimate[200, AnimationDisplayTime -> 0.1,
AnimationDirection -> Forward]}]
You can advance frame by frame to search out the maximum points. It was only
after doing the animation that I realized there were two points of global
maximum.
You could also see this by the following plot along the circle.
f[t_] = f[x, y] /. Thread[{x, y} -> {Cos[t], Sin[t]}]
Cos[t]^2 + 4*Cos[t]*Sin[t] + 3*Sin[t]^2
Plot[f[t], {t, 0, 2Pi}];
I will send the VisualizingMaximixation.gif image of the first plot to
anyone who is interested.
David Park
djmp at earthlink.net
http://home.earthlink.net/~djmp/
From: Uwe Ziegenhagen [mailto:newsgroup at ziegenhagen.info]
To: mathgroup at smc.vnet.net
Hi,
I want to maximize
x1^2 + 4*x1*x2 + 3*x2^2 (eq.1)
under the constraint
x1^2 + x2^2 == 1 (eq. 2)
So far no problem, Maximize gives me 2 + sqrt(5)
But how can I display this visually?
For eq. 1 I can use Plot3D[], for eq. 2 ImplicitPlot[] but how to have
them in one picture?
Thanks in advance,
Uwe