4D Region Plot with multiple inequalities

Question

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.

Answer 1

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}

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]

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}

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]