3
$\begingroup$

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)?

$\endgroup$
8
  • $\begingroup$ 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? $\endgroup$
    – Mr.Wizard
    Commented Jul 15, 2016 at 8:32
  • $\begingroup$ Sort[DeleteDuplicates[coLine]][[{-1, 1}]] $\endgroup$
    – yode
    Commented Jul 15, 2016 at 8:33
  • 2
    $\begingroup$ If[MatrixRank[Transpose[#]] <= 1, Sort[#][[{1, -1}]], #] & should to the trick... $\endgroup$
    – ciao
    Commented Jul 15, 2016 at 8:38
  • $\begingroup$ @ciao looks good, how would I apply that to my pnts? If it works, I think ist worth posting an answer :) $\endgroup$
    – DPF
    Commented Jul 15, 2016 at 8:40
  • 1
    $\begingroup$ myFn= If[MatrixRank[Transpose[#]] <= 1, Sort[#][[{1, -1}]], #] &; then to use it, myFn@pnts... $\endgroup$
    – ciao
    Commented Jul 15, 2016 at 8:41

4 Answers 4

5
$\begingroup$

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]}}]]

2D collinear points

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]}}]]

3D collinear points

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

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]

Mathematica graphics

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]

Mathematica graphics

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]
$\endgroup$
2
  • $\begingroup$ Thats a cool view on it :) $\endgroup$
    – DPF
    Commented Jul 15, 2016 at 15:34
  • $\begingroup$ 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. $\endgroup$
    – yarchik
    Commented Jul 15, 2016 at 16:36
2
$\begingroup$
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}]

enter image description here

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

$\endgroup$
1
$\begingroup$

Historical note:

enter image description here

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}}

$\endgroup$

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.