5
$\begingroup$

Problem

I am trying to plot Tubes made from the Tube function with varying radii. At one point there is a discontinuity and the radius of the tube is much large than it should be. I want to correct this error.

Context

I have a parametric curve, $g(t)$, which I will call the g curve. I am trying to plot level sets of a function which surrounds the g curve. The radius of the level set varies with the parameter $t$. When $t=0$ the radius is at its maximum and when $t=t_{max}$ the radius is at it's minimum. Attempt at plotting 4 of these levels sets, using Tube is based of the answer to a similar question.

The problem with my attempt is that for some reason the radius of the tube is too large at one end. This is clearly an error as the function with defines the radius is continuous but there is a huge discontinuity in the plot. I do not know what is causing the issue.

Notes

  • If there is something about this form of radialfun that is causing the error please let me know.
  • If you have any questions feel free to ask.

Example Code

(*Simulation Parameters and definitions*)
(*---------------------------------*)
Clear[f]
Clear[i, P, B]
f[P_, B_] := 1/2 P + 10 B/(1 + B);
tmax = 25;
eps = 0.001;
randNum = 100;
A = {{1/20, 1/4, 1/50}, {1/4, 1/26, 1/40}};
point = {16.666666666666735`, 0.`, 8.333333333333345`};

(*ODE System*)
ODEsys = {i'[t] == f[P[t], B[t]] - i[t], 
   P'[t] == 
    P[t] (1 - A[[1, 1]] P[t] - A[[1, 2]] B[t] - A[[1, 3]] i[t]), 
   B'[t] == B[t] (1 - A[[2, 2]] B[t] - A[[2, 3]] i[t])};

(*Generating parametric g curve.*)
(* Consider this section a  *)
(*--------------------------*)
set = List[];

While[Length[set] < randNum, 
 holdSet = 
  Join[set, Map[point + # &, RandomReal[{-eps, eps}, {randNum, 3}]]];
 set = Select[holdSet, #[[2]] >= 0 &];]

set = Drop[set, -(randNum - Length[set])];

(*Simulation*)
sol = ParametricNDSolveValue[{ODEsys, {P[0] == init1, B[0] == init2, 
     i[0] == init0}}, {P, B, i}, {t, 0, tmax}, {init1, init2, init0}];

(*Averging solution over multiple inital conditions.*)
gCurve[t_] := 
  Evaluate[Mean[Through /@ (sol[#[[1]], #[[2]], #[[3]]][t] & /@ set)]];
gPlot = ParametricPlot3D[gCurve[t], {t, 0, tmax}, PlotRange -> All, 
   ImageSize -> Large, PlotStyle -> Black];

(* Plot tubes of varying radiuses *)
(*----------------------------*)

(* Function which varies radius along the tube *)
radialfun[x_, radius_] := radius (Abs[x - 25]/50)^(1.20);

(* Controls the number of points plotted, 600+ gives a high quality \
plot *)
numPoints = 50;

(* Controls opacity *)
a = 0.2;

{plot, vals} = 
  Reap[ParametricPlot3D[gCurve[t], {t, 0, tmax}, 
    EvaluationMonitor :> Sow[t], MaxRecursion -> 0, 
    Method -> {"TubePoints" -> numPoints}, PlotPoints -> numPoints, 
    PlotStyle -> RGBColor[0., 0.5, 0.73, a] ]];
(* Plot different level sets of tubes*)
TubePlot1 = 
  plot /. Line[pts_, rest___] :> 
    Tube[pts, radialfun[vals[[1]], 1], rest];
TubePlot2 = 
  plot /. Line[pts_, rest___] :> 
    Tube[pts, radialfun[vals[[1]], 4], rest];
TubePlot3 = 
  plot /. Line[pts_, rest___] :> 
    Tube[pts, radialfun[vals[[1]], 10], rest];
TubePlot4 = 
  plot /. Line[pts_, rest___] :> 
    Tube[pts, radialfun[vals[[1]], 15], rest];

(*Show the plots of the different level tube sets*)
Show[gPlot, TubePlot1, TubePlot2, TubePlot3, TubePlot4, 
 LabelStyle -> Automatic, BoxStyle -> Dashing[{0.02, 0.02}], 
 Boxed -> None, PlotRangePadding -> 0, AxesOrigin -> Automatic, 
 AxesEdge -> {{1, 1, 1}, None, Automatic}, Ticks -> Automatic, 
 AxesStyle -> Thickness[0.005], ImageSize -> Large, 
 ImageResolution -> Automatic, PlotRangeClipping -> True, 
 PlotRange -> {{0, Automatic}, {0, Automatic}, {0, Automatic}}]

Picture enter image description here

$\endgroup$
3
$\begingroup$

It is necessary to set the shape of the Tube at the ends

(*Simulation Parameters and \
definitions*)(*---------------------------------*)Clear[f]
Clear[i, p, b]
f[p_, b_] := 1/2 p + 10 b/(1 + b);
tmax = 25;
eps = 0.001;
randNum = 100;
A = {{1/20, 1/4, 1/50}, {1/4, 1/26, 1/40}};
point = {16.666666666666735`, 0.`, 8.333333333333345`};

