# Creating a tube from orbit collection

I have a data file which contains the $(x,y,z)$ coordinates of a large collection of orbits (about 2000 orbits). Now let's plot them

data1 = Import["mans_3D.out", "Table"];
d1 = SplitBy[data1, Dimensions][[2 ;; ;; 2]];
d11 = d1[[;; , ;; , {1, 2, 3}]];
d2 = Map[{1, -1, 1} # &, d11, {-2}];

g1 = Graphics3D[{Red, PointSize[0.003], Line /@ d11}, Axes -> True,
BoxRatios -> {1, 1, 1}, PlotRange -> 15, ImageSize -> 550];
g2 = Graphics3D[{Darker[Green], PointSize[0.003], Line /@ d2},
Axes -> True, BoxRatios -> {1, 1, 1},
BoxStyle -> Directive[Thickness[0.003]], PlotRange -> 15,
ImageSize -> 550];

rmax = 25;
plot1 = Show[{g1, g2}, AxesStyle -> Directive[FontSize -> 20,
FontFamily -> "Helvetica"], AxesLabel -> {"x", "y", "z"},
PlotRange -> rmax, BoxStyle -> Directive[Thickness[0.005]],
ImageSize -> 550, ViewPoint -> {1.5, -1.1, 1.5}]


which produces the following plot (the three dimensional gray surface it's not important)

As we can see, the orbits create three-dimensional tubes inside the $(x,y,z)$ configuration space. Below I present a zoom plot

Now I want the following: use the orbits as a guide in order to produce two hollow transparent tubes (red and green). The tubes should contain inside all the corresponding orbits and their shape should look like the following red tube

Is this task doable, using Mathematica, at all? And if so, how?

• The dimensions of the data sets {2222, 99, 3}, so that's 2222 orbits of 99-1 line segments each? – Feyre Feb 14 '17 at 14:17
• @Feyre Yep, that's right! – Vaggelis_Z Feb 14 '17 at 14:19
• How do you expect anyone to write this program? You have not made the data available anywhere. – bill s Feb 26 '17 at 19:48
• @bills I'm sorry but you are wrong! The complete data file is available through a hyperlink at the very first sentence of the post (data file in red). – Vaggelis_Z Feb 27 '17 at 9:40
• For all would-be answerers, I found the following code quite fast and convenient to import this large dataset: strm = OpenRead["mans_3D.out"]; Do[ReadList[strm, "String", 1]; orbit[i] = DeveloperToPackedArray@ReadList[strm, {Number, Number, Number}, 99];,{i, 2222}];Close[strm]; – LLlAMnYP Mar 6 '17 at 11:50

This is a partial answer in response to Vaggelis' comment.

First, importing the data:

strm = OpenRead["mans_3D.out"];
orbit[i] = DeveloperToPackedArray@ReadList[strm, {Number, Number, Number}, 99],
{i, 2222}]
Close[strm];


Next, sort each orbit by their lengths:

Evaluate[sorted/@Range[2222]] = SortBy[orbit/@Range[2222], Total[Norm /@ Differences[#]] &]


Some orbits seem to be localized near the origin, but approximately from sorted[1300] and upwards they all lie on the larger almost circular arms visible in OPs first figure.

First parametrize the longest orbit by arc-length:

parametrized[2222] =
Interpolation[{First@#, Rest@#} & /@
Transpose[{{0.}~Join~
Accumulate[(Norm /@ Differences@sorted[2222])]}~Join~
Transpose@sorted[2222]]]


Then parametrize the rest by arc-length, using the i+1'th orbit as an approximation for the i'th if we go out of range of the arc-length:

Do[parametrized[i] =
Interpolation[{First@#, Rest@#} & /@
Transpose[{{0.}~Join~Accumulate[(Norm /@ Differences@sorted[i])]}~
Join~Transpose@sorted[i]],
"ExtrapolationHandler" -> {parametrized[i + 1],
"WarningMessage" -> False}],
{i, 2221, 1300, -1}]


I assume and this answer relies on that if you go 20 "steps" along one orbit, say sorted[1500], you'll find yourself roughly in the same place if you follow sorted[2000] for the same 20 "steps". In that case, the general path of the collection of orbits is given by

Mean[Through[(parametrized /@ Range[1302, 1500])[x]]]


And this can be plotted by

Table[Mean[Through[(parametrized /@ Range[1302, 2222])[x]]], {x, 0, 47.4, .5}]
Graphics3D[Line@%]


This is far from perfect, but a starting point, nonetheless.

UPDATE
My thought about the phase space appears to have been useful. The following code:

strm = OpenRead["mans_3D.out"];
orbit[i] =
DeveloperToPackedArray@
ReadList[strm, {Number, Number, Number}, 99], {i, 2222}]
Close[strm];
Do[xyz[i] = (Rest@# + Most@#)/2 &@orbit[i], {i, 2222}]
Do[pxyz[i] = Differences@orbit[i], {i, 2222}]
Manipulate[
ListPlot[Table[{xyz[j][[i, k]], pxyz[j][[i, l]]}, {j, 2222}]], {i, 1,
98, 1}, {k, 1, 3, 1}, {l, 1, 3, 1}]
`

Basically, it plots the k-th component of the midpoint of the i-th line segment in every orbit against the length of the projection of said line segment on the l-th axis.

• I run your code but the result is just a line in 3D space which does not follow the full path of the manifolds. I suppose that producing 3D fitting tubes would be impossible, right? – Vaggelis_Z Mar 7 '17 at 16:03
• Like I said, this solution is based on several assumptions. Without much knowledge of the underlying problem its not that easy to take meaningful steps to solve this. Another idea that comes to mind is to plot the phase space. But here the underlying assumption is that the positions on all the orbits are sampled at 99 equally spaced points in time. – LLlAMnYP Mar 7 '17 at 17:29
• @Vaggelis_Z I've added the code for visualizing the phase-space, though I cannot say it really helps much in solving the problem, rather highlights its difficulty. – LLlAMnYP Mar 8 '17 at 7:45