3
$\begingroup$

enter image description here

I would like to put labels on vertices instead of putting a label on axes. I am not sure how this can be done. My specific question is the following. In the attached 3-d picture, I would like to remove the numbers 0,0.5 and 1. Currently, I have three labels for the three axes. I would like to remove them and instead place four labels (one for each vertex). I would really appreciate if someone could let me know how to do this.

Here is the code that I am using.

Clear[f, g, h, p, r, l, jac, u1, u2, u3, u4, G, x, y, z, sol, xinit, \
yinit, zinit, plotfunc0, plotfunc1]
r = 0.5;    (*Recombination parameter*)
G = {{6, 6, 6, 2}, {5, 5, 5, 
   1}, {5, 5, 5, 1}, {7, 7, 7, 3}};
u1[x_, y_, z_] = 
  G[[1, 1]]*x +  G[[1, 2]]*y + G[[1, 3]]*z +  
   G[[1, 4]]*(1 - x - y - z) ;
u2[x_, y_, z_] = 
  G[[2, 1]]*x +  G[[2, 2]]*y + G[[2, 3]]*z +  
   G[[2, 4]]*(1 - x - y - z);
u3[x_, y_, z_] = 
  G[[3, 1]]*x +  G[[3, 2]]*y + G[[3, 3]]*z +  
   G[[3, 4]]*(1 - x - y - z) ;
u4[x_, y_, z_] = 
  G[[4, 1]]*x +  G[[4, 2]]*y + G[[4, 3]]*z +  
   G[[4, 4]]*(1 - x - y - z) ;
ualpha[x_, y_, 
   z_] = (x*u1[x, y, z]) + (y*u2[x, y, z]) + (z*
     u3[x, y, z]) + ((1 - x - y - z)*u4[x, y, z]);
us[x_, y_, z_] = (x*u1[x, y, z]) + (y*u2[x, y, z]);
ua[x_, y_, z_] = (z*u3[x, y, z]) + ((1 - x - y - z)*u4[x, y, z]);
uc[x_, y_, z_] = (x*u1[x, y, z]) + (z*u3[x, y, z]);
ud[x_, y_, z_] = (y*u2[x, y, z]) + ((1 - x - y - z)*u4[x, y, z]);
F1[x_, y_, 
   z_] = ((1 - r)*x*u1[x, y, z]/ualpha[x, y, z]) + (r*us[x, y, z]*
     uc[x, y, z]/((ualpha[x, y, z])^2)) - x;
F2[x_, y_, 
   z_] = ((1 - r)*y*u2[x, y, z]/ualpha[x, y, z]) + (r*us[x, y, z]*
     ud[x, y, z]/((ualpha[x, y, z])^2)) - y;
F3[x_, y_, 
   z_] = ((1 - r)*z*u3[x, y, z]/ualpha[x, y, z]) + (r*ua[x, y, z]*
     uc[x, y, z]/((ualpha[x, y, z])^2)) - z;
nmax = 1000.0;
tmax = 500;
func0 = {};
tol = 0.000001;
func1 = {};
P0 = {};
P1 = {};
basin0 = 0;
basin1 = 0;
basinneq01 = 0;
plotfunc0 = {};
plotfunc1 = {};
p100 = {1, 0, 0};
For[k = 1, k <= nmax, k++, 
 region = ImplicitRegion[
   x + y + z <= 1 && x >= 0 && y >= 0 && z >= 0, {x, y, 
    z}];(*way to get uniform points from region*)
 rand = RandomPoint[region] ;
 solution = 
  NDSolve[{x'[t] == F1[x[t], y[t], z[t]], 
    y'[t] == F2[x[t], y[t], z[t]], z'[t] == F3[x[t], y[t], z[t]], 
    x[0] == rand[[1]], y[0] == rand[[2]], z[0] == rand[[3]]}, {x, y, 
    z}, {t, 0, tmax}];
 prox = Evaluate[{x[t], y[t], z[t]} /. solution] /. {t -> tmax};
 d0 = Norm[prox];
 If[d0 < tol, basin0 = basin0 + 1, 
  If[d0 > 1 - tol, basin1 = basin1 + 1]];
 (*If[d0>tol&&d1>tol,basinneq01=basinneq01+1,If[d0<tol,basin0=basin0+\
1,If[d1<tol, basin1=basin1+1]]];*)
 
 If[d0 < tol, 
  plotfunc0 = 
   ParametricPlot3D[{x[t], y[t], z[t]} /. solution, {t, 0, tmax}, 
     PlotRange -> {{0, 1}, {0, 1}, {0, 1}}, 
     BaseStyle -> Arrowheads[{0, .01, 0.01, 0}], 
     PlotStyle -> {Red, Thin}, Boxed -> False, 
     AxesStyle -> Directive[Black, Bold, Thick, 16], 
     AxesEdge -> {{-1, -1}, {-1, -1}, {-1, -1}}, 
     AxesLabel -> {"sc", "sd", "ac"}] /. Line -> Arrow, 
  plotfunc1 = 
   ParametricPlot3D[{x[t], y[t], z[t]} /. solution, {t, 0, tmax}, 
     PlotRange -> {{0, 1}, {0, 1}, {0, 1}}, 
     BaseStyle -> Arrowheads[{0, .001, 0.001, 0}], 
     PlotStyle -> {Blue, Thin}, Boxed -> False, 
     AxesStyle -> Directive[Black, Bold, Thick, 16], 
     AxesEdge -> {{-1, -1}, {-1, -1}, {-1, -1}}, 
     AxesLabel -> {"sc", "sd", "ac"}] /. Line -> Arrow];
 AppendTo[func0, plotfunc0];
 AppendTo[func1, plotfunc1]]