(*ODE System*)
ODEsys = {i'[t] == f[P[t], B[t]] - i[t], 
   P'[t] == 
    P[t] (1 - A[[1, 1]] P[t] - A[[1, 2]] B[t] - A[[1, 3]] i[t]), 
   B'[t] == B[t] (1 - A[[2, 2]] B[t] - A[[2, 3]] i[t])};

(*Generating parametric g curve.*)
(*Consider this section a*)
(*--------------------------*)
set = List[];

While[Length[set] < randNum, 
 holdSet = 
  Join[set, Map[point + # &, RandomReal[{-eps, eps}, {randNum, 3}]]];
 set = Select[holdSet, #[[2]] >= 0 &];]

set = Drop[set, -(randNum - Length[set])];

(*Simulation*)
sol = ParametricNDSolveValue[{ODEsys, {P[0] == init1, B[0] == init2, 
     i[0] == init0}}, {P, B, i}, {t, 0, tmax}, {init1, init2, init0}];

(*Averging solution over multiple inital conditions.*)
gCurve[t_] := 
  Evaluate[Mean[Through /@ (sol[#[[1]], #[[2]], #[[3]]][t] & /@ set)]];
gPlot = ParametricPlot3D[gCurve[t], {t, 0, tmax}, PlotRange -> All, 
   ImageSize -> Large, PlotStyle -> Black];

(*Plot tubes of varying radiuses*)
(*----------------------------*)

(*Function which varies radius along the tube*)
radialfun[x_, radius_] := radius (Abs[x - 25]/50)^(1.20);

(*Controls the number of points plotted,600+gives a high quality plot*)


numPoints = 50;

(*Controls opacity*)
a = 0.2;

{plot, vals} = 
  Reap[ParametricPlot3D[gCurve[t], {t, 0, tmax}, 
    EvaluationMonitor :> Sow[t], MaxRecursion -> 0, 
    Method -> {"TubePoints" -> numPoints}, PlotPoints -> numPoints, 
    PlotStyle -> RGBColor[0., 0.5, 0.73, a]]];
(*Plot different level sets of tubes*)
TubePlot1 = 
  plot /. Line[pts_, rest___] :> {CapForm["Butt"], 
     Tube[pts, radialfun[vals[[1]], 1], rest]};
TubePlot2 = 
  plot /. Line[pts_, rest___] :> {CapForm["Butt"], 
     Tube[pts, radialfun[vals[[1]], 4], rest]};
TubePlot3 = 
  plot /. Line[pts_, rest___] :> {CapForm["Butt"], 
     Tube[pts, radialfun[vals[[1]], 10], rest]};
TubePlot4 = 
  plot /. Line[pts_, rest___] :> {CapForm["Butt"], 
     Tube[pts, radialfun[vals[[1]], 15], rest]};

(*Show the plots of the different level tube sets*)
Show[gPlot, TubePlot1, TubePlot2, TubePlot3, TubePlot4, 
 LabelStyle -> Automatic, BoxStyle -> Dashing[{0.02, 0.02}], 
 Boxed -> None, PlotRangePadding -> 0, AxesOrigin -> Automatic, 
 AxesEdge -> {{1, 1, 1}, None, Automatic}, Ticks -> Automatic, 
 AxesStyle -> Thickness[0.005], ImageSize -> Large, 
 ImageResolution -> Automatic, PlotRangeClipping -> True, 
 PlotRange -> {{-5, Automatic}, {-10, Automatic}, {-5, Automatic}}]

fig1 The peculiarity of the curve along which the Tube is constructed is the concentration of points at the ends, with a uniform breakdown of t along the curve. The function radialfun[] changes almost linearly by vals[[1]]. Therefore, a sharp expansion effect occurs at the edges.

{ListPlot[{radialfun[vals[[1]], 1], radialfun[vals[[1]], 4], 
  radialfun[vals[[1]], 10], radialfun[vals[[1]], 15]}],
ListPointPlot3D[Table[gCurve[t], {t, 0, tmax, .02*tmax}]]}

fig2

| improve this answer | |
$\endgroup$
  • $\begingroup$ Apologies for not replying earlier. Your explanation was very helpful. My question is what types of radialfun will cause this expansion effect? Are there functions that do not have this expansion effect? $\endgroup$ – AzJ Feb 26 '19 at 23:57
  • 1
    $\begingroup$ @AzJ Use radialfun[x_, radius_] := radius (Abs[gCurve[x] - 25]/50)^(1.20); $\endgroup$ – Alex Trounev Feb 27 '19 at 1:36

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.