current community

your communities

more stack exchange communities

company blog
Stack Exchange Inbox Reputation and Badges
tour help
Mathematica Stack Exchange is a question and answer site for users of Wolfram Mathematica. Join them; it only takes a minute:

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top
up vote 8 down vote favorite
2

I have need of a function to find a good ordering for a series of lines, as FindCurvePath does for points.

Sample data:

dat = {{{-2.83718,1.},{-2.83708,0.999885}},{{-2.837,0.999875},
{-2.83708,0.999885}},{{-2.83649,0.999763},{-2.83673,0.999716}},
{{-2.83673,0.999716},{-2.837,0.999875}},{{-2.83747,0.999718},{-2.83718,1.}},
{{-2.83699,0.999714},{-2.83697,0.999704}},{{-2.83696,0.999716},
{-2.8368,0.999686}},{{-2.83696,0.999716},{-2.83697,0.999704}},
{{-2.83678,0.999668},{-2.8368,0.999686}},{{-2.83702,0.999653},
{-2.83699,0.999714}},{{-2.83675,0.999644},{-2.83678,0.999668}},
{{-2.83647,0.999632},{-2.83649,0.999763}},{{-2.83647,0.999632},
{-2.8365,0.999633}},{{-2.8367,0.999603},{-2.83675,0.999644}},
{{-2.8365,0.999633},{-2.83654,0.999584}},{{-2.83666,0.99957},
{-2.8367,0.999603}},{{-2.83728,0.999697},{-2.83712,0.999592}},
{{-2.83664,0.999553},{-2.83666,0.99957}},{{-2.83654,0.999584},
{-2.83655,0.999551}},{{-2.83655,0.999551},{-2.83656,0.999549}},
{{-2.83712,0.999592},{-2.83702,0.999653}},{{-2.83656,0.999549},
{-2.83664,0.999553}}};

These lines form a single line:

ListLinePlot[dat, Frame -> True]

enter image description here

But they are out of order and their directions are mixed:

ListLinePlot[Join @@ dat, Frame -> True]
Graphics[Arrow @ dat, Frame -> True]

enter image description here

enter image description here

So I need not only to order the lines but to reverse some of them as well.

I also need to allow for gaps between lines. End points will not always be as close as in this example. A solution should work also on:

dat2 = dat ~Delete~ {{2}, {8}, {9}, {13}};

ListLinePlot[dat2, Frame -> True]

enter image description here

Additionally in practice my constituent lines are more than two points long but the end points should be sufficient for a solution. However I either need ordering and direction data that I can apply to the full lines or an algorithm that works on compound lines, not just line segments.

share|improve this question
    
You can use a loop with minimizing RegionDistance but my attempts got rather messy. Easy if you know begin and end lines though. – Feyre 12 hours ago
    
@Feyre If you feel like posting something don't worry about it being messy. I am curious to see multiple approaches. – Mr.Wizard♦ 12 hours ago
up vote 8 down vote

This approach generates the data into newdat, while removing from dat, so you may want to store original data first, or rewrite to avoid that.

newdat = {dat[[1]]};
z = 1; k = 1;
While[k < Length@dat, 
 temp = Select[dat, FreeQ[Join[Reverse /@ newdat, newdat], #] &];
 it = Table[
   RegionDistance[Line@newdat[[k]], temp[[i, j]]], {i, 
    Length[dat] - k}, {j, 2}];
 z = Position[it, Min@it][[1, 1]];
 If[it[[z, 1]] > it[[z, 2]], AppendTo[newdat, Reverse@temp[[z]]], 
  AppendTo[newdat, temp[[z]]]]; k++;]

And the results:

ListLinePlot[Join @@ newdat, Frame -> True]
Graphics[Arrow@newdat, Frame -> True]

enter image description here enter image description here

For the reduced data one arrow stays reversed.

enter image description here enter image description here

share|improve this answer
    
@Mr.Wizard I know what's going on, foolishly changed 22 to Length@dat, should be fixed now. This is why you don't do things like editing original dataset. – Feyre 11 hours ago
    
Confirmed fixed now. :-) Mine was broken too by the way, only worse. ;^) – Mr.Wizard♦ 10 hours ago
up vote 7 down vote

With the missing piece from How do I "read out" the vertex names on this graph? I can self-answer using Nearest and Graph. Please don't let this post discourage answering as I am eager to see other approaches.

Now as a function with at least a little reusability. The second parameter is the search radius. 

order[data_, rad_: 0.0001] := Module[{dd, near, g},
  dd = Join @@ data;
  near = Nearest[dd -> Automatic, dd, {2, rad}] ~Cases~ {_, _};
  g = near ~Join~ Partition[Range @ Length @ dd, 2] // Graph;
  FindPath[g, ##][[1]] & @@ GraphPeriphery[g]
]

ListLinePlot[Part[Join @@ dat, order[dat]], Frame -> True]

enter image description here

It works on the set with gaps given a sufficient radius:

ListLinePlot[Part[Join @@ dat2, order[dat2, 0.0001]], Frame -> True]

enter image description here

The next step in improving this would be to extract direction data from the output of order to apply to full lines.

share|improve this answer
    
How about a larger test set to enable benchmarking? I'm very interested to learn about the speed of different approaches (very relevant for CNC path optimization...) – Yves Klett 11 hours ago
    
@YvesKlett Do you have a set to propose? If uniformly distributed pseudorandom data useful? – Mr.Wizard♦ 11 hours ago
1  
... will take a look if I find a wicked set tomorrow (sorry, very busy at the office recently) . However, pseudorandom should work as well. – Yves Klett 11 hours ago
up vote 6 down vote

Using FindShortestTour with a custom distance function:

d = Flatten[dat, 1];

dist[a_?OddQ, b_] /; (b == a + 1) := 0.0001 EuclideanDistance[d[[a]], d[[b]]]

dist[a_, b_] := EuclideanDistance[d[[a]], d[[b]]]

o = Most@FindShortestTour[Range[Length@d], DistanceFunction -> dist][[2]]
(* {1, 2, 4, 3, 8, 7, 6, 5, 24, 23, 25, 26, 29, 30, 37, 38, 39, \
40, 43, 44, 35, 36, 31, 32, 27, 28, 21, 22, 17, 18, 14, 13, 15, 16, \
12, 11, 20, 19, 42, 41, 34, 33, 9, 10} *)

Graphics[Arrow /@ Partition[d[[o]], 2]]

enter image description here

share|improve this answer
    
Great! I had a feeling there was a more direct approach but I could not see my way to it. I knew I needed a way to "contract" the distance between points joined by existing lines but I struggled to do it. Treating odd indices seems obvious now but it was not at the time, like so many great ideas. – Mr.Wizard♦ 2 hours ago
    
I'm probably having another moment of obtuseness but why can one not use dist[a_?OddQ, b_] /; (b == a + 1) := 0? – Mr.Wizard♦ 1 hour ago
    
There is one issue with this as written: the order always starts with {1} whereas in practice it should start with one of the ends, i.e. {9} or {33}. – Mr.Wizard♦ 25 mins ago
    
It seems this method also has problems with self-intersecting lines. I wonder if that can be resolved. – Mr.Wizard♦ 12 secs ago

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.