# Remove inner points from collinear List

Imagine a List of Points that is collinear:

{{-1,-1},{1,1},{0,0},{-2,-2},{1,1}}


How can I at first check, if such a List is collinear and if so, reduce it to contain only the two "endpoints":

{{1,1},{-2,-2}}


## Edit

If a list is not collinear, I'd expect to get the untouched list back.

{{-7,-1},{1,1},{0,0},{-2,-2},{1,1}} -> {{-7,-1},{1,1},{0,0},{-2,-2},{1,1}}


## Approaching

pnts = {{-1, -1}, {1, 1}, {0, 0}, {-2, -2}, {1, 1}};
totals = Total /@ pnts
list = Pick[pnts, totals, Min[totals] | Max[totals]]
DeleteDuplicates[list //. {} -> Sequence[]]


gives the Endpoints of a collinear set, but how could I apply a check for collinearity first (see my edit)?

• After seeing multiple failures of the built-in computational geometry functions applied to your numeric values I am inclined to ask: are your values precise or floating point numeric, and if they are FP what tolerance should be used to determine collinearity? Commented Jul 15, 2016 at 8:32
• Sort[DeleteDuplicates[coLine]][[{-1, 1}]]
– yode
Commented Jul 15, 2016 at 8:33
• If[MatrixRank[Transpose[#]] <= 1, Sort[#][[{1, -1}]], #] & should to the trick...
– ciao
Commented Jul 15, 2016 at 8:38
• @ciao looks good, how would I apply that to my pnts? If it works, I think ist worth posting an answer :)
– DPF
Commented Jul 15, 2016 at 8:40
• myFn= If[MatrixRank[Transpose[#]] <= 1, Sort[#][[{1, -1}]], #] &; then to use it, myFn@pnts...
– ciao
Commented Jul 15, 2016 at 8:41

Here is a sturdier variation of ciao's answer:

getEnds[pts_?MatrixQ] := If[MatrixRank[Standardize[pts, Mean, 1 &]] ==
Last[Dimensions[pts]], pts,
With[{dm = DistanceMatrix[pts]},
pts[[FirstPosition[Unitize[dm - Max[dm]], 0]]]]]


Tests:

BlockRandom[SeedRandom["collinearity"]; (* for reproducibility *)
n = 30;
init = RandomReal[{-2, 2}, 2];
d = RandomReal[4]; θ = RandomReal[{-π, π}];
pos = RandomReal[1, n];
tst = Transpose[{init, init + d Through[{Cos, Sin}[θ]]}.{1 - pos, pos}];
ends = getEnds[tst];
Graphics[{{Red, Point[tst]}, {Blue, AbsolutePointSize[5], Point[ends]}}]]


BlockRandom[SeedRandom["collinearity"];
n = 30;
init = RandomReal[{-2, 2}, 3];
d = RandomReal[4]; θ = RandomReal[{-π, π}]; φ = RandomReal[π];
pos = RandomReal[1, n];
tst = Transpose[{1 - pos, pos}] .
{init, init + FromSphericalCoordinates[{d, φ, θ}]};
ends = getEnds[tst];
Graphics3D[{{Red, Point[tst]}, {Blue, AbsolutePointSize[5], Point[ends]}}]]


• (Of course, you will need to do a few replacements for versions earlier than 10.) Commented Jul 16, 2016 at 0:19

Posting this less-than-efficient method just for the fun of it

Say you've got a list of random collinear points

SeedRandom[42];
ln = InfiniteLine[RandomReal[{-1000, 1000}, {2, 2}]];
pts = RandomPoint[
ln,
50, {{-1000, 1000}, {-1000, 1000}}];
Graphics[{Red, PointSize[Large], Point@pts, Blue, Thick, ln},
Frame -> True]


Now these are only approximate numbers, so they are approximately collinear. In order to get the MatrixRank test to work, I have to set the Tolerance up to 0.4

MatrixRank[pts, Tolerance -> .3]
MatrixRank[pts, Tolerance -> .4]
(* 2 *)
(* 1 *)


So here's a silly modification to ciao's solution that determines if the areas of triangles are zero in the list,

myFn2 = If[
PossibleZeroQ@*Chop@*Area@*Triangle /@ Partition[#, 3, 2] //
Apply[And], Sort[#][[{1, -1}]], #] &


and it works on this example

myFn2@pts
(* {{-997.106, 457.397}, {829.276, -995.571}} *)


and in higher dimensions,

SeedRandom[42];
ln = InfiniteLine[RandomReal[{-1000, 1000}, {2, 3}]];
pts = RandomPoint[
ln,
50, {{-1000, 1000}, {-1000, 1000}, {-1000, 1000}}];
Graphics3D[{Blue, ln, Red, PointSize[Medium], Point@pts, Yellow,
PointSize[.1], Sphere[#, 50] & /@ (myFn2@pts)}, Boxed -> False,
PlotRange -> All]


But it isn't guaranteed to work -

The general problem of determining whether an expression has value zero is undecidable; PossibleZeroQ provides a quick but not always accurate test

## Version 9 compatible

For version 9 I couldn't use any of my favorite functions. We can't use the operator forms of anything, nor can we use Area or Triangle, so we can resort to taking the determinant of a matrix as described here

myFn2V9[pts_] := If[Max[
(Chop[Det[Map[(Append[#, 1] &), #]], 10^-8] &) /@
Partition[#, 3, 2, 1, {First@#}] &@pts
] == 0,
Sort[pts][[{1, -1}]], pts]

• Thats a cool view on it :)
– DPF
Commented Jul 15, 2016 at 15:34
• I have MA 9.0.1 and I cannot run your code, any idea why? Is it possible to make it compatible with older versions, I would be interested to compare performances of your and my codes. Commented Jul 15, 2016 at 16:36
col[pts_] :=
Module[{a},
a = MapThread[Append, {pts, ConstantArray[1, Length[pts]]}];
If[Length[NullSpace[a]] == Last[Dimensions[pts]] - 1, Sort[pts][[{1, -1}]], pts]]


It turns out that NullSpace is rather slow. One can replace Length[NullSpace[a]]==Last[Dimensions[pts]] - 1with MatrixRank[a] == 2. For this my acknowledgements fully go to @ciao. In fact his initial answer only required two minor correction that I am realising here.

colFast[pts_] :=
Module[{a = MapThread[Append, {pts, ConstantArray[1, Length[pts]]}]},
If[MatrixRank[a] == 2, Sort[pts][[{1, -1}]], pts]]


Now timing results comparing with the method of @JasonB.

listN = Table[
test = Table[{8. - 5. i, -7. i}, {i, k}];
{k,myFn2V9[test] // Timing // First,
k,colFast[test] // Timing // First}, {k, 100000,1000000, 100000}]
gr = ListLinePlot[{listN[[All, 1 ;; 2]], listN[[All, 3 ;; 4]]},
AxesLabel -> {"# points", "time (s)"}, PlotLegends -> {myFn2V9, colFast}]


It seems that both methods do feature linear scaling, albeit with different prefactors.

Historical note:

If the coordinate entries were all integers, the CollinearPoints function would come in handy replacing the rank calculations featured in other answers. However, such is rarely the practical case.

Let's define a function f and use it on two examples on the page:

f[k_List] :=
If[NumericQ@RegionMeasure@ConvexHullMesh[k], k,
SortBy[k, First][[{1, -1}]]]


Explanation:

The idea is that if a ConvexHullMesh can be created with the given pts and its RegionMeasure returns a numeric quantity, then the points are non-collinear. A further check can be introduced (if required) regarding an upper threshold on the magnitude of this area. If the calculation returns unevaluated, then the points are collinear (barring any symbolic inputs). In this case, the two extreme points are extracted.

Ex:1

pts = {{-1, -1}, {1, 1}, {0, 0}, {-2, -2}, {1, 1}};
f@pts


{{-2, -2}, {1, 1}}

Ex:2 (from @JasonB, featuring real numbers)

SeedRandom[42];
ln = InfiniteLine[RandomReal[{-1000, 1000}, {2, 2}]];
pts = RandomPoint[ln, 50, {{-1000, 1000}, {-1000, 1000}}];

f@pts


{{-997.106, 457.397}, {829.276, -995.571}}