Creating a tube from orbit collection

Question

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?

Many thanks in advance!

Answer 1

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

First, importing the data:

strm = OpenRead["mans_3D.out"];
Do[ReadList[strm, "String", 1];
orbit[i] = Developer`ToPackedArray@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"];
Do[ReadList[strm, "String", 1];
 orbit[i] = 
  Developer`ToPackedArray@
   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.