# How to get Contour tips?

I have a contour data like this

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


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.

upate

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

and

while Coolwater got data2 right, failed data1

• 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. – kglr Dec 16 '17 at 10:17
• {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). – aardvark2012 Dec 16 '17 at 10:43
• @kglr Well, it capture two, but the other two is wrong... – matheorem Dec 16 '17 at 10:45
• @aardvark2012 This seems not general. Because I am not just processing one data, but series of data differs in shape and orientation – matheorem Dec 16 '17 at 10:46
• Could you add another couple of images so we can get some idea of how general it needs to be? – aardvark2012 Dec 16 '17 at 10:56

## 3 Answers

(* 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]]


• Hi, I update my post – matheorem Dec 16 '17 at 12:03
• @matheorem See edit – Coolwater Dec 16 '17 at 12:27
• Seems quite good. But could you please elaborate a little more on your approach. I still don't get the code... – matheorem Dec 16 '17 at 12:34
• @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. – Coolwater Dec 16 '17 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] & @@@
Partition[
Normalize /@
Differences[
Insert[#, Last@#, 1] &@DeleteDuplicates[datapoints]
],
2, 1],
-n]


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.

Then

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


• Hi, I update my post – matheorem Dec 16 '17 at 12:03
• @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. – aardvark2012 Dec 16 '17 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]]