Mathematica Stack Exchange is a question and answer site for users of Mathematica. Join them; it only takes a minute:

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

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?

share|improve this question
2  
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). – Xavier Mar 8 at 21:13
    
Thanks your amaze function of DistanceMatrix.But this method by mat[[1,1]] lead to a rough result? – yode Mar 8 at 21:23
    
@Xavier: You should write that up as an answer. It's pretty slick. – Michael Seifert Mar 8 at 21:49
up vote 12 down vote accepted

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.

share|improve this answer
    
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. – yode Mar 8 at 21:37
    
@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.) – Michael Seifert Mar 8 at 21:46
    
Sorry my English.And thanks four your explaination. – yode Mar 8 at 21:48
    
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? – yode Mar 8 at 22:00
    
What if you used NMaximize[] instead? – J. M. Mar 8 at 23:07

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}} *)
share|improve this answer

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}

share|improve this answer
    
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]]}}]}]` – yode Mar 29 at 9:11
    
@yode I don't know why it fails, maybe a bug? – RunnyKine Mar 29 at 9:41
    
I think so.Thanks for your confirmation. – yode Mar 29 at 9:59

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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