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$ Commented Jul 5, 2021 at 9:21
  • $\begingroup$ Great, it is working. Thanks ! $\endgroup$ Commented 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$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.