p1 = Graphics3D[{Black, Opacity[0.1], 
    HalfPlane[{{1, 0, 0}, {0, 1, 0}}, {0, -1, 0}], 
    HalfPlane[{{0, 0, 1}, {0, 1, 0}}, {0, -1, 0}], 
    HalfPlane[{{0, 0, 1}, {1, 0, 0}}, {-1, 0, 0}]}];
Show[func0, func1, p1]
basin0 = basin0/nmax
basin1 = basin1/nmax
TimeUsed[]
$\endgroup$

1 Answer 1

5
$\begingroup$

enter image description here

We can use Simplex[3] as the plotting region with the desired look. We use BoundaryDiscretizeRegion to discretize it and use the options MeshCellLabel and MeshCellStyle to label and style various cells:

labeledsimplex = BoundaryDiscretizeRegion[Simplex[3], 
   MaxCellMeasure -> Infinity, 
   MeshCellStyle -> {2 -> Opacity[.2, Gray], 
        {1, 6 | 2 | 3} -> Directive[Thick, Opacity[1], Black], 
        1 -> Directive[Gray, Thin]}, 
   MeshCellLabel -> Prepend[{0, 1} -> Style["ad", 16, Bold] ][
     {#, #2} -> Placed[Style[#3, 16, Bold], #4] & @@@ 
      Thread[{1, {2, 3, 6}, {"sc", "sd", "ac"}, {-.1,1.1,1.1}}]]]

enter image description here

Since OP's code crashed my session, I use some 3D plot with lines contained in the simplex:

SeedRandom[1];
func1 = BSplineFunction@RandomPoint[Simplex[3], 100];
func2 = BSplineFunction@RandomPoint[Simplex[3], 100];

plots = ParametricPlot3D[{func1[t], func2[t]}, {t, 0, 1}, 
   ImageSize -> Large, 
   BaseStyle -> 
    Arrowheads[ConstantArray[Medium, 40], Appearance -> "Projected"], 
   PlotStyle -> {Directive[Thin, Red], Directive[Thin, Blue]}, 
   Boxed -> False, Axes -> False] /. Line -> Arrow

enter image description here

The picture at the top is obtained using

Show[plots, labeledsimplex,
 PlotRange -> All, PlotRangePadding -> 0, ViewPoint -> {.3, 2, .3}]

Update: An alternative approach using custom Arrowheads to render axes:

simplex = BoundaryDiscretizeRegion[Simplex[3], 
   MaxCellMeasure -> Infinity, 
   MeshCellStyle -> {2 -> Opacity[.2, Gray], 
     1 -> Directive[Thin, GrayLevel[.1]]}];

labeledAxes = Graphics3D @ 
   {Text[Style["ad", 16, Bold, Black], {0, 0, 0}, {-1, -1}],
    Black, Thick, 
    MapThread[{Arrowheads[{{Automatic,1, 
         {Graphics3D[Inset[Style[#, 16, Bold, Black], {0, 0, 0}, #2]], 0}}}], 
       Arrow[{{0, 0, 0}, 1.1 #3}]} &, 
     {{"sc", "sd", "ac"}, {{1, 0}, {-1, 1}, {0, -1}}, IdentityMatrix[3]}]};

Show[plots, simplex, labeledAxes, PlotRange -> All, 
  ViewPoint -> {.3, 2, .3}]

enter image description here

$\endgroup$
3
  • $\begingroup$ Thanks a lot. This is almost what I need in the final figure. Is it possible to remove the numbers 0 and 1 at the vertices and place four labels in their position? So in the final figure, I want the labels 'sc', 'sd' and 'ac' at the positions where the number 1 appears. Also at the position where '0' appears, I need to put a label 'ad'. $\endgroup$
    – egt123
    Sep 24, 2021 at 9:43
  • $\begingroup$ @egt123, please see the updated version, $\endgroup$
    – kglr
    Sep 24, 2021 at 9:55
  • $\begingroup$ Perfect, Thanks! $\endgroup$
    – egt123
    Sep 24, 2021 at 10:11

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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