# Group points which on several straight lines

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


## 4 Answers

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


Original answer:

chmboundary = RegionBoundary @ ConvexHullMesh @ pts


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]


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


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]


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]


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


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