In short:
I have a 2-D function that gives this plot, where the orange dots are maxima:
There are 4 maxima in this plot.
Now, I plot the function again in a smaller region, close to these maxima, resulting in this :
So, one of the maxima turned out to be fake.
How can I change the main code to better extremise the function (when it is on a larger area, like the first picture) and not return false maxima?
Thanks so much.
Code:
k = 2 π;
k1 = {k, 0};
k2 = FullSimplify[RotationMatrix[(2 π)/5]. k1];
k3 = FullSimplify[RotationMatrix[(2 π)/5]. k2];
k4 = FullSimplify[RotationMatrix[(2 π)/5] .k3];
k5 = FullSimplify[RotationMatrix[(2 π)/5] .k4];
E1[x_, y_, I1_, α1_] := Sqrt[I1] Exp[I k1.{x, y} - α1]
E2[x_, y_, I1_, α1_] := Sqrt[I1] Exp[I k2.{x, y} - α1]
E3[x_, y_, I1_, α1_] := Sqrt[I1] Exp[I k3.{x, y} - α1]
E4[x_, y_, I1_, α1_] := Sqrt[I1] Exp[I k4.{x, y} - α1]
E5[x_, y_, I1_, α1_] := Sqrt[I1] Exp[I k5.{x, y} - α1]
Eges[x_, y_] :=
E1[x, y, 1, 0] + E2[x, y, 1, 0] + E3[x, y, 1, 0] + E4[x, y, 1, 0] +
E5[x, y, 1, 0]
IIges[x_, y_] :=
Conjugate[Eges[x, y]] Eges[x, y] // ComplexExpand //
Simplify; (* can't differentiate Conjugate, had to change this *)
xm = 4;
{dx[x_, y_], dy[x_, y_]} =
D[IIges[x, y], {{x, y}}]; (* calculating partial derivatives *)
hes[x_, y_] =
D[IIges[x, y], {{x, y},
2}]; (* Hessian matrix: Second derivative matrix *)
crit = Cases[
Normal[ContourPlot[dx[x, y] == 0, {x, -xm, xm}, {y, -xm, xm},
ContourStyle -> None, Mesh -> {{0}},
MeshFunctions -> Function[{x, y, z}, dy[x, y]]]],
Point[{x0_, y0_}] :> ({\[FormalX], \[FormalY]} /.
FindRoot[{dx[\[FormalX], \[FormalY]],
dy[\[FormalX], \[FormalY]]}, {{\[FormalX], x0}, {\[FormalY],
y0}}]), ∞];
(* Identify points as minima, maxima or saddle points *)
hl = hes @@@ crit;
mnp = PositiveDefiniteMatrixQ /@ hl; (*pick minima*)
mxp = PositiveDefiniteMatrixQ /@ (-hl); (*pick maxima*)
sdp = Thread[mnp ⊽ mxp];(*saddle points are leftovers*)
(* Finding coordinates of critical points *)
mini = Pick[crit, mnp];
maxi = Pick[crit, mxp];
sadl = Pick[crit, sdp];
(* Plot stuff!
I changed the Image Size because it was too small *)
{Legended[
ContourPlot[IIges[x, y], {x, -xm, xm}, {y, -xm, xm},
ImageSize -> Scaled[0.3], ColorFunction -> "DarkTerrain",
Contours -> 15,
Epilog -> {AbsolutePointSize[6], {Cyan, Point[mini]}, {Orange,
Point[maxi]}}],
PointLegend[{Cyan, Orange}, {"Minima", "Maxima"}]],
Show[Plot3D[IIges[x, y], {x, -xm, xm}, {y, -xm, xm},
BoundaryStyle -> None, Boxed -> False,
ColorFunction -> "DarkTerrain", Mesh -> 15,
MeshFunctions -> {#3 &}],
Graphics3D[{{Cyan, Sphere[mini, 1/20]}, {Orange,
Sphere[maxi, 1/20]}} /. {x_?NumericQ, y_?NumericQ} :> {x, y,
IIges[x, y]}], ImageSize -> Scaled[0.43]]}
crit2 = Cases[
Normal[ContourPlot[dx[x, y] == 0, {x, 0.5, 2}, {y, -2.5, -1},
ContourStyle -> None, Mesh -> {{0}},
MeshFunctions -> Function[{x, y, z}, dy[x, y]]]],
Point[{x0_, y0_}] :> ({\[FormalX], \[FormalY]} /.
FindRoot[{dx[\[FormalX], \[FormalY]],
dy[\[FormalX], \[FormalY]]}, {{\[FormalX], x0}, {\[FormalY],
y0}}]), ∞];
hl2 = hes @@@ crit2;
mnp2 = PositiveDefiniteMatrixQ /@ hl2; (*pick minima*)
mxp2 = PositiveDefiniteMatrixQ /@ (-hl2); (*pick maxima*)
sdp2 = Thread[mnp2 ⊽ mxp2];(*saddle points are leftovers*)
mini2 = Pick[crit2, mnp2];
maxi2 = Pick[crit2, mxp2];
sadl2 = Pick[crit2, sdp2];
{Legended[
ContourPlot[IIges[x, y], {x, 0.5, 2}, {y, -2.5, -1},
ImageSize -> Scaled[0.3], ColorFunction -> "DarkTerrain",
Contours -> 15,
Epilog -> {AbsolutePointSize[6], {Cyan, Point[mini2]}, {Orange,
Point[maxi2]}}],
PointLegend[{Cyan, Orange}, {"Minima", "Maxima"}]],
Show[Plot3D[IIges[x, y], {x, 0.5, 2}, {y, -2.5, -1},
BoundaryStyle -> None, Boxed -> False,
ColorFunction -> "DarkTerrain", Mesh -> 15,
MeshFunctions -> {#3 &}],
Graphics3D[{{Cyan, Sphere[mini2, 1/20]}, {Orange,
Sphere[maxi2, 1/20]}} /. {x_?NumericQ, y_?NumericQ} :> {x, y,
IIges[x, y]}], ImageSize -> Scaled[0.43]]}