13
$\begingroup$

I have some points, they are distributed on three straight lines, how to group points on the same line? I have tried FindCurvePath, but I got the wrong result. I also thought about GatherBy or Split, but I don't know how to write the second parameter.

pts = RandomSample@
   Join[RandomPoint[Line[{{0.3, 0.4}, {0.9, 1.4}}], 10], 
    RandomPoint[Line[{{0.2, 0.3}, {2.2, 0.3}}], 10], 
    RandomPoint[Line[{{2, 0.5}, {1.4, 1.6}}], 10]];

curve = FindCurvePath[pts]
Show[Graphics[{Point@pts}], ListLinePlot[pts[[#]] & /@ curve]]

enter image description here

$\endgroup$
2
  • 2
    $\begingroup$ You may find CollinearPoints and ResourceFunction["FindExtraordinaryLines"] useful. $\endgroup$
    – flinty
    Nov 10, 2021 at 16:14
  • $\begingroup$ In your example, the lines intersect at points that are not inside the convex hull of the points. Is that a general rule for your needs? $\endgroup$
    – A.G.
    Nov 10, 2021 at 17:37

4 Answers 4

8
$\begingroup$

Update:

curve = FindCurvePath[pts];

ip = Join @@ 
      (Permutations /@ IntegerPartitions[Length @ pts, {3}, Range[2, Length @ pts]]); 

partition = Quiet @ First @
   MinimalBy[ip, Total[LinearModelFit[#, x, x]["BIC"] & /@ 
       TakeList[pts[[Most@curve[[1]]]], #]] &]
{10, 10, 10}
bf = LinearModelFit[#, x, x]["BestFit"] & /@ TakeList[pts[[Most@curve[[1]]]], partition]
{0.3 + 5.43214*10^-17 x, 4.16667 - 1.83333 x, -0.1 + 1.66667 x}
Show[Plot[bf, {x, 0, 3}], 
 ListPlot[TakeList[pts[[Most@curve[[1]]]], partition]]]

enter image description here

Original answer:

chmboundary = RegionBoundary @ ConvexHullMesh @ pts

enter image description here

grouped = GroupBy[Sort @ MeshPrimitives[chmboundary, 1], 
   Round[#, 10^-3] &@*Ratios@*First@*Apply[Differences] -> SortBy[#[[1, 1]] &], 
    {RegionMeasure @ RegionUnion @ #, 
     InfiniteLine @ {#[[1, 1, 1]], #[[-1, -1, -1]]}} &];

infinitelines = Last /@ MaximalBy[Values[grouped], First, 3]

enter image description here

Graphics[{MapThread[{AbsoluteThickness[7], #, #2} &, 
       {{Red, Green, Blue}, infinitelines}], 
   AbsoluteThickness[2], Opacity[1], Gray, Last /@ Values[grouped],
   Black, PointSize[Small], Point @ pts}, 
 PlotRangePadding -> Scaled[.2]]

enter image description here

$\endgroup$
9
$\begingroup$

One way is to randomly sample the points and check for approximate collinearity (note: I found the function CollinearPoints to be too precise for this task). When this condition is met, fit an InfiniteLine to these collinear points and remove points in the set that are on the line (or extremely close). Proceed in this way until all points are removed.

SeedRandom[1];
pts = RandomSample@
   Join[RandomPoint[Line[{{0.3, 0.4}, {0.9, 1.4}}], 10], 
    RandomPoint[Line[{{0.2, 0.3}, {2.2, 0.3}}], 10], 
    RandomPoint[Line[{{2, 0.5}, {1.4, 1.6}}], 10]];
approxcollinear[pts_] := With[{reg = Line[pts[[{1, -1}]]]},
   With[{rdf = RegionDistance[reg]},
    Return@AllTrue[pts, rdf[#] < 0.0001 &]
    ]
   ];
online[pts_, line_] := With[{rdf = RegionDistance[line]},
  Select[pts, rdf[#] < 0.0001 &]
  ]
findcolin[pts_, n_] := Module[{rs = RandomSample[pts, n]},
  While[Not@approxcollinear@rs,
   rs = RandomSample[pts, n];
   ]; Return[rs]]
newpts = pts;
lines = Reap[While[newpts != {},
     rs = findcolin[newpts, 4];
     infl = InfiniteLine[rs[[{1, -1}]]];
     Sow[infl];
     ontheline = online[newpts, infl];
     newpts = Complement[newpts, ontheline];
     ListPlot[newpts]
     ]][[2, 1]];
Graphics[{lines, Red, Point@pts}, PlotRange -> All]

enter image description here

They can then be gathered up by checking region distance:

gathered = Reap[Do[
     Sow[Select[pts, RegionDistance[line, #] < 0.001 &]],
     {line, lines}]][[2, 1]];
ListPlot[gathered, AspectRatio -> 1]

enter image description here

$\endgroup$
5
$\begingroup$

Based on this answer of mine a general solution could be this

func[parms_List][x_] :=parms.Table[x^(n-1),{n,Length[parms]}]
dist[f_][{x_, y_}] := Abs[(y - f[x])]^2

sol2 = Last@With[{n = 2, m =3},
   NMinimize[
    Total@Map[Function[{L}, Min @@ Table[
         dist[func[Array[c[#, k] &, n]]][L]
         , {k, m}]], pts]
    , Flatten[Table[c[i, j], {i, n}, {j, m}]]
,Method->"DifferentialEvolution"]]

Here n=2 so we search for straight lines, i.e polynomial of degree $n-1=1$, and m=3 the number of curves, in this case, three lines. func define the shape of the curve you want to fit, and dist define a distance function to minimize.

The main concept is that you want to minimize (NMinimize) the minimum (Min) distance (dist) from each point to any of the alternative curves i.e. you minimize the distance to the closest curve, in this case, the closest line.

With some data

SeedRandom[42];
pts = RandomSample@
   Join[RandomPoint[Line[{{0.3, 0.4}, {0.9, 1.4}}], 10], 
    RandomPoint[Line[{{0.2, 0.3}, {2.2, 0.3}}], 10], 
    RandomPoint[Line[{{2, 0.5}, {1.4, 1.6}}], 10]];

Plotting the results

SetOptions[ListPlot
,PlotRange->All
,PlotTheme->"Scientific"];
Show[
 ListPlot@GatherBy[
   pts
   , Position[#, Min[#]] &[
     Table[dist[func[{c[1, k], c[2, k]} /. sol2]][#], {k, 3}]] &
   ],
 Plot[
  Evaluate[
   Table[
     func[{c[1, k], c[2, k]}][x]
     , {k, 4}] /. sol2
   ]
  , {x, 0, 10}
  ]]

enter image description here

$\endgroup$
3
$\begingroup$

We may determine the first line by taking an arbitrary point: p0, e.g. the first one, and determine its nearest neighbor: pn. This determines a line. Now, we calculate a perpendicular unit vector: perp. The scalar product of perp with any of the remaining point gives the distance to the line. If we select all points that have a small distance to the line we have all the points on the line. Next, we eliminate these points and repeat the process with the remaining points.

SeedRandom[1];
pts = RandomSample@
   Join[RandomPoint[Line[{{0.3, 0.4}, {0.9, 1.4}}], 10], 
    RandomPoint[Line[{{0.2, 0.3}, {2.2, 0.3}}], 10], 
    RandomPoint[Line[{{2, 0.5}, {1.4, 1.6}}], 10]];
getLines[pts0_] := Module[{pts, l1, l2, l3},
   getlin[ps_] := Module[{p0, pn, perp, lin},
     p0 = ps[[1]];
     pn = Nearest[Rest@ps, p0][[1]];
     perp = Normalize[{{0, -1}, {1, 0}} . (pn - p0)];
     {lin = Select[ps, Abs[perp . (# - p0)] < 0.01 &],
      Complement[ps, lin]}];
   {l1, pts} = getlin[pts0];
   {l2, pts} = getlin[pts];
   {l3, pts} = getlin[pts];
   {l1, l2, l3}
   ];
ListLinePlot[getLines[pts], Epilog -> Point[pts]]

enter image description here

$\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.