I have a contour data like this

data = ToExpression@Import["https://pastebin.com/raw/ukcaXRF0"];
ListLinePlot[data, AspectRatio -> Automatic]

enter image description here

Is there general way to get those tip coordinates ( that is those with large curvature)? I definitely do not want to use "get coordinate" menu.


OK, we got several answers now. Thank you so much. But none of them are robust.

For example

data1 = ToExpression@Import["https://pastebin.com/raw/uJbzjUZd"];
data2 = ToExpression@Import[ "https://pastebin.com/raw/Qki84fPf"];

aardvark2012's answer will give

enter image description here


enter image description here

while Coolwater got data2 right, failed data1

  • $\begingroup$ llp = ListLinePlot[data, AspectRatio -> Automatic]; corners = ImageCorners[Image[llp], MaxFeatures -> 4]; HighlightImage[Image[llp], corners] gets you the coordinates of corners in image dimensions. They need to be rescaled. $\endgroup$
    – kglr
    Dec 16, 2017 at 10:17
  • $\begingroup$ {First@MaximalBy[data[[1]], First], First@MinimalBy[data[[1]], Last]} and {First@MinimalBy[data[[2]], First], First@MaximalBy[data[[2]], Last]}. (Not very general... but works in this case). $\endgroup$ Dec 16, 2017 at 10:43
  • $\begingroup$ @kglr Well, it capture two, but the other two is wrong... $\endgroup$
    – matheorem
    Dec 16, 2017 at 10:45
  • $\begingroup$ @aardvark2012 This seems not general. Because I am not just processing one data, but series of data differs in shape and orientation $\endgroup$
    – matheorem
    Dec 16, 2017 at 10:46
  • $\begingroup$ Could you add another couple of images so we can get some idea of how general it needs to be? $\endgroup$ Dec 16, 2017 at 10:56

3 Answers 3

(* position of the point(s) between 2 sublines turning more than an angle v *)
v = 90 °;
pos = Nearest[Dot @@@ Partition[Normalize /@ Differences[#],
                        2, 1, {1, 1}] -> "Index", -1, {∞, 1 + Cos[v]}] & /@ data
(* {{982, 36}, {1923, 977}} *)

(* or estimating appropriate angle *)
pos = With[{ds = Dot @@@ Partition[Normalize /@ Differences[#], 2, 1, {1, 1}]},
        Nearest[ds -> "Index", -1, {∞, 1 + {0.95, 0.05}.MinMax[ds]}]] & /@ data;

Show[ListLinePlot[data, AspectRatio -> Automatic],
  ListPlot[MapThread[Part, {data, pos}], PlotStyle -> Black]]

  • $\begingroup$ Hi, I update my post $\endgroup$
    – matheorem
    Dec 16, 2017 at 12:03
  • $\begingroup$ @matheorem See edit $\endgroup$
    – Coolwater
    Dec 16, 2017 at 12:27
  • $\begingroup$ Seems quite good. But could you please elaborate a little more on your approach. I still don't get the code... $\endgroup$
    – matheorem
    Dec 16, 2017 at 12:34
  • $\begingroup$ @matheorem Differences gives the vector coordinates of each subline. Normalize and Dot correspond to VectorAngle. I avoid the latter, because it also takes ArcCos which is monotonous (only the order matters here). Among the computed Cos-values, I take those that are near -1, because -1 means that successive sublines take a 180 degree turn. In the second approach a 5% quantile is used to get those turns that turn almost as much as the most drastic turn. In that way at least the most drastic turn will always be included. $\endgroup$
    – Coolwater
    Dec 16, 2017 at 13:42

UPDATED: I have deleted previous non-working solutions.

After a bit of fumbling around, this works on all the test data:

extremes[datapoints_, n_: 2] := datapoints[[#]] & /@ 
  Ordering[ArcCos[#1.#2] & @@@ 
     Normalize /@ 
       Insert[#, Last@#, 1] &@DeleteDuplicates[datapoints]
     2, 1], 

which just finds the smallest n angles around the countour. It should also generalize to contours with more tips (just change n to reflect how many you're looking for) and cases where the tips are wrapped up inside the contour.

Two things to notice are:

  1. DeleteDuplicates is necessary in at least some cases because duplicates in the data were throwing things off -- likely the contour was actually doubling back in itself, creating a very tight angle.

  2. Tacking the last datapoint back on to the front is necessary in case the tip occurs at the first or last point in the list.


 Show[ListLinePlot[#, AspectRatio -> Automatic], 
    Graphics[{PointSize[Large], Red, 
      Point[extremes[#]] & /@ #}]] & /@ {data, data1, data2}, 
 ImageSize -> 750]

enter image description here

  • $\begingroup$ Hi, I update my post $\endgroup$
    – matheorem
    Dec 16, 2017 at 12:03
  • $\begingroup$ @matheorem Updated my answer to one that works. I've deleted old versions because it was becoming very unclear what was going on. Unfortunately, that makes your references to my older versions a bit superfluous, and I apologise for that. $\endgroup$ Dec 16, 2017 at 22:53

The following works perfectly on the three examples you provided. Since there is no precise definition of "tip of the contour", I based the strategy on the data you provided, but I cannot guarantee it would work for everything.

Strategy The idea is to observe that the tips correspond to the closest points between each closed curves. The following function mynearest computes the points in list $j$ that are the closest to list $i$ and vice-versa, using two efficient NearestFunction. Then, the combination of all pairs of curve is generated (tuples), to compute the closest points for each pair of curves. It then suffices to delete duplicates.

mynearest[data_, {i_, j_}] := Block[{},
  nf1 = Nearest@data[[i]];
  pts2 = Flatten[nf1[data[[j]]] // DeleteDuplicates, 1];
  nf2 = Nearest@data[[j]];
  pts1 = Flatten[nf2[data[[i]]] // DeleteDuplicates, 1];
  Join[pts1, pts2]]

data = ToExpression@Import["https://pastebin.com/raw/uJbzjUZd"];
tuples = Subsets[Range[Length@data], {2}];
pts = Flatten[mynearest[data, #] & /@ tuples, 1] // DeleteDuplicates;
Show[ListLinePlot[data, AspectRatio -> Automatic], 
 ListPlot[pts, PlotStyle -> Red]]

enter image description here


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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