1
$\begingroup$

I am trying to draw a polytope with 4 variables. These 4 variables are probabilities so their lower bounds are all 0 and upper bounds are all 1.

Here are the inequalities that define the polytope: $$\alpha\geq 2\beta, \quad 2\sigma\geq\gamma,\quad 2\alpha\geq3\gamma,\quad3\sigma\geq2\beta,\quad\alpha+\beta+\sigma+\gamma=1$$

I think what I need to do is draw a 3D plot whose axes are $\alpha,\beta,\sigma$ and a color coding for $\gamma$. Can anyone help me with drawing this plot please? Thank you in advance.

$\endgroup$
2
$\begingroup$

Using color as the fourth dimension has severe limitations for regions that are solid in that you can only see the color of the surface of the region. While Opacity could be used to see "into" the solid region, the colors would be muddled together and you would not be able to appreciate the fourth dimension.

ineq = α >= 2 β && 2 σ >= γ && 2 α >= 3 γ && 
     3 σ >= 2 β /. γ -> 1 - (α + β + σ) // Simplify;

EDIT: You can use Manipulate to peal back the boundaries to see the inner values

EDIT 2: The color range for the plot needs to be adjusted to the range of γ.

Determining the range of γ

#[{1 - (α + β + σ), α >= 2 β, 
    2 σ >= γ, 2 α >= 3 γ, 
    3 σ >= 2 β,
    α + β + σ + γ == 1, 0 <= α <= 1, 
    0 <= β <= 1, 0 <= σ <= 1}, {α, β, σ}, 
   Reals] & /@ {MinValue, MaxValue}

enter image description here

Rescaling for -3/2 <= γ <= 1/3

Manipulate[Module[
  {ineq = α >= 2 β && 2 σ >= γ && 2 α >= 3 γ && 
       3 σ >= 2 β /. γ -> 1 - (α + β + σ) //
     Simplify},
  Legended[
   RegionPlot3D[
    ineq && αlb < α < αub && βlb < β < βub && σlb < σ < σub,
    {α, 0, 1}, {β, 0, 1}, {σ, 0, 1},
    AxesLabel -> (Style[#, 14, Bold] & /@ {α, β, σ}),
    PlotPoints -> 100,
    ColorFunction ->
     Function[{α, β, σ}, ColorData["Rainbow"][
       Rescale[1 - (α + β + σ), {-3/2, 1/3}]]]],
   BarLegend[{"Rainbow", {-3/2, 1/3}}]]],
 {{αlb, 0}, 0, 0.98, 0.01, Appearance -> "Labeled"},
 {{αub, 1}, αlb + 0.01, 1, 0.01, Appearance -> "Labeled"},
 {{βlb, 0}, 0, 0.48, 0.01, Appearance -> "Labeled"},
 {{βub, 0.5}, βlb + 0.01, 0.5, 0.01, Appearance -> "Labeled"},
 {{σlb, 0}, 0, 0.98, 0.01, Appearance -> "Labeled"},
 {{σub, 1}, σlb + 0.01, 1, 0.01, Appearance -> "Labeled"},
 SynchronousUpdating -> False]

enter image description here

EDIT 3: I forgot to restrict γ to interval {0, 1}. This significantly reduces the region of interest.

#[{1 - (α + β + σ), α >= 2 β, 
    2 σ >= γ, 2 α >= 3 γ, 
    3 σ >= 2 β, α + β + σ + γ == 1, 
    0 <= α <= 1, 0 <= β <= 1, 0 <= σ <= 1, 
    0 <= γ <= 1}, {α, β, σ}, Reals] & /@ {MinValue,
   MaxValue}

enter image description here

Manipulate[
 Module[{ineq = (α >= 2 β && 2 σ >= γ && 
        2 α >= 3 γ && 3 σ >= 2 β && 
        0 <= α <= 1 && 0 <= β <= 1 && 0 <= σ <= 1 && 
        0 <= γ <= 1) /. γ -> 
       1 - (α + β + σ) // Simplify}, 
  Legended[RegionPlot3D[
    ineq && αlb < α < αub && βlb < β < βub && σlb < σ < σub, 
     {α, 0, 1}, {β, 0, 1}, {σ, 0, 1}, 
    AxesLabel -> (Style[#, 14, Bold] & /@ {α, β, σ}), 
    PlotPoints -> 100, 
    ColorFunction -> 
     Function[{α, β, σ}, 
      ColorData["Rainbow"][
       Rescale[1 - (α + β + σ), {0, 1/3}]]]], 
   BarLegend[{"Rainbow", {0, 1/3}}]]], {{αlb, 0}, 0, 0.98, 0.01, 
  Appearance -> "Labeled"}, {{αub, 1}, αlb + 0.01, 1, 0.01, 
  Appearance -> "Labeled"}, {{βlb, 0}, 0, 0.28, 0.01, 
  Appearance -> "Labeled"}, {{βub, 0.3}, βlb + 0.01, 0.3, 0.01, 
  Appearance -> "Labeled"}, {{σlb, 0}, 0, 0.98, 0.01, 
  Appearance -> "Labeled"}, {{σub, 1}, σlb + 0.01, 1, 0.01, 
  Appearance -> "Labeled"}, SynchronousUpdating -> False]

enter image description here

$\endgroup$
  • $\begingroup$ Thank you so much for your help! Really love this plot $\endgroup$ – jackDanielle Nov 19 at 6:24

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.