7
$\begingroup$

The question originates from Max & min distance between two moving points. I think it can be solved easily because of the function is a parametic function. My heat-shaped curve is given by

ContourPlot[ ((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, AspectRatio -> Automatic]

enter image description here

So how do I find two points on this curve that have maximal distance between them?

Improve this question
$\endgroup$
3
  • 2
    $\begingroup$ This could be a possibility : mat = ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}][[1, 1]] ; Max@DistanceMatrix[mat, mat] (returns 1.79212). $\endgroup$ Commented Mar 8, 2016 at 21:13
  • $\begingroup$ Thanks your amaze function of DistanceMatrix.But this method by mat[[1,1]] lead to a rough result? $\endgroup$ Commented Mar 8, 2016 at 21:23
  • $\begingroup$ @Xavier: You should write that up as an answer. It's pretty slick. $\endgroup$ Commented Mar 8, 2016 at 21:49

3 Answers 3

Reset to default
13
$\begingroup$

You can use FindMaximum to numerically maximize the distance (squared) between two arbitrary points $(x_1, y_1)$ and $(x_2, y_2)$, subject to the constraint that both points lie on the curve:

soln = FindMaximum[{(x1 - x2)^2 + (y1 - y2)^2, {((1.2 x1)^2 + (1.4 y1)^2 - 1)^3 - (1.3 x1)^2 y1^3 == 0, ((1.2 x2)^2 + (1.4 y2)^2 - 1)^3 - (1.3 x2)^2 y2^3 == 0}}, {{x1, 0.33}, {y1, 0.82}, {x2, -0.9}, {y2, 0.3}}] ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, AspectRatio -> Automatic, Epilog -> {PointSize[Large], Red, Point[{{x1, y1}, {x2, y2}} /. soln[[2]]]}] (* {3.21208, {x1 -> 0.896114, y1 -> 0.282435, x2 -> -0.896114, y2 -> 0.282435}} *)

enter image description here

I had to play around with the starting value quite a lot to arrive at this result, though. FindMaximum tends to get "stuck" at the points where $x = 0$ or $y = 0$; I presume this has something to do with the form of the constraint curves at these points.

EDIT: Note that the value of 3.21208 is the square of the distance between these points. The actual distance would therefore be 1.79223, which is in good agreement with the distance that @Xavier extracted from the plot data.

Improve this answer
$\endgroup$
5
  • $\begingroup$ When you run re = ImplicitRegion[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, y}]; soln = FindMaximum[{EuclideanDistance[{x1, y1}, {y1, y2}], {{x1, y1} \[Element] re, {x2, y2} \[Element] re}}, {{x1, 0.33}, {y1, 0.82}, {x2, -0.9}, {y2, 0.3}}] ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, AspectRatio -> Automatic, Epilog -> {PointSize[Large], Red, Point[{{x1, y1}, {x2, y2}} /. soln[[2]]]}].you will get another result. $\endgroup$ Commented Mar 8, 2016 at 21:37
  • $\begingroup$ @yode: As I noted, the FindMaximum algorithm tends to get "stuck" on points with $x = 0$ or $y = 0$, for reasons I'm not entirely clear on. This is one such example. Note that FindMaximum returns an error message for your code (due to poor convergence to a maximum), but does not for mine. (Also, you have an error in your expression: it should be EuclideanDistance[{x1, y1}, {x2, y2}] instead of what you have.) $\endgroup$ Commented Mar 8, 2016 at 21:46
  • $\begingroup$ Sorry my English.And thanks four your explaination. $\endgroup$ Commented Mar 8, 2016 at 21:48
  • $\begingroup$ Clear["`*"]; re = ImplicitRegion[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, y}]; soln = ArgMax[{EuclideanDistance[{x1, y1}, {x2, y2}], {{x1, y1} \[Element] re, {x2, y2} \[Element] re}}, {x1, y1, x2, y2}]; ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, AspectRatio -> Automatic, Epilog -> {PointSize[Large], Red, Point[{{soln[[1]], soln[[2]]}, {soln[[3]], soln[[4]]}}]}]. And the ArgMax give a wrong result? $\endgroup$ Commented Mar 8, 2016 at 22:00
  • $\begingroup$ What if you used NMaximize[] instead? $\endgroup$ Commented Mar 8, 2016 at 23:07
7
$\begingroup$

