# Reorder sets of 3D points to retrieve line segments coordinates

I have the following two sets of 3D points representing lines coordinates and points. :

pts  = {{0., -0.004, 0.}, {0., 0.016, 0.}, {0.001, 0.017, 0.}, {0.006, 0.017, 0.},
{0.011, 0.017, 0.}, {0.011, 0.021, 0.}, {0.011, 0.022, 0.001}, {0.011, 0.022, 0.015}}
pts1 = {{-0.01, 0.015, 0.}, {-0.01, 0.015, 0.01}, {0., 0., 0.}, {0., 0.015, 0.}};


In order to export those sets of data into another software, I would need to find the different lines segments creating the "big line".

So far I've only found the following code giving me the correct points order, which is not robust enough since it doesn't work with the pts1 set.

ordered[p_] := p[[Last[FindShortestTour[p, Method -> "AllTours"]]]]
ordered@pts
Graphics3D[{Red, Line@%, Point@pts}]


For the pts1 I get the following image:

I've tried changing the Method without any luck.

Unfortunately, I haven't use Mathematica in a very long time, and apparently the few skills I had have vanished.

• I'm not sure but this can help en.wikipedia.org/wiki/… Commented Aug 24, 2018 at 8:41
• The problem in the second case is caused by the DeleteDuplicates: You only apply it to the input of FindShortestTour, but when processing the output, (i.e. pts[[…]], you don't use it. Since pts1 has duplicates, you get the problem you're seeing. Commented Aug 24, 2018 at 8:57
• The problem is that FindShortestTour returns a list of indices w.r.t. its argument ({1,4,3,2,1} for pts1). If you now use this list to extract points from pts1 without DeleteDuplicates, you get meaningless results. The reason why pts doesn't make problems is that the duplicates are all at the end, so the indices of the other elements are not affected Commented Aug 24, 2018 at 10:17
• What version are you using? For me in 11.3 the default method of FindShortestTour yields accurate results. Commented Aug 24, 2018 at 12:58
• That might explains why it works with Graphs as well. I'm still on v8.
– Öskå
Commented Aug 24, 2018 at 13:00

## 1 Answer

Update: A more robust approach (than NearestNeighborGraph in the original answer below) is to use DistanceMatrix to identify the farthest apart pair of points and use one of the two points as the first element and sort all the points by their distance to this point:

ClearAll[pathF]
pathF = Module[{max = Max@DistanceMatrix[#] , first},
first = First @ SelectFirst[Subsets[#, {2}], EuclideanDistance @@ # == max &];
SortBy[#, EuclideanDistance [#, first] &]] &;

Row[Graphics3D[{Red, PointSize[Large], Point @ #, Blue,
Line @ pathF @ #}, BoxRatios -> 1, ImageSize -> 300] & /@ {pts,  pts1}, Spacer[10]]


Original answer:

An alternative is to use NearestNeighborGraph and FindPath:

pathF = Module[{nng = NearestNeighborGraph@#, l = Length@#},
FindPath[nng, ## & @@ GraphPeriphery[nng], l]] &;

paths = pathF /@ {pts, pts1};
Graphics3D[{Red, Thick, Line@#, Blue, Sphere[#, .5]},
ImageSize -> 300, Boxed -> True] & /@ paths // Row


paths2 = pathF /@ {RandomSample @ pts, RandomSample @ pts1}
Graphics3D[{Red, Thick, Line@#, Blue, Sphere[#, .5]},
ImageSize -> 300, Boxed -> True] & /@ paths // Row


same picture