1
$\begingroup$

I am trying to remove certain parts from my 3d-plots and also add labels to the vertices. In the attached plot, I would only like to keep the 3d-simplex with all the blue lines. I would like to remove the extra axes. In addition, I would like to add labels 'X', 'Y' and 'Z' to the vertices of the simplex. Any help will be greatly appreciated.

The code has two plots, one plot is the simplex joining the points (1,0,0), (0,1,0) and (0,0,1) and the second plot is the trajectories of certain quantities which am interested in. The three quantities of my interest always sump up to 1 and hence lie on the simplex at all times. Here is the code am using:

Clear[f, g, h, p, r, l, jac, u1, u2, u3, u4, u5, G, plotfunc0]
r = 0.3;  
g = 0.5;
b = 0.1/10;  
c = 0.2/10;
G = {{0, 1 + g + b + c, b + c, 1 + g, b, 1 + g + b}, {1 - g - b - c, 
    1, 1 - g, 1 - b - c, 1 - g - c, 1 - c}, {-b - c, 1 + g, 0, 
    1 + g - b - c, -c, 1 + g - c}, {1 - g, 1 + b + c, 1 - g + b + c, 
    1, 1 - g + b, 1 + b}, {-b, 1 + g + c, c, 1 + g - b, 0, 
    1 + g}, {1 - g - b, 1 + c, 1 - g + c, 1 - b, 1 - g, 1}};
u1[hH_, dH_, hD_, dD_, hV_] = 
  G[[1, 1]]*hH +  G[[1, 2]]*dH + G[[1, 3]]*hD +  G[[1, 4]]*dD +  
   G[[1, 5]]*hV +  G[[1, 6]]*(1 - hH - dH - hD - dD - hV);
u2[hH_, dH_, hD_, dD_, hV_] = 
 G[[2, 1]]*hH +  G[[2, 2]]*dH + G[[2, 3]]*hD +  G[[2, 4]]*dD +  
  G[[2, 5]]*hV +  G[[2, 6]]*(1 - hH - dH - hD - dD - hV); 
u3[hH_, dH_, hD_, dD_, hV_] = 
 G[[3, 1]]*hH +  G[[3, 2]]*dH + G[[3, 3]]*hD +  G[[3, 4]]*dD +  
  G[[3, 5]]*hV +  G[[3, 6]]*(1 - hH - dH - hD - dD - hV);
u4[hH_, dH_, hD_, dD_, hV_] = 
  G[[4, 1]]*hH +  G[[4, 2]]*dH + G[[4, 3]]*hD +  G[[4, 4]]*dD +  
   G[[4, 5]]*hV +  G[[4, 6]]*(1 - hH - dH - hD - dD - hV);
u5[hH_, dH_, hD_, dD_, hV_] = 
  G[[5, 1]]*hH +  G[[5, 2]]*dH + G[[5, 3]]*hD +  G[[5, 4]]*dD +  
   G[[5, 5]]*hV +  G[[5, 6]]*(1 - hH - dH - hD - dD - hV);
u6[hH_, dH_, hD_, dD_, hV_] = 
  G[[6, 1]]*hH +  G[[6, 2]]*dH + G[[6, 3]]*hD +  G[[6, 4]]*dD +  
   G[[6, 5]]*hV +  G[[6, 6]]*(1 - hH - dH - hD - dD - hV);
ualpha[hH_, dH_, hD_, dD_, 
   hV_] = (hH*u1[hH, dH, hD, dD, hV]) + (dH*
     u2[hH, dH, hD, dD, hV]) + (hD*u3[hH, dH, hD, dD, hV]) + (dD*
     u4[hH, dH, hD, dD, hV]) + (hV*
     u5[hH, dH, hD, dD, hV]) + ((1 - hH - dH - hD - dD - hV)*
     u6[hH, dH, hD, dD, hV]);
uh[hH_, dH_, hD_, dD_, 
   hV_] = (hH*u1[hH, dH, hD, dD, hV]) + (hD*
     u3[hH, dH, hD, dD, hV]) + (hV*u5[hH, dH, hD, dD, hV]);
ud[hH_, dH_, hD_, dD_, 
   hV_] = (dH*u2[hH, dH, hD, dD, hV]) + (dD*
     u4[hH, dH, hD, dD, hV]) + ((1 - hH - dH - hD - dD - hV)*
     u6[hH, dH, hD, dD, hV]);
uH[hH_, dH_, hD_, dD_, 
   hV_] = (hH*u1[hH, dH, hD, dD, hV]) + (dH*u2[hH, dH, hD, dD, hV]);
uD[hH_, dH_, hD_, dD_, 
   hV_] = (hD*u3[hH, dH, hD, dD, hV]) + (dD*u4[hH, dH, hD, dD, hV]);
uV[hH_, dH_, hD_, dD_, 
   hV_] = (hV*u5[hH, dH, hD, dD, hV]) + ((1 - hH - dH - hD - dD - hV)*
     u6[hH, dH, hD, dD, hV]);