Making a post out of my comment as suggested. Note that the first part of what follows answers a (restricted) interpretation of a previous version of the question. It only concerns the computation of the maximum distance of a heart-shaped curve, and not the two points that satisfy it. The second part of this answer uses J.M.'s proposition.

The function DistanceMatrix introduced in 10.3 offers an alternative approach,

DistanceMatrix[{$u_1$, $u_2$, $\dots$}, {$v_1$, $v_2$, $\dots$}] gives the matrix of distances between each pair of elements $u_i$, $v_j$.

We simply need to extract the points from ContourPlot and feed DistanceMatrix with them:

points = ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}][[1, 1]]; Max@ DistanceMatrix[points, points] (* 1.79212 *)

One can get a more accurate evaluation of the maximum distance by modifying the value of the option MaxRecursion for ContourPlot:

With[{points = ContourPlot[ ((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, MaxRecursion -> 6][[1, 1]]}, Max@DistanceMatrix[points, points]] (* 1.79223 *)

which brings us to the same value as the one obtained by Michael Seifert in his answer, but at the expense of performance. A RepeatedTiming, from the construction of points to the final output, gives respectively 0.0537 and 1.29 seconds (against the 0.0247 seconds of Michael's FindMaximum).

The proposition of J.M. posted in a comment is probably the way to go, as it avoids searching for the appropriate starting values of FindMaximum, while performing similarly as the latter,

NMaximize[{(x1 - x2)^2 + (y1 - y2)^2, {((1.2 x1)^2 + (1.4 y1)^2 - 1)^3 - (1.3 x1)^2 y1^3 == 0, ((1.2 x2)^2 + (1.4 y2)^2 - 1)^3 - (1.3 x2)^2 y2^3 == 0} }, {x1, x2, y1, y2}] (* {3.21208, {x1 -> -0.896114, x2 -> 0.896114, y1 -> 0.282435, y2 -> 0.282435}} *)
Improve this answer
$\endgroup$
3
$\begingroup$

Here is an approach that turns the graphics into a region and with the help of NArgMax we get the desired points quite easily (this method is approximate, but a good one):

cp = ContourPlot[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {x, -1.5, 1.5}, {y, -3/2, 3/2}, AspectRatio -> Automatic, MaxRecursion -> 6];

Now we turn the plot into a region:

reg = DiscretizeGraphics @ cp;

Finally, get the points of interest:

NArgMax[Norm[{x, y} - {u, v}], {{x, y} ∈ reg, {u, v} ∈ reg}] // Quiet

{0.896113, 0.282458, -0.896113, 0.282458}

Note: The following approach will not work in Mathematica 10.4 but works in 10.3.1

Also, one can use DiscretizeRegion to achieve the same thing without plotting the curve:

imp = ImplicitRegion[((1.2 x)^2 + (1.4 y)^2 - 1)^3 - (1.3 x)^2 y^3 == 0, {{x, -1.2, 1.2}, {y, -1.2, 1.2}}]; dreg = DiscretizeRegion[imp, MaxCellMeasure -> 0.0001];

Then, as before:

NArgMax[Norm[{x, y} - {u, v}], {{x, y} ∈ dreg, {u, v} ∈ dreg}] // Quiet

This approach gives a better approximation because we can control the "fineness" of the discretization with MaxCellMeasure.

{0.896114, 0.282435, -0.896114, 0.282435}

Improve this answer
$\endgroup$
3
  • $\begingroup$ Why my same method with you,but give a wrong result?Clear["*"];re=ImplicitRegion[((1.2 x)^2+(1.4 y)^2-1)^3-(1.3 x)^2 y^3==0,{x,y}];soln=ArgMax[{EuclideanDistance[{x1,y1},{x2,y2}],{{x1,y1}[Element]re,{x2,y2}[Element]re}},{x1,y1,x2,y2}]; ContourPlot[((1.2 x)^2+(1.4 y)^2-1)^3-(1.3 x)^2 y^3==0,{x,-1.5,1.5},{y,-3/2,3/2},AspectRatio->Automatic,Epilog->{PointSize[Large],Red,Point[{{soln[[1]],soln[[2]]},{soln[[3]],soln[[4]]}}]}]` $\endgroup$ Commented Mar 29, 2016 at 9:11
  • $\begingroup$ @yode I don't know why it fails, maybe a bug? $\endgroup$ Commented Mar 29, 2016 at 9:41
  • $\begingroup$ I think so.Thanks for your confirmation. $\endgroup$ Commented Mar 29, 2016 at 9:59

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.