Sort Data Sets by Lines/Neighbours

Question

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

Answer 1

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)