F1[hH_, dH_, hD_, dD_, 
   hV_] = ((1 - r)*hH*
     u1[hH, dH, hD, dD, hV]/ualpha[hH, dH, hD, dD, hV]) + (r*
     uh[hH, dH, hD, dD, hV]*
     uH[hH, dH, hD, dD, hV]/((ualpha[hH, dH, hD, dD, hV])^2)) - hH;
F2[hH_, dH_, hD_, dD_, 
   hV_] = ((1 - r)*dH*
     u2[hH, dH, hD, dD, hV]/ualpha[hH, dH, hD, dD, hV]) + (r*
     ud[hH, dH, hD, dD, hV]*
     uH[hH, dH, hD, dD, hV]/((ualpha[hH, dH, hD, dD, hV])^2)) - dH;
F3[hH_, dH_, hD_, dD_, 
   hV_] = ((1 - r)*hD*
     u3[hH, dH, hD, dD, hV]/ualpha[hH, dH, hD, dD, hV]) + (r*
     uh[hH, dH, hD, dD, hV]*
     uD[hH, dH, hD, dD, hV]/((ualpha[hH, dH, hD, dD, hV])^2)) - hD;
F4[hH_, dH_, hD_, dD_, 
   hV_] = ((1 - r)*dD*
     u4[hH, dH, hD, dD, hV]/ualpha[hH, dH, hD, dD, hV]) + (r*
     ud[hH, dH, hD, dD, hV]*
     uD[hH, dH, hD, dD, hV]/((ualpha[hH, dH, hD, dD, hV])^2)) - dD;
F5[hH_, dH_, hD_, dD_, 
   hV_] = ((1 - r)*hV*
     u5[hH, dH, hD, dD, hV]/ualpha[hH, dH, hD, dD, hV]) + (r*
     uh[hH, dH, hD, dD, hV]*
     uV[hH, dH, hD, dD, hV]/((ualpha[hH, dH, hD, dD, hV])^2)) - hV;
nmax = 100.0;
tmax = 1000000;
func0 = {};
P0 = {};
plotfunc0 = {};
For[k = 1, k <= nmax, k++, 
 region = ImplicitRegion[
   hH + dH + hD + dD + hV <= 1 && hH >= 0 && dH >= 0 && hD >= 0 && 
    dD >= 0 && hV >= 0, {hH, dH, hD, dD, 
    hV}];(*way to get uniform points from region*)
 rand = RandomPoint[region] ;
 solution = 
  NDSolve[{hH'[t] == F1[hH[t], dH[t], hD[t], dD[t], hV[t]], 
    dH'[t] == F2[hH[t], dH[t], hD[t], dD[t], hV[t]], 
    hD'[t] == F3[hH[t], dH[t], hD[t], dD[t], hV[t]], 
    dD'[t] == F4[hH[t], dH[t], hD[t], dD[t], hV[t]], 
    hV'[t] == F5[hH[t], dH[t], hD[t], dD[t], hV[t]], 
    hH[0] == rand[[1]], dH[0] == rand[[2]], hD[0] == rand[[3]], 
    dD[0] == rand[[4]], hV[0] == rand[[5]]}, {hH, dH, hD, dD, hV}, {t,
     0, tmax}];
 plotfunc0 = 
  ParametricPlot3D[{hH[t] + dH[t], hD[t] + dD[t], 
      1 - hH[t] - dH[t] - hD[t] - dD[t]} /. solution, {t, 0, tmax}, 
    BaseStyle -> Arrowheads[{0, .01, 0.01, 0}], 
    PlotStyle -> {Blue, Thin}, Boxed -> False, 
    PlotRange -> {{0, 1}, {0, 1}, {0, 1}}] /. Line -> Arrow;
 AppendTo[func0, plotfunc0]]
p1 = Graphics3D[Simplex[{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}], 
   Boxed -> False];
Show[func0, p1]

enter image description here

$\endgroup$
2
  • $\begingroup$ Show[func0, p1, Graphics3D[MapThread[ Text[#, 1.05 #2] &, { {"X", "Y", "Z"}, {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}}]], Axes -> False]? $\endgroup$
    – kglr
    Jul 5, 2021 at 9:21
  • $\begingroup$ Great, it is working. Thanks ! $\endgroup$
    – egt123
    Jul 5, 2021 at 10:07

1 Answer 1

2
$\begingroup$

A bit more elementary than kglr's comment, and with the caveat that it is not clear what label you want to place where, replace your last two commands with

p1 = Graphics3D[{Simplex[{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}],
    Text["X", {.55, -.1, .55}],
    Text["Y", {-.1, .55, .55}],
    Text["Z", {.55, .55, -.1}]}, Boxed -> False];
Show[func0, p1, Axes -> False]

to get something like

enter image description here

$\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.