Sort Data Sets by Lines/Neighbours

I have several sets of data which together yield Fig. 1. As can be seen from the colours of the dots, the data sets are mixed, but do obviously belong to several distinct lines. My question is:

How can I efficiently sort the data sets by their corresponding lines? The structure of my data is just a list of lists of data poinst. E.g.

{
{a1[ω],a2[ω],a3[ω],...},
{b1[ω],b2[ω],b3[ω],...},
...,
{z1[ω],z2[ω],z3[ω],...}
}


The lists are of the same length each (i.e. my data forms a matrix). They should be sorted in such a way that I get e.g.

{
{first point of top line, second point, third point,...},
{first point of second line, second point, third point,...},
{first point of lowest line, second...}
}


However, how the lines themselves are ordered is not important.

Fig. 2 is another example of a plot with much more points.

It is not important that it works well close to zero where all the lines meet.

(This problem has probably already been solved, but I was unable to find the solution.)

• Have you tried GroupBy ? – Whelp Dec 11 '19 at 13:21
• The property top and bottom is not so clearly established when the lines intersect. – Cesareo Dec 11 '19 at 13:23
• @Whelp I wouldn't have known what to group by. So no, I didn't. – Fred Dec 11 '19 at 14:45
• @Cesareo Yes, they aren't. That's why I added that comment below the example list stating that the order of the lines themselves is not important. I could probably have made it more clear, but for the sake of readability I didn't reason it any further. – Fred Dec 11 '19 at 14:45

Here is an approach that tries to shuffle the points to form lines that are as straight as possible:

SeedRandom[3];
(* some random data *)
data = Map[RandomSample]@
Transpose@
Table[Evaluate@Sum[RandomReal[{-1, 1}] #^n, {n, 0, 2, 0.5}] & /@
Subdivide[50], {i, 25}];
Monitor[ (* show the current state of the points *)
data = Sort/@data; (* sort the points *)
Do[ (* go over the y coordinates from the back*)
change = True;
While[change,(* repeat swapping until no better solution can be found *)
change = False;
Do[ (* iterate over all pairs of points *)
ridx = Reverse@idx;
dist = (* distance function *)
EuclideanDistance[data[[i, #]], data[[i + 1, idx]]] +
100 If[i < Length@data - 1,
Total[(data[[i, #]] - 2 data[[i + 1, idx]] + data[[i + 2, idx]])^2],
0] &;
If[dist@ridx < dist@idx, (* if swapping the points lowers the distance function: *)
data[[i, idx]] = data[[i, ridx]]; (* swap them *)
change = True; (* and record that something changed *)
],
{idx, RandomSample@Subsets[Range@Length@First@data, {2}]}
]
],
{i, Length@data - 1, 1, -1}
],
ListLinePlot@Transpose@data
];
ListLinePlot@Transpose@data


Some notes:

• This assumes that each $$x$$ position, there is the same amount of $$y$$ coordinates that just need reordering
• We sort each column of points initially to get a reasonably good starting state. (Of course, this will work worse the more the lines cross)
• Ideally, we would like to find the best permutation out of all possible ones. Unfortunately, the number of permutations grows too quickly, so we can't check all of them. Instead, we simply try to swap to points - if the result is better, we keep it, otherwise we discard it. We do this until no changes are made anymore.
• The distance function dist consists of two parts: The euclidean distance between the current column and the previous one - this alone is a pretty good metric already. The second part is the second derivative of the curves produced (in discretised form). This ensures that straighter lines are favoured over slightly shorter ones. The 100 is a weighting factor that might need adjustment. Without the second term, we would get "avoided crossing" (note how the lines "bounce" off each other):

• We start at the back, since the lines seem to be more spread out there. This makes the first step more robust, since no second derivative information is available yet.

• We shuffle the swaps to try with RandomSample - this seems to be faster than to try them in order (probably a more deterministic order could be found)
• This is VERY cool! – MarcoB Dec 11 '19 at 14:12
• This is really cool. In particular, I like that it shows the sorting progress and allows me to stop the computation at any point if I'm happy with it already, and that I can then continue it at any time. There may or may not be some more deterministic way for my problem, or maybe even some tweaks for your code in general, but it is definitely enough to handle most cases. Thank you very much! – Fred Dec 11 '19 at 14:20