2
$\begingroup$

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

pts

For the pts1 I get the following image:

pts1

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.

$\endgroup$
  • $\begingroup$ I'm not sure but this can help en.wikipedia.org/wiki/… $\endgroup$ – David Baghdasaryan Aug 24 '18 at 8:41
  • 1
    $\begingroup$ 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. $\endgroup$ – Lukas Lang Aug 24 '18 at 8:57
  • 1
    $\begingroup$ 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 $\endgroup$ – Lukas Lang Aug 24 '18 at 10:17
  • $\begingroup$ What version are you using? For me in 11.3 the default method of FindShortestTour yields accurate results. $\endgroup$ – Lukas Lang Aug 24 '18 at 12:58
  • $\begingroup$ That might explains why it works with Graphs as well. I'm still on v8. $\endgroup$ – Öskå Aug 24 '18 at 13:00
4
$\begingroup$

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

enter image description here

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 

enter image description here

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

same picture

|improve this answer|||||
